Skip to content

Commit 1c7cc85

Browse files
roconnor-blockstreamroconnor-blockstream
committed
Haskell implementation of Codex32
1 parent 1a1c22a commit 1c7cc85

16 files changed

+1192
-0
lines changed

‎haskell/Codex32.cabal

+43
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
cabal-version: 3.0
2+
name: codex32
3+
version: 0.0.0
4+
license: MIT
5+
author: Russell O'Connor
6+
maintainer: [email protected]
7+
copyright: (c) 2025 Blockstream
8+
build-type: Simple
9+
10+
library
11+
exposed-modules: Codex32,
12+
Codex32.Error,
13+
Codex32.Lfsr,
14+
Codex32.Linear,
15+
Codex32.Polynomial,
16+
Codex32.Word10,
17+
Codex32.Word5,
18+
build-depends: base >=4.18 && <4.22,
19+
array >= 0.5 && <0.6,
20+
comonad >= 5.0 && <5.1,
21+
streams >=3.3 && <3.4,
22+
default-language: Haskell2010
23+
24+
test-suite codex32-test
25+
type: exitcode-stdio-1.0
26+
hs-source-dirs: test
27+
main-is: Tests.hs
28+
other-modules: TestVectors,
29+
build-depends: base >=4.18 && <4.22,
30+
codex32,
31+
tasty,
32+
tasty-quickcheck,
33+
default-language: Haskell2010
34+
35+
executable codex32
36+
hs-source-dirs: exec
37+
main-is: Main.hs
38+
build-depends: base
39+
, codex32
40+
, optparse-applicative
41+
, prettyprinter
42+
, text
43+
default-language: Haskell2010

‎haskell/Codex32.hs

+164
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,164 @@
1+
-- Copyright (c) 2025 Blockstream
2+
--
3+
-- Permission is hereby granted, free of charge, to any person obtaining a copy
4+
-- of this software and associated documentation files (the "Software"), to deal
5+
-- in the Software without restriction, including without limitation the rights
6+
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
7+
-- copies of the Software, and to permit persons to whom the Software is
8+
-- furnished to do so, subject to the following conditions:
9+
--
10+
-- The above copyright notice and this permission notice shall be included in
11+
-- all copies or substantial portions of the Software.
12+
--
13+
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14+
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15+
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16+
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17+
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
18+
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
19+
-- THE SOFTWARE.
20+
module Codex32 where
21+
22+
import Control.Monad (guard)
23+
import Data.Maybe (fromMaybe, listToMaybe)
24+
import Data.Word (Word8)
25+
import Data.Char (isAlpha, isDigit, isLower, isUpper, toLower)
26+
import Data.Bits (testBit)
27+
28+
import Codex32.Polynomial
29+
import Codex32.Word5
30+
import Codex32.Word10
31+
32+
fromBytes :: [Word8] -> [Word5]
33+
fromBytes bytes = go $ bits ++ replicate ((negate (length bits)) `mod` 5) False
34+
where
35+
bits = bytes >>= \b -> [testBit b i | i <- [7,6..0]]
36+
go [] = []
37+
go (a:b:c:d:e:l) = w:go l
38+
where
39+
w = sum $ zipWith f [a,b,c,d,e] (word5 <$> [16, 8, 4, 2, 1])
40+
f True v = v
41+
f False v = 0
42+
43+
toBytes :: [Word5] -> [Word8]
44+
toBytes l = go $ bits
45+
where
46+
bits = l >>= \(UnsafeWord5 b) -> [testBit b i | i <- [4,3..0]]
47+
go (a:b:c:d:e:f:g:h:l) = w:go l
48+
where
49+
w = sum $ zipWith fn [a,b,c,d,e,f,g,h] [128, 64, 32, 16, 8, 4, 2, 1]
50+
fn True v = v
51+
fn False v = 0
52+
go _ = []
53+
54+
hrpExpand str = [1] ++ [word5 (fromEnum x `div` 32) | x <- str] ++ [0] ++ [word5 (fromEnum x) | x <- str]
55+
56+
-- Specification of BCH code of degree 2 over GF[32]
57+
data Spec = Spec { specPrefix :: String -- Must be lowercase
58+
, specBase :: Word10
59+
, specFcr :: Int -- First consecutive root
60+
, specDistance :: Int
61+
, specTarget :: [Word5] -- Must be have length equal to specDegree.
62+
}
63+
specHrp = hrpExpand . specPrefix
64+
specLength spec = fromMaybe err (order (specBase spec))
65+
where
66+
err = error "Codex32.specLength: zero base"
67+
specDataLength spec = specLength spec - specDegree spec
68+
specRoots spec = [specBase spec^(i + specFcr spec) | i <- [0..specDistance spec-1]]
69+
specGenerator spec = foldr1 monicMult (minPoly <$> specRoots spec)
70+
specBias :: Spec -> Poly Word5
71+
specBias = reverse . specTarget
72+
specDegree = length . specGenerator
73+
74+
residue :: Spec -> [Word5] -> Poly Word5
75+
residue spec body = p `polyMod` generator
76+
where
77+
generator = specGenerator spec
78+
p = reverse $ specHrp spec ++ body
79+
80+
codex32Prefix = "ms"
81+
codex32Spec :: Spec
82+
codex32Spec = Spec { specPrefix = codex32Prefix
83+
, specBase = Word10 0 (read "G")
84+
, specFcr = 77
85+
, specDistance = 8
86+
, specTarget = fromRight (fromString "secretshare32")
87+
}
88+
89+
codex32LongSpec :: Spec
90+
codex32LongSpec = Spec { specPrefix = codex32Prefix
91+
, specBase = Word10 (read "E") (read "X")
92+
, specFcr = 1019
93+
, specDistance = 8
94+
, specTarget = fromRight (fromString "secretshare32ex")
95+
}
96+
97+
decodeErrString :: String -> Maybe (String, [Either Char Word5])
98+
decodeErrString str | (all isLower `or` all isUpper) (filter isAlpha str) && Just '1' == listToMaybe xiferp = return (prefix, body)
99+
| otherwise = Nothing
100+
where
101+
(ydob, xiferp) = break (=='1') (reverse (toLower <$> str))
102+
prefix = reverse $ tail xiferp
103+
body = charsetMap <$> reverse ydob
104+
or p q x = p x || q x
105+
106+
decodeCodex32 str = do
107+
(pre, body) <- decodeErrString str
108+
guard $ pre == codex32Prefix
109+
let spec = if length body <= specLength codex32Spec then codex32Spec else codex32LongSpec
110+
return (spec, body)
111+
112+
decodeString :: String -> Maybe (String, [Word5])
113+
decodeString str = do
114+
(pre, errBody) <- decodeErrString str
115+
body <- traverse (either (const Nothing) Just) errBody
116+
return (pre, body)
117+
118+
createGenericChecksum spec = \dat -> residue spec (dat ++ target)
119+
where
120+
hrp = hrpExpand (specPrefix spec)
121+
generator = specGenerator spec
122+
target = specTarget spec
123+
124+
createGenericString spec = \dat -> prefix ++ "1" ++ toString (dat ++ reverse (createGenericChecksum spec dat))
125+
where
126+
prefix = specPrefix spec
127+
128+
129+
createCodex32Checksum l = createGenericChecksum spec l
130+
where
131+
spec | length l <= specDataLength codex32Spec = codex32Spec
132+
| otherwise = codex32LongSpec
133+
134+
verifyGenericChecksum spec l | length l <= specLength spec = bias == residue spec l
135+
| otherwise = False
136+
where
137+
hrp = hrpExpand (specPrefix spec)
138+
generator = specGenerator spec
139+
bias = specBias spec
140+
141+
verifyCodex32Checksum l = any (flip verifyGenericChecksum l) [codex32Spec, codex32LongSpec]
142+
143+
verifyGenericString spec str = (Just True ==) $ do
144+
(pre, dat) <- decodeString str
145+
guard $ pre == specPrefix spec
146+
return $ verifyGenericChecksum spec dat
147+
148+
verifyCodex32String str = (Just True ==) $ do
149+
(pre, dat) <- decodeString str
150+
guard $ pre == codex32Prefix
151+
return $ verifyCodex32Checksum dat
152+
153+
bip173Spec :: Spec
154+
bip173Spec = Spec { specPrefix = "bc"
155+
, specBase = Word10 (read "H") (read "F")
156+
, specFcr = 997
157+
, specDistance = 3
158+
, specTarget = fromRight (fromString "qqqqqp")
159+
}
160+
bip350Spec :: Spec
161+
bip350Spec = bip173Spec { specTarget = fromRight (fromString "4usv9r") }
162+
163+
fromRight (Right x) = x
164+
fromRight (Left _) = error "Program error: fromRight: Left"

‎haskell/Codex32/Error.hs

+118
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,118 @@
1+
-- Copyright (c) 2025 Blockstream
2+
--
3+
-- Permission is hereby granted, free of charge, to any person obtaining a copy
4+
-- of this software and associated documentation files (the "Software"), to deal
5+
-- in the Software without restriction, including without limitation the rights
6+
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
7+
-- copies of the Software, and to permit persons to whom the Software is
8+
-- furnished to do so, subject to the following conditions:
9+
--
10+
-- The above copyright notice and this permission notice shall be included in
11+
-- all copies or substantial portions of the Software.
12+
--
13+
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14+
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15+
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16+
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17+
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
18+
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
19+
-- THE SOFTWARE.
20+
module Codex32.Error where
21+
22+
import Control.Applicative ((<|>))
23+
import Control.Monad (guard)
24+
import Data.Either (isLeft)
25+
import Data.List (findIndices)
26+
27+
import Codex32
28+
import Codex32.Lfsr
29+
import qualified Codex32.Linear as Linear
30+
import Codex32.Polynomial
31+
import Codex32.Word10
32+
import Codex32.Word5
33+
34+
-- Find all roots of a given function.
35+
solveWord10 :: (Eq a, Num a) => (Word10 -> a) -> [Word10]
36+
solveWord10 f = filter (\x -> f x == 0) allWord10
37+
38+
-- Short convolution of two lists of numbers.
39+
-- convolution [a_0..a_n] [b_0..b_m] is [c_n..c_m]
40+
-- where c_i = a_0*b_i + ... + a_n*b_(i-n).
41+
-- Note: the second list must be at least as long as first list for the result to be non-empty.
42+
convolution :: Num a => [a] -> [a] -> [a]
43+
convolution as bs = go (reverse as) bs
44+
where
45+
go [] _ = repeat 0
46+
go (a:as) bs = zipWith (+) ((a *) <$> bs) (go as (tail bs))
47+
48+
-- Compute the error locator polynomial from a sequence of syndromes, given the erassure polynomial.
49+
-- Note: The resulting locator polynomial doesn't include the given erasures.
50+
-- To compute the full locator polynomial you will need to multiply the result by the given erasure polynomial.
51+
locatorPoly :: [Word10] -> Poly Word10 -> Poly Word10
52+
locatorPoly syndromes erasurePoly = connection (synthesize modifiedSyndromes)
53+
where
54+
modifiedSyndromes = convolution erasurePoly syndromes
55+
56+
-- Given erasure locations and the residue, run the BCH error correction algorithm returning the location and error values for those locations.
57+
-- This can find up to (specDistance spec - length erasureIx)/2 error locations in addition to the given erasure locations.
58+
-- Returns Nothing when error correction fails.
59+
-- Returns Just [] when given a zero checksumError and empty erasuresIxs.
60+
-- The length of the checksumError must be equal to the (specDegree spec)
61+
bchErrorCorrections :: Spec -> [Int] -> [Word5] -> Maybe [(Int, Word5)]
62+
bchErrorCorrections spec erasureIxs residue = do
63+
guard $ length erasureIxs <= length betas
64+
guard $ length locator == 1 + length roots
65+
corrections <- sequence [correct i l | i<-reverse [0..specLength spec-1], let l = recip (beta^i), l `elem` (roots ++ erasureRoots)]
66+
return corrections
67+
where
68+
generator = specGenerator spec
69+
fcr = specFcr spec
70+
beta = specBase spec
71+
betas = specRoots spec
72+
erasureRoots = (\i -> recip (beta^i)) <$> erasureIxs
73+
erasurePoly = foldr polyMult [1] [[-r, 1]|r <- erasureRoots]
74+
locator = locatorPoly syn erasurePoly
75+
checksumError = zipWith (-) residue (specBias spec)
76+
syn = horner (toWord10 <$> checksumError) <$> betas
77+
fullLocator = locator `polyMult` erasurePoly
78+
omega = take (length betas) $ syn `polyMult` fullLocator
79+
roots = solveWord10 $ horner locator
80+
correct i invR = do
81+
guard (0 == z)
82+
return $ (i, e)
83+
where
84+
Word10 e z = negate (horner omega invR * (invR^(fcr - 1) / horner (diff fullLocator) invR))
85+
86+
-- This error correctly algorithm can only correct erasures.
87+
-- However, unlike bchErrorCorrection it sometimes (but not always) correct up to (specDegree spec) many erasures.
88+
-- In particular it can always correct up to (specDegree spec) many erasures if they are all consecutive (a burst error).
89+
-- Returns Nothing when error correction fails.
90+
-- Returns Just [] when given a zero checksumError and empty erasuresIxs.
91+
-- The length of the checksumError must be equal to the (specDegree spec)
92+
linearErrorCorrections :: Spec -> [Int] -> [Word5] -> Maybe [(Int, Word5)]
93+
linearErrorCorrections spec erasureIxs residue = do
94+
Right solution <- return $ Linear.solver unknowns checksumError
95+
return $ zip erasureIxs solution
96+
where
97+
checksumError = zipWith (-) residue (specBias spec)
98+
powers = polyPowers (specGenerator spec)
99+
unknowns = map (powers!!) erasureIxs
100+
101+
-- Tries both the bchErrorCorrections and the linearErrorCorrections.
102+
errorCorrections :: Spec -> [Int] -> [Word5] -> Maybe [(Int, Word5)]
103+
errorCorrections spec erasureIxs residue = bchErrorCorrections spec erasureIxs residue
104+
<|> linearErrorCorrections spec erasureIxs residue
105+
106+
-- Given an alledged codex32 string, attempt to find the closest string that is a valid codex32 string.
107+
-- Returns Nothing if the implementation is unable to find a solution
108+
correctCodex32String :: String -> Maybe String
109+
correctCodex32String str = do
110+
(spec, body) <- decodeCodex32 str
111+
let erasureIxs = findIndices isLeft (reverse body)
112+
let zeroedBody = either (const 0) id <$> body
113+
corrections <- errorCorrections spec erasureIxs (residue spec zeroedBody)
114+
let corrected = foldr polySum (reverse zeroedBody) (expand <$> corrections)
115+
guard $ length corrected == length body
116+
return $ (specPrefix spec) ++ "1" ++ (toString . reverse $ corrected)
117+
where
118+
expand (i,e) = replicate i 0 ++ [e]

0 commit comments

Comments
 (0)