Haskell implementation of Codex32

haskell/Codex32.cabal

@@ -0,0 +1,43 @@
+cabal-version:      3.0
+name:               codex32
+version:            0.0.0
+license:             MIT
+author:              Russell O'Connor
+maintainer:          [email protected]
+copyright:           (c) 2025 Blockstream
+build-type:          Simple
+
+library
+  exposed-modules: Codex32,
+                   Codex32.Error,
+                   Codex32.Lfsr,
+                   Codex32.Linear,
+                   Codex32.Polynomial,
+                   Codex32.Word10,
+                   Codex32.Word5,
+  build-depends: base >=4.18 && <4.22,
+                 array >= 0.5 && <0.6,
+                 comonad >= 5.0 && <5.1,
+                 streams >=3.3 && <3.4,
+  default-language: Haskell2010
+
+test-suite codex32-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Tests.hs
+  other-modules: TestVectors,
+  build-depends: base >=4.18 && <4.22,
+                 codex32,
+                 tasty,
+                 tasty-quickcheck,
+  default-language: Haskell2010
+
+executable codex32
+  hs-source-dirs: exec
+  main-is: Main.hs
+  build-depends: base
+               , codex32
+               , optparse-applicative
+               , prettyprinter
+               , text
+  default-language: Haskell2010

haskell/Codex32.hs

@@ -0,0 +1,164 @@
+-- Copyright (c) 2025 Blockstream
+--
+-- Permission is hereby granted, free of charge, to any person obtaining a copy
+-- of this software and associated documentation files (the "Software"), to deal
+-- in the Software without restriction, including without limitation the rights
+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+-- copies of the Software, and to permit persons to whom the Software is
+-- furnished to do so, subject to the following conditions:
+--
+-- The above copyright notice and this permission notice shall be included in
+-- all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+-- THE SOFTWARE.
+module Codex32 where
+
+import Control.Monad (guard)
+import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Word (Word8)
+import Data.Char (isAlpha, isDigit, isLower, isUpper, toLower)
+import Data.Bits (testBit)
+
+import Codex32.Polynomial
+import Codex32.Word5
+import Codex32.Word10
+
+fromBytes :: [Word8] -> [Word5]
+fromBytes bytes = go $ bits ++ replicate ((negate (length bits)) `mod` 5) False
+  where
+    bits = bytes >>= \b -> [testBit b i | i <- [7,6..0]]
+    go [] = []
+    go (a:b:c:d:e:l) = w:go l
+     where
+      w = sum $ zipWith f [a,b,c,d,e] (word5 <$> [16, 8, 4, 2, 1])
+      f True v = v
+      f False v = 0
+
+toBytes :: [Word5] -> [Word8]
+toBytes l = go $ bits
+  where
+    bits = l >>= \(UnsafeWord5 b) -> [testBit b i | i <- [4,3..0]]
+    go (a:b:c:d:e:f:g:h:l) = w:go l
+     where
+      w = sum $ zipWith fn [a,b,c,d,e,f,g,h] [128, 64, 32, 16, 8, 4, 2, 1]
+      fn True v = v
+      fn False v = 0
+    go _ = []
+
+hrpExpand str = [1] ++ [word5 (fromEnum x `div` 32) | x <- str] ++ [0] ++ [word5 (fromEnum x) | x <- str]
+
+-- Specification of BCH code of degree 2 over GF[32]
+data Spec = Spec { specPrefix :: String -- Must be lowercase
+                 , specBase :: Word10
+                 , specFcr :: Int -- First consecutive root
+                 , specDistance :: Int
+                 , specTarget :: [Word5] -- Must be have length equal to specDegree.
+                 }
+specHrp = hrpExpand . specPrefix
+specLength spec = fromMaybe err (order (specBase spec))
+ where
+  err = error "Codex32.specLength: zero base"
+specDataLength spec = specLength spec - specDegree spec
+specRoots spec = [specBase spec^(i + specFcr spec) | i <- [0..specDistance spec-1]]
+specGenerator spec = foldr1 monicMult (minPoly <$> specRoots spec)
+specBias :: Spec -> Poly Word5
+specBias = reverse . specTarget
+specDegree = length . specGenerator
+
+residue :: Spec -> [Word5] -> Poly Word5
+residue spec body = p `polyMod` generator
+ where
+  generator = specGenerator spec
+  p = reverse $ specHrp spec ++ body
+
+codex32Prefix = "ms"
+codex32Spec :: Spec
+codex32Spec = Spec { specPrefix = codex32Prefix
+                   , specBase = Word10 0 (read "G")
+                   , specFcr = 77
+                   , specDistance = 8
+                   , specTarget = fromRight (fromString "secretshare32")
+                   }
+
+codex32LongSpec :: Spec
+codex32LongSpec = Spec { specPrefix = codex32Prefix
+                       , specBase = Word10 (read "E") (read "X")
+                       , specFcr = 1019
+                       , specDistance = 8
+                       , specTarget = fromRight (fromString "secretshare32ex")
+                       }
+
+decodeErrString :: String -> Maybe (String, [Either Char Word5])
+decodeErrString str | (all isLower `or` all isUpper) (filter isAlpha str) && Just '1' == listToMaybe xiferp = return (prefix, body)
+                    | otherwise = Nothing
+ where
+  (ydob, xiferp) = break (=='1') (reverse (toLower <$> str))
+  prefix = reverse $ tail xiferp
+  body = charsetMap <$> reverse ydob
+  or p q x = p x || q x
+
+decodeCodex32 str = do
+  (pre, body) <- decodeErrString str
+  guard $ pre == codex32Prefix
+  let spec = if length body <= specLength codex32Spec then codex32Spec else codex32LongSpec
+  return (spec, body)
+
+decodeString :: String -> Maybe (String, [Word5])
+decodeString str = do
+  (pre, errBody) <- decodeErrString str
+  body <- traverse (either (const Nothing) Just) errBody
+  return (pre, body)
+
+createGenericChecksum spec = \dat -> residue spec (dat ++ target)
+ where
+  hrp = hrpExpand (specPrefix spec)
+  generator = specGenerator spec
+  target = specTarget spec
+
+createGenericString spec = \dat -> prefix ++ "1" ++ toString (dat ++ reverse (createGenericChecksum spec dat))
+ where
+  prefix = specPrefix spec
+
+
+createCodex32Checksum l = createGenericChecksum spec l
+ where
+  spec | length l <= specDataLength codex32Spec = codex32Spec
+       | otherwise = codex32LongSpec
+
+verifyGenericChecksum spec l | length l <= specLength spec = bias == residue spec l
+                             | otherwise = False
+ where
+  hrp = hrpExpand (specPrefix spec)
+  generator = specGenerator spec
+  bias = specBias spec
+
+verifyCodex32Checksum l = any (flip verifyGenericChecksum l) [codex32Spec, codex32LongSpec]
+
+verifyGenericString spec str = (Just True ==) $ do
+  (pre, dat) <- decodeString str
+  guard $ pre == specPrefix spec
+  return $ verifyGenericChecksum spec dat
+
+verifyCodex32String str = (Just True ==) $ do
+  (pre, dat) <- decodeString str
+  guard $ pre == codex32Prefix
+  return $ verifyCodex32Checksum dat
+
+bip173Spec :: Spec
+bip173Spec = Spec { specPrefix = "bc"
+                  , specBase = Word10 (read "H") (read "F")
+                  , specFcr = 997
+                  , specDistance = 3
+                  , specTarget = fromRight (fromString "qqqqqp")
+                  }
+bip350Spec :: Spec
+bip350Spec = bip173Spec { specTarget = fromRight (fromString "4usv9r") }
+
+fromRight (Right x) = x
+fromRight (Left _) = error "Program error: fromRight: Left"

haskell/Codex32/Error.hs

@@ -0,0 +1,118 @@
+-- Copyright (c) 2025 Blockstream
+--
+-- Permission is hereby granted, free of charge, to any person obtaining a copy
+-- of this software and associated documentation files (the "Software"), to deal
+-- in the Software without restriction, including without limitation the rights
+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+-- copies of the Software, and to permit persons to whom the Software is
+-- furnished to do so, subject to the following conditions:
+--
+-- The above copyright notice and this permission notice shall be included in
+-- all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+-- THE SOFTWARE.
+module Codex32.Error where
+
+import Control.Applicative ((<|>))
+import Control.Monad (guard)
+import Data.Either (isLeft)
+import Data.List (findIndices)
+
+import Codex32
+import Codex32.Lfsr
+import qualified Codex32.Linear as Linear
+import Codex32.Polynomial
+import Codex32.Word10
+import Codex32.Word5
+
+-- Find all roots of a given function.
+solveWord10 :: (Eq a, Num a) => (Word10 -> a) -> [Word10]
+solveWord10 f = filter (\x -> f x == 0) allWord10
+
+-- Short convolution of two lists of numbers.
+-- convolution [a_0..a_n] [b_0..b_m] is [c_n..c_m]
+-- where c_i = a_0*b_i + ... + a_n*b_(i-n).
+-- Note: the second list must be at least as long as first list for the result to be non-empty.
+convolution :: Num a => [a] -> [a] -> [a]
+convolution as bs  = go (reverse as) bs
+ where
+  go [] _ = repeat 0
+  go (a:as) bs = zipWith (+) ((a *) <$> bs) (go as (tail bs))
+
+-- Compute the error locator polynomial from a sequence of syndromes, given the erassure polynomial.
+-- Note: The resulting locator polynomial doesn't include the given erasures.
+-- To compute the full locator polynomial you will need to multiply the result by the given erasure polynomial.
+locatorPoly :: [Word10] -> Poly Word10 -> Poly Word10
+locatorPoly syndromes erasurePoly = connection (synthesize modifiedSyndromes)
+  where
+   modifiedSyndromes = convolution erasurePoly syndromes
+
+-- Given erasure locations and the residue, run the BCH error correction algorithm returning the location and error values for those locations.
+-- This can find up to (specDistance spec - length erasureIx)/2 error locations in addition to the given erasure locations.
+-- Returns Nothing when error correction fails.
+-- Returns Just [] when given a zero checksumError and empty erasuresIxs.
+-- The length of the checksumError must be equal to the (specDegree spec)
+bchErrorCorrections :: Spec -> [Int] -> [Word5] -> Maybe [(Int, Word5)]
+bchErrorCorrections spec erasureIxs residue = do
+  guard $ length erasureIxs <= length betas
+  guard $ length locator == 1 + length roots
+  corrections <- sequence [correct i l | i<-reverse [0..specLength spec-1], let l = recip (beta^i), l `elem` (roots ++ erasureRoots)]
+  return corrections
+ where
+  generator = specGenerator spec
+  fcr = specFcr spec
+  beta = specBase spec
+  betas = specRoots spec
+  erasureRoots = (\i -> recip (beta^i)) <$> erasureIxs
+  erasurePoly = foldr polyMult [1] [[-r, 1]|r <- erasureRoots]
+  locator = locatorPoly syn erasurePoly
+  checksumError = zipWith (-) residue (specBias spec)
+  syn = horner (toWord10 <$> checksumError) <$> betas
+  fullLocator = locator `polyMult` erasurePoly
+  omega = take (length betas) $ syn `polyMult` fullLocator
+  roots = solveWord10 $ horner locator
+  correct i invR = do
+    guard (0 == z)
+    return $ (i, e)
+   where
+    Word10 e z = negate (horner omega invR * (invR^(fcr - 1) / horner (diff fullLocator) invR))
+
+-- This error correctly algorithm can only correct erasures.
+-- However, unlike bchErrorCorrection it sometimes (but not always) correct up to (specDegree spec) many erasures.
+-- In particular it can always correct up to (specDegree spec) many erasures if they are all consecutive (a burst error).
+-- Returns Nothing when error correction fails.
+-- Returns Just [] when given a zero checksumError and empty erasuresIxs.
+-- The length of the checksumError must be equal to the (specDegree spec)
+linearErrorCorrections :: Spec -> [Int] -> [Word5] -> Maybe [(Int, Word5)]
+linearErrorCorrections spec erasureIxs residue = do
+  Right solution <- return $ Linear.solver unknowns checksumError
+  return $ zip erasureIxs solution
+ where
+  checksumError = zipWith (-) residue (specBias spec)
+  powers = polyPowers (specGenerator spec)
+  unknowns = map (powers!!) erasureIxs
+
+-- Tries both the bchErrorCorrections and the linearErrorCorrections.
+errorCorrections :: Spec -> [Int] -> [Word5] -> Maybe [(Int, Word5)]
+errorCorrections spec erasureIxs residue = bchErrorCorrections spec erasureIxs residue
+                                       <|> linearErrorCorrections spec erasureIxs residue
+
+-- Given an alledged codex32 string, attempt to find the closest string that is a valid codex32 string.
+-- Returns Nothing if the implementation is unable to find a solution
+correctCodex32String :: String -> Maybe String
+correctCodex32String str = do
+  (spec, body) <- decodeCodex32 str
+  let erasureIxs = findIndices isLeft (reverse body)
+  let zeroedBody = either (const 0) id <$> body
+  corrections <- errorCorrections spec erasureIxs (residue spec zeroedBody)
+  let corrected = foldr polySum (reverse zeroedBody) (expand <$> corrections)
+  guard $ length corrected == length body
+  return $ (specPrefix spec) ++ "1" ++ (toString . reverse $ corrected)
+ where
+  expand (i,e) = replicate i 0 ++ [e]