diff --git a/haskell/Codex32.cabal b/haskell/Codex32.cabal new file mode 100644 index 0000000..89f80ab --- /dev/null +++ b/haskell/Codex32.cabal @@ -0,0 +1,43 @@ +cabal-version: 3.0 +name: codex32 +version: 0.0.0 +license: MIT +author: Russell O'Connor +maintainer: roconnor@blockstream.com +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 diff --git a/haskell/Codex32.hs b/haskell/Codex32.hs new file mode 100644 index 0000000..ad2ed5c --- /dev/null +++ b/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" diff --git a/haskell/Codex32/Error.hs b/haskell/Codex32/Error.hs new file mode 100644 index 0000000..46016d4 --- /dev/null +++ b/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] diff --git a/haskell/Codex32/GenPython.hs b/haskell/Codex32/GenPython.hs new file mode 100644 index 0000000..4f854d1 --- /dev/null +++ b/haskell/Codex32/GenPython.hs @@ -0,0 +1,80 @@ +-- 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 GenPython where + +import Data.List (foldl', intercalate) +import Data.Char (toUpper) +import qualified Numeric + +import Codex32 +import Polynomial +import Word5 +import Word10 + +hrp = specHrp codex32Spec +beta = specBase codex32Spec +betas = specRoots codex32Spec +generator = specGenerator codex32Spec -- word5 <$> [25, 27, 17, 8, 0, 25, 25, 25, 31, 27, 24, 16, 16] +genLength = specLength codex32Spec +target = specTarget codex32Spec + +gamma = specBase codex32LongSpec +gammas = specRoots codex32LongSpec +longGenerator = specGenerator codex32LongSpec +longTarget = specTarget codex32LongSpec + +powers = iterate (alpha*) 1 +genPowers gen = [map (a*) gen | a <- powers] +pack l = foldl' f 0 l + where + f x a = 2^5 * x + fromWord5 a + +showHex n = "0x" ++ Numeric.showHex n "" + +printPython long target gen hrp = do + putStrLn $ const ++ " = " ++ showHex (pack target) + putStrLn "" + putStrLn $ "def ms32_" ++ long ++ "polymod(values):" + putStrLn $ " GEN = [" ++ intercalate ", " (showHex . pack <$> take 5 (genPowers gen)) ++ "]" + putStrLn $ " residue = " ++ (showHex . pack $ hrp) + putStrLn $ " for v in values:" + putStrLn $ " b = (residue >> " ++ show (5 * (length gen - 1)) ++ ")" + putStrLn $ " residue = (residue & " ++ showHex (2 ^ (5 * (length gen - 1)) - 1) ++ ") << 5 ^ v" + putStrLn $ " for i in range(5):" + putStrLn $ " residue ^= GEN[i] if ((b >> i) & 1) else 0" + putStrLn $ " return residue" + putStrLn "" + putStrLn $ "def ms32_verify_" ++ long ++ "checksum(data):" + putStrLn $ " return ms32_" ++ long ++ "polymod(data) == " ++ const + putStrLn "" + putStrLn $ "def ms32_create_" ++ long ++ "checksum(data):" + putStrLn $ " values = data" + putStrLn $ " polymod = ms32_" ++ long ++ "polymod(values + [0] * " ++ show (length gen) ++ ") ^ " ++ const + putStrLn $ " return [(polymod >> 5 * (" ++ show (length gen - 1) ++ " - i)) & 31 for i in range(" ++ show (length gen) ++ ")]" + where + const = "MS32_" ++ (toUpper <$> long) ++ "CONST" + +main | checks = do + printPython "" target generator hrp + putStrLn "" + printPython "long_" longTarget longGenerator hrp + where + checks = length generator == length target + && length longGenerator == length longTarget diff --git a/haskell/Codex32/Lfsr.hs b/haskell/Codex32/Lfsr.hs new file mode 100644 index 0000000..7c3983b --- /dev/null +++ b/haskell/Codex32/Lfsr.hs @@ -0,0 +1,106 @@ +-- 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 for Linear Feedback Shift Registers +-- Synthesize of LFSRs. + +module Codex32.Lfsr + ( LFSR + , lfsrLength + , Poly, connection + , synthesize, generate + , validate + ) where + +import Control.Comonad +import Data.Foldable +import Data.List +import Data.Stream.Infinite (Stream(..)) +import qualified Data.Stream.Infinite as Stream + +import Codex32.Polynomial + +-- The contents of an LFSR. The only reason the coefficents and values are paired up is because an LFSR has equal number of coefficents and initial values. +data LFSRDatum a = LFSRDatum { coef :: a, value :: a } + +-- | A linear feedback shift register, including initial values. +newtype LFSR a = LFSR [LFSRDatum a] + +-- | Length of a 'LFSR'. +lfsrLength :: LFSR a -> Int +lfsrLength (LFSR l) = length l + +-- | The connection polynomial of a 'LFSR'. +-- The degree of the connection polynomial is at most 'lfsrLength'. +-- +-- Note: the resulting polynomials may not be normalized and may have trailing zeros. +connection :: Num a => LFSR a -> Poly a +connection (LFSR l) = 1 : map coef l + +-- | Generate an infinite stream of values from an 'LFSR', including the initial values from the 'LFSR' +generate :: Num a => LFSR a -> Stream a +generate (LFSR l) = result + where + len = length l + result = Stream.prepend (map value l) (extend (f . reverse . Stream.take len) result) + f = generateNext (map coef l) + +-- Interpret the coefficents from an LFSR and a (reversed) segment of the input values to generate the next value. +generateNext :: Num a => [a] -> [a] -> a +generateNext coef val = negate . sum $ zipWith (*) coef val + +-- | Given a sequence of values, find a minimal 'LFSR' that 'generate's that sequence. +synthesize :: (Foldable f, Eq a, Fractional a) => f a -> LFSR a +synthesize l = LFSR (zipWith LFSRDatum coef l') + where + l' = toList l + (coef, _) = synthesizeRec (reverse l') + +-- The Berlekamp-Massey Algorithm. +-- Given a reversed list of inputs, recursively compute the set of coefficents of a minimal 'LFSR' to generate that input, +-- paired with a helper set of coefficents used for updating the 'LFSR' for more inputs. +synthesizeRec :: (Eq a, Fractional a) => [a] -> ([a], [a]) +synthesizeRec [] = ([], [0]) +synthesizeRec (n:ns) = (next, nextAdj) + where + (coef, adjustment) = synthesizeRec ns + discrepency = n - generateNext coef ns + next | 0 == discrepency = coef + | otherwise = zipSum coef (map ((-discrepency)*) adjustment) + nextAdj | length next == length coef = 0:adjustment + | otherwise = map (/ discrepency) (1:coef) + +-- Similar to zip (+), but instead returns the longer of the two lists instead of the shorter of the two lists. +zipSum [] l = l +zipSum l [] = l +zipSum (a:as) (b:bs) = (a + b):(zipSum as bs) + +-- | Checks to see of 'synthesize' correctly produces a minimal 'lsfrLength' 'LFSR' for the given input. +validate :: (Eq a, Fractional a) => [a] -> Bool +validate l = all sound lfsrs && zero (head lfsrs) && and (zipWith complete lfsrs (tail lfsrs)) + where + lfsrs = [(x, length x, generate lfsr, lfsrLength lfsr) | x <- inits l, let lfsr = synthesize x] + sound (x, _, output, _) = x == Stream.take (length x) output + zero (_, _, _, n) = 0 == n + complete (_, _, outputN, n) (l, lenM, _, m) + | extending = m == n + | otherwise = m == n `max` (lenM - n) + where + extending = l == Stream.take lenM outputN diff --git a/haskell/Codex32/Linear.hs b/haskell/Codex32/Linear.hs new file mode 100644 index 0000000..eeb9c3e --- /dev/null +++ b/haskell/Codex32/Linear.hs @@ -0,0 +1,95 @@ +-- 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.Linear where + +import Data.List (findIndex, transpose) + +iden :: (Num a) => Int -> [[a]] +iden 1 = [[1]] +iden n = (1:replicate (n-1) 0):((0:) <$> iden (n-1)) + +u `dot` v = foldr (+) 0 $ zipWith (*) u v + +matrixApply m v = fmap (`dot` v) m + +matrixInv :: (Fractional a, Eq a) => [[a]] -> [[a]] +matrixInv m = drop size <$> foldr clearRow augment [0..size-1] + where + size = length m + augment = zipWith (++) m (iden size) + clearRow n m | c /= 0 = fmap clear pre ++ [newRow] ++ fmap clear post + | otherwise = clearRow n $ row : pre ++ post + where + (pre, row:post) = splitAt n m + c = recip $ m !! n !! n + newRow = fmap (c *) row + clear r = zipWith (-) r $ fmap (s *) newRow + where + s = r !! n + +-- Precondition: all lists of mat have the same length +reducedRowEchelon :: (Fractional a, Eq a) => [[a]] -> [[a]] +reducedRowEchelon mat | all null mat = mat + | any null mat = error "Linear.reducedRowEchelon: input not a matrix" + | otherwise = + case pivot of + Nothing -> map (0:) (reducedRowEchelon (map tail mat)) + Just ix -> let (a,b) = splitAt ix mat in process (b++a) + where + pivot = findIndex (\w -> head w /= 0) mat + process (w0:wn) = w0'':recurse + where + reduce w = zipWith (-) w (map (* (head w)) w0') + w0' = map (/ (head w0)) w0 + wn' = map (tail . reduce) wn + recurse = map (0:) (reducedRowEchelon wn') + w0'' = foldr backsubst w0' recurse + backsubst v w = zipWith (-) w (map (* scale) v) + where + scale = case filter (\(vn,_wn) -> vn /= 0) (zip v w) of + [] -> 0 + (vi, wi):_ -> wi / vi + +rank mat = length (filter (not . allZero) (reducedRowEchelon mat)) + where + allZero = all (==0) + +independent mat = length mat == rank mat + +dependent mat = not (independent mat) + +data SolverError = Unsolvable | MultipleSolutions + deriving Show + +-- precondition, target and every member of vecs must have equal length +-- Trys to prove that target is in the span of vec by giving a set of coefficents to be applied to vec. +-- If target is not in the span, Unsolvable is returned. +-- If the solution is not unique, MultipleSolutions is returned. +solver :: (Fractional a, Eq a) => [[a]] -> [a] -> Either SolverError [a] +solver vecs target | min n (redRank reduced) < redRank unaugmented = error "Linear.solver: Internal Error" + | redRank unaugmented < redRank reduced = Left Unsolvable + | redRank unaugmented < n = Left MultipleSolutions + | otherwise = Right (take n solution) + where + n = length vecs + augmented = transpose (vecs ++ [target]) + reduced = reducedRowEchelon augmented + (unaugmented, solution) = (map init reduced, map last reduced) + redRank m = length (filter (not . all (==0)) m) diff --git a/haskell/Codex32/Polynomial.hs b/haskell/Codex32/Polynomial.hs new file mode 100644 index 0000000..70c38ea --- /dev/null +++ b/haskell/Codex32/Polynomial.hs @@ -0,0 +1,59 @@ +-- 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.Polynomial where + +-- Polynomials in little endian order. +type Poly a = [a] + +horner :: (Num a) => Poly a -> a -> a +horner l x = foldr f 0 l + where + f c y = y*x + c + +polySum :: (Num a) => Poly a -> Poly a -> Poly a +polySum [] l = l +polySum l [] = l +polySum (a:p) (b:q) = (a + b):polySum p q + +polyMult :: (Num a) => Poly a -> Poly a -> Poly a +polyMult [] q = [] +polyMult (a:p) q = polySum ((a*) <$> q) (fromInteger 0 : polyMult p q) + +-- | Formal derivative +diff :: (Num a) => Poly a -> Poly a +diff = zipWith (*) (fromInteger <$> [1..]) . tail + +-- Monic polynomials in big endian order with the leading 1 coefficent stripped. +type Monic x = [x] + +monicMult :: (Eq x, Num x) => Monic x -> Monic x -> Monic x +monicMult a b = let (1:c) = reverse $ polyMult (reverse (1:a)) (reverse (1:b)) in c + +-- | List of all x^i `mod` modulus +polyPowers :: (Num a) => Monic a -> [Poly a] +polyPowers modulus = reverse <$> iterate f i + where + i = replicate (length modulus - 1) 0 ++ [1] + f (hd:tl) = zipWith (+) (tl ++ [0]) ((hd *) <$> modulus) + +polyMod :: (Num a) => Poly a -> Monic a -> Poly a +poly `polyMod` modulus = foldr polySum [] (zipWith f poly (polyPowers modulus)) + where + f c xp = (c *) <$> xp diff --git a/haskell/Codex32/Setup.hs b/haskell/Codex32/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/haskell/Codex32/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell/Codex32/Word10.hs b/haskell/Codex32/Word10.hs new file mode 100644 index 0000000..cf3ef36 --- /dev/null +++ b/haskell/Codex32/Word10.hs @@ -0,0 +1,70 @@ +-- 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.Word10 where + +import Data.List (find) +import Data.Ratio (numerator, denominator) + +import Codex32.Word5 +import Codex32.Polynomial + +-- Word10 a b denotes the value a + b*zeta where zeta is a primitive cube root of unity and zeta^2 = zeta + 1. +data Word10 = Word10 Word5 Word5 deriving Eq + +zeta = Word10 0 1 +toWord10 x = Word10 x 0 +conj (Word10 a b) = Word10 (a + b) b + +minPoly :: Word10 -> Monic Word5 +minPoly (Word10 x 0) = [x] +minPoly x = [y, z] + where + Word10 y 0 = x + conj x + Word10 z 0 = x * conj x + +instance Show Word10 where + show (Word10 a b) | 0 == b = show a + | 0 == a && 1 == b = "zeta" + | 0 == a = shows b $ "*zeta" + | 1 == b = shows a $ " + zeta" + | otherwise = shows a . showString " + " . shows b $ "*zeta" + +instance Num Word10 where + Word10 a0 b0 + Word10 a1 b1 = Word10 (a0 + a1) (b0 + b1) + a - b = a + b + Word10 a0 b0 * Word10 a1 b1 = Word10 (a0 * a1 + b0 * b1) (a0 * b1 + a1 * b0 + b0 * b1) + abs = error "abs{Word10}" + signum = error "sign{Word10}" + fromInteger = toWord10 . fromInteger + +instance Fractional Word10 where + fromRational x = fromInteger (numerator x) / fromInteger (denominator x) + recip (Word10 a b) = Word10 ((a + b)*den) (b * den) + where + den = recip $ a^2 + b^2 + a*b + +allWord10 = Word10 <$> allWord5 <*> allWord5 + +order x = find p divisors + where + -- divisors of 1024-1 + divisors = [1, 3, 11, 31, 33, 93, 341, 1023] + p i = x^i == 1 diff --git a/haskell/Codex32/Word5.hs b/haskell/Codex32/Word5.hs new file mode 100644 index 0000000..c301e4a --- /dev/null +++ b/haskell/Codex32/Word5.hs @@ -0,0 +1,95 @@ +-- Copyright (c) 2017 Marko Bencun +-- 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.Word5 where + +import qualified Data.Array as Arr +import Data.Word (Word8) +import Data.Ratio (numerator, denominator) +import Data.Ix (Ix, inRange, index, range) +import Data.Char (toUpper) +import Data.Bits ((.&.), shiftL, testBit, xor) +import Data.List (foldl') + +newtype Word5 = UnsafeWord5 Word8 deriving (Eq, Ord) + +instance Ix Word5 where + range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n) + index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i + inRange (m,n) i = m <= i && i <= n + +word5 :: Integral a => a -> Word5 +word5 x = UnsafeWord5 ((fromIntegral x) .&. 31) + +fromWord5 :: Num a => Word5 -> a +fromWord5 (UnsafeWord5 x) = fromIntegral x + +-- 'alpha' is a generator for GF(32). +alpha :: Word5 +alpha = word5 2 + +charset :: Arr.Array Word5 Char +charset = Arr.listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l" + +charsetMap :: Char -> Either Char Word5 +charsetMap c = maybe (Left c) Right $ lookup upperC assocs + where + upperC = toUpper c + assocs = swap <$> Arr.assocs charset + swap (a, b) = (toUpper b, a) + +instance Show Word5 where + show w = (charset Arr.! w):[] + +instance Read Word5 where + readsPrec _ [] = [] + readsPrec _ (c:cs) = [(w,cs) | Right w <- [charsetMap c]] + +(.+.) :: Word5 -> Word5 -> Word5 +(UnsafeWord5 x) .+. (UnsafeWord5 y) = UnsafeWord5 (x `xor` y) + +(.*.) :: Word5 -> Word5 -> Word5 +x .*. (UnsafeWord5 y) = foldl' (.+.) (word5 0) $ zipWith f [0..5] (iterate alphaShift x) + where + alphaShift (UnsafeWord5 w) | testBit w 4 = word5 (shiftL w 1 `xor` 9) + | otherwise = word5 (shiftL w 1) + f i xi | testBit y i = xi + | otherwise = word5 0 + +instance Num Word5 where + (+) = (.+.) + (-) = (.+.) + (*) = (.*.) + abs x | x == 0 = 0 + | otherwise = 1 + signum x = x + fromInteger i | even i = word5 0 + | otherwise = word5 1 + +instance Fractional Word5 where + fromRational x = fromInteger (numerator x) / fromInteger (denominator x) + recip x = x ^ 30 + +fromString str = traverse charsetMap str +toString l = (charset Arr.!) <$> l +toChar w = charset Arr.! w + +allWord5 = Arr.indices charset diff --git a/haskell/codex32.nix b/haskell/codex32.nix new file mode 100644 index 0000000..9a44d30 --- /dev/null +++ b/haskell/codex32.nix @@ -0,0 +1,13 @@ +{ mkDerivation, streams +, lib, tasty, tasty-hunit, tasty-quickcheck +}: +mkDerivation { + pname = "codex32"; + version = "0.0.0"; + src = lib.sourceFilesBySuffices ./. [".cabal" ".hs"]; + libraryHaskellDepends = [ streams ]; + testHaskellDepends = [ + tasty tasty-hunit tasty-quickcheck + ]; + license = lib.licenses.mit; +} diff --git a/haskell/default.nix b/haskell/default.nix new file mode 100644 index 0000000..487c1bd --- /dev/null +++ b/haskell/default.nix @@ -0,0 +1 @@ +{ nixpkgs ? import {}}: nixpkgs.haskellPackages.callPackage ./codex32.nix {} diff --git a/haskell/exec/Main.hs b/haskell/exec/Main.hs new file mode 100644 index 0000000..d28e6ac --- /dev/null +++ b/haskell/exec/Main.hs @@ -0,0 +1,119 @@ +module Main where + +import Control.Applicative ((<**>), (<|>), many) +import Control.Arrow ((+++)) +import Control.Monad (unless) +import Data.List (find,intercalate, nub) +import Data.Monoid ((<>)) +import Data.Text (pack) +import qualified Options.Applicative as Opt +import qualified Options.Applicative.Types as Opt +import qualified Prettyprinter as PP +import qualified Prettyprinter.Util as PP +import qualified System.Exit as Sys + +import Codex32 +import Codex32.Error +import Codex32.Word5 +import Codex32.Polynomial + +data AdvancedOptions = AdvancedOptions { optLength :: Int + , optOverrideLength :: Bool + , optErasures :: [Int] + , optSpec :: Spec + , optResidue :: Poly Word5 + } + +data Command = Simple String + | Advanced AdvancedOptions + +residueReader :: Opt.ReadM (Spec, [Word5]) +residueReader = do + result <- Opt.eitherReader parse + let len = length result + spec <- maybe (failLength len) return $ find (\spec -> len == specDegree spec) specs + return (spec, result) + where + parse = (errMsg +++ reverse) . fromString + errMsg c = "Illegal Bech32 character " ++ show c ++ "." + failLength len = fail $ "Residue length must be " ++ intercalate " or " (show <$> validDegrees) ++ "." + validDegrees = specDegree <$> specs + specs = [codex32Spec, codex32LongSpec] + +codex32SimpleParser :: Opt.Parser Command +codex32SimpleParser = Simple <$> Opt.strArgument (Opt.metavar "CODEX32_STRING" <> Opt.help "Codex32 string to correct") + +codex32AdvancedParser :: Opt.Parser Command +codex32AdvancedParser = Advanced <$> + (mkAdvancedOptions <$> Opt.option Opt.auto (Opt.long "len" <> Opt.metavar metaLength <> Opt.help "Total length of codex32 string") + <*> Opt.switch (Opt.long overrideOptName <> Opt.hidden) + <*> many (Opt.option Opt.auto (Opt.short 'e' <> Opt.metavar "ERASURE_LOCATION" <> Opt.help "Location of unreadable character (can be repeated)")) + <*> Opt.argument residueReader (Opt.metavar metaResidue <> Opt.help "Residue from worksheet")) + where + mkAdvancedOptions l ol e (s, r) = AdvancedOptions l ol e s r + +metaLength = "LENGTH" +overrideOptName = "override_length" +metaResidue = "RESIDUE" + +codex32CorrectParser :: Opt.ParserInfo Command +codex32CorrectParser = Opt.info ((codex32SimpleParser <|> codex32AdvancedParser) <**> Opt.helper) (Opt.progDescDoc desc) + where + pretty = PP.reflow . pack + desc = Just $ pretty "Error correct codex32 strings." + <> PP.line <> PP.line + <> pretty "Pass an 'ms1' string on the command line to try and output an error-corrected version of that string." + <> PP.line <> PP.line + <> pretty "Alternatively, if you are verifying your checksum using the worksheet from the Codex32 booklet, you can pass '--len 48' followed by the 13 character residue you computed on your worksheet." + <> PP.space <> PP.space + <> pretty "If you have unreadable characters in your string, use your best guess and add '-e ' to let the tool know which box contained your unreadable character." + <> PP.space <> PP.space + <> pretty "If error correction is possible, the program will output instructions on which character locations contain errors and what values to add, using the booklet's addition wheel, in order to correct the error." + <> PP.space <> PP.space + <> pretty "With this method, the computer can help you correct your codex32 string without even needing to know what the string is." + +codex32CorrectOptions :: Opt.Parser Command +codex32CorrectOptions = Opt.subparser (Opt.command "correct" codex32CorrectParser) + +codex32Options :: Opt.ParserInfo Command +codex32Options = Opt.info (codex32CorrectOptions <**> Opt.helper) mempty + +codex32Prefs :: Opt.ParserPrefs +codex32Prefs = Opt.prefs Opt.showHelpOnEmpty + +formatCorrections :: Int -> [(Int, Word5)] -> String +formatCorrections _ [] = "No errors found. Residue is correct." +formatCorrections len corrections = unlines (header : (fmt <$> corrections)) + where + header = show len ++ " errors found. Make the following corrections." + fmt (ix, delta) = "Add " ++ show (toChar delta) ++ " to position " ++ show (len - ix) ++ "." + +main :: IO () +main = Opt.customExecParser codex32Prefs codex32Options >>= run + +run :: Command -> IO a +run (Simple codex32Str) = + case (correctCodex32String codex32Str) of + Nothing -> putStrLn "Failed to error correct string" >> Sys.exitFailure + Just str -> putStrLn str >> Sys.exitSuccess +run (Advanced options) | 13 < length erasureIxs = failWith "No more than 13 -e options are allowed." + | not (optOverrideLength options) && bitsize `notElem` [128, 256, 512] = failWith $ "Unusual bitsize found. Override with --" ++ overrideOptName ++ "." + | 5 <= padding = failWith $ "Invalid " ++ metaLength ++ "." + | len < 48 = failWith $ metaLength ++ " too short." + | 127 < len = failWith $ metaLength ++ " too long." + | specDataLength spec < 6 + payloadLength = failWith $ metaLength ++ " too long for " ++ show (length residue) ++ " character " ++ metaResidue ++ "." + | 15 == length residue && len < 99 = failWith $ metaLength ++ " too short for " ++ show (length residue) ++ " character " ++ metaResidue ++ "." + | otherwise = format result + where + erasureIxs = nub (optErasures options) + residue = optResidue options + len = optLength options + spec = optSpec options + dataLength = len - length (specPrefix spec) - 1 + payloadLength = dataLength - 6 - length (specTarget spec) + (bytesize, padding) = (payloadLength * 5) `divMod` 8 + bitsize = bytesize * 8 + failWith str = Opt.handleParseResult . Opt.Failure $ Opt.parserFailure codex32Prefs codex32Options (Opt.ErrorMsg str) [Opt.Context "correct" codex32CorrectParser] + result = errorCorrections (optSpec options) erasureIxs residue + format Nothing = putStrLn "Too many errors. Unable to correct." >> Sys.exitFailure + format (Just corrections) = putStr (formatCorrections len corrections) >> Sys.exitSuccess diff --git a/haskell/shell.nix b/haskell/shell.nix new file mode 100644 index 0000000..f429b71 --- /dev/null +++ b/haskell/shell.nix @@ -0,0 +1,12 @@ +{ pkgs ? import {} }: + +pkgs.haskellPackages.shellFor { + packages = hpkgs: [ + (hpkgs.callPackage ./codex32.nix { }) + ]; + + # development tools we use + nativeBuildInputs = [ + pkgs.cabal-install + ]; +} diff --git a/haskell/test/TestVectors.hs b/haskell/test/TestVectors.hs new file mode 100644 index 0000000..4b62cd7 --- /dev/null +++ b/haskell/test/TestVectors.hs @@ -0,0 +1,142 @@ +-- 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 TestVectors where + +import Data.Char (toUpper) +import Data.List (inits, tails) + +import Codex32 +import Codex32.Polynomial +import Codex32.Word5 +import Codex32.Word10 + +validExamples = + [ "ms10testsxxxxxxxxxxxxxxxxxxxxxxxxxx4nzvca9cmczlw" + , "MS12NAMEA320ZYXWVUTSRQPNMLKJHGFEDCAXRPP870HKKQRM" + , "MS12NAMECACDEFGHJKLMNPQRSTUVWXYZ023FTR2GDZMPY6PN" + , "MS12NAMEDLL4F8JLH4E5VDVULDLFXU2JHDNLSM97XVENRXEG" + , "MS12NAMES6XQGUZTTXKEQNJSJZV4JV3NZ5K3KWGSPHUH6EVW" + , "ms13cashsllhdmn9m42vcsamx24zrxgs3qqjzqud4m0d6nln" + , "ms13casha320zyxwvutsrqpnmlkjhgfedca2a8d0zehn8a0t" + , "ms13cashcacdefghjklmnpqrstuvwxyz023949xq35my48dr" + , "ms13cashd0wsedstcdcts64cd7wvy4m90lm28w4ffupqs7rm" + , "ms13casheekgpemxzshcrmqhaydlp6yhms3ws7320xyxsar9" + , "ms13cashf8jh6sdrkpyrsp5ut94pj8ktehhw2hfvyrj48704" + , "ms13cashsllhdmn9m42vcsamx24zrxgs3qpte35dvzkjpt0r" + , "ms13cashsllhdmn9m42vcsamx24zrxgs3qzfatvdwq5692k6" + , "ms13cashsllhdmn9m42vcsamx24zrxgs3qrsx6ydhed97jx2" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqqtum9pgv99ycma" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqpj82dp34u6lqtd" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqzsrs4pnh7jmpj5" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqrfcpap2w8dqezy" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqy5tdvphn6znrf0" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyq9dsuypw2ragmel" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqx05xupvgp4v6qx" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyq8k0h5p43c2hzsk" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqgum7hplmjtr8ks" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqf9q0lpxzt5clxq" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyq28y48pyqfuu7le" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqt7ly0paesr8x0f" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqvrvg7pqydv5uyz" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqd6hekpea5n0y5j" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyqwcnrwpmlkmt9dt" + , "ms10leetsllhdmn9m42vcsamx24zrxgs3qrl7ahwvhw4fnzrhve25gvezzyq0pgjxpzx0ysaam" + , "MS100C8VSM32ZXFGUHPCHTLUPZRY9X8GF2TVDW0S3JN54KHCE6MUA7LQPZYGSFJD6AN074RXVCEMLH8WU3TK925ACDEFGHJKLMNPQRSTUVWXY06FHPV80UNDVARHRAK" + ] + +createString prefix target generator dat = prefix ++ "1" ++ toString (dat ++ reverse checksum) + where + hrp = hrpExpand prefix + checksum = reverse (hrp ++ dat ++ target) `polyMod` generator + +prefix = specPrefix codex32Spec +roots = specRoots codex32Spec +generator = specGenerator codex32Spec +target = specTarget codex32Spec +longRoots = specRoots codex32LongSpec +longGenerator = specGenerator codex32LongSpec +longTarget = specTarget codex32LongSpec + +badIdentity = "faux" +invalidA = [ createString prefix target generator l + | target <- [ replicate (length generator) 0, replicate (length generator - 1) 0 ++ [1] ] + , let Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate 26 'x' + ] + ++ [ createString prefix (reverse bias) g l + | g <- badGens + , let bias = reverse target `polyMod` g + , let Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate (26 + 13 - length g) 'x' + ] + ++ [ createString prefix target generator l + | spec <- [ bip173Spec, bip350Spec ] + , let target = specTarget spec + , let generator = specGenerator spec + , let Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate (28 + 13 - length generator) 'x' + ] + where + badGens = foldr1 monicMult . fmap minPoly <$> zipWith (<>) (init $ inits roots) (tail <$> tails roots) + +invalidB = [ createString prefix target longGenerator l + | target <- [ replicate (length longGenerator) 0, replicate (length longGenerator - 1) 0 ++ [1] ] + , let Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate 103 'x' + ] + ++ [ createString prefix (reverse bias) g l + | g <- badLongGens + , let bias = reverse longTarget `polyMod` g + , let Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate (103 + 15 - length g) 'x' + ] + where + badLongGens = foldr1 monicMult . fmap minPoly <$> zipWith (<>) (init $ inits longRoots) (tail <$> tails longRoots) + +invalidC = [ createString prefix (if long then longTarget else target) (if long then longGenerator else generator) l + | sz <- [24, 26, 72, 73, 74, 75, 76, 77, 103, 105] + , let long = sz <= 74 + , let Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate sz 'x' + ] + +invalidD = [ createString prefix (if long then longTarget else target) (if long then longGenerator else generator) l + | (threshold, share) <- [("0", "s"), ("2", "x")] + , sz <- [24, 25, 27, 73, 75, 102, 104] + , let long = 75 <= sz + , let Right l = fromString $ threshold ++ badIdentity ++ share ++ replicate sz 'x' + ] + +invalidE = [ createString prefix target generator l + | Right l <- [ fromString $ "0" ++ badIdentity ++ "x" ++ replicate 26 'x' + , fromString $ badIdentity ++ "xx" ++ replicate 26 'x' + ] + ] + +invalidF = [ str, "1"++str,"ms"++str,"m1"++str,"s1"++str] ++ [tail badHrp] ++ badHrps + where + Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate 26 'x' + 'm':'s':'1':str = createString prefix target generator l + badHrps@(badHrp:_) = [ createString prefix target generator l | prefix <- ["", "m", "s"] ] + +invalidG = [ zipWith ($) adj str + | adj <- [ [ if i `elem` uppers then toUpper else id | i <- [0..]] + | uppers <- [[0],[1],[0,1],[4..7],[8],[9..34],[35..47]] + ] + ] + where + Right l = fromString $ "0" ++ badIdentity ++ "s" ++ replicate 26 'x' + str = createString prefix target generator l + +invalidExamples = concat [invalidA, invalidB, invalidC, invalidD, invalidE, invalidF, invalidG] diff --git a/haskell/test/Tests.hs b/haskell/test/Tests.hs new file mode 100644 index 0000000..a807d30 --- /dev/null +++ b/haskell/test/Tests.hs @@ -0,0 +1,73 @@ +module Main where + +import Control.Monad (guard, replicateM) +import Data.Char (toLower) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck (Gen, Property, chooseInt, elements, forAll, shuffle, testProperty) + +import Codex32 +import Codex32.Error +import Codex32.Word5 +import TestVectors + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ testProperty "prop_verifyCodex32Checksum_valid" prop_verifyCodex32Checksum_valid + , testProperty "prop_correctCodex32String_BCHError" prop_correctCodex32String_BCHError + , testProperty "prop_correctCodex32String_LinearError" prop_correctCodex32String_LinearError + ] + +-- :TODO: actually generate arbitrary valid data +arbitraryValid :: Gen String +arbitraryValid = elements validExamples + +correctableBCHErrorVector :: Spec -> Int -> Gen [Maybe Word5] +correctableBCHErrorVector spec length = do + (errorCount, erasureCount) <- elements distribution + let remainderCount = length - errorCount - erasureCount + errorString <- replicateM errorCount genError + let erasureString = replicate erasureCount Nothing + let remainderString = replicate remainderCount 0 + shuffle $ erasureString ++ fmap Just (errorString ++ remainderString) + where + distance = specDistance spec + distribution = do + errorCount <- [0..distance `div` 2] + erasureCount <-[0..distance-2*errorCount] + guard (0 < errorCount || 0 < erasureCount) + return (errorCount, erasureCount) + genError = word5 <$> chooseInt (1,31) + +correctableLinearErrorVector :: Spec -> Int -> Gen [Maybe Word5] +correctableLinearErrorVector spec length = do + start <- chooseInt (0,length - degree) + return $ replicate start (Just 0) ++ replicate degree Nothing ++ replicate (length - degree - start) (Just 0) + where + degree = specDegree spec + +arbitraryError :: (Spec -> Int -> Gen [Maybe Word5]) -> Gen (String, String) +arbitraryError mkError = do + valid <- arbitraryValid + let Just (spec, body) = decodeCodex32 valid + err <- mkError spec (length body) + let errBody = zipWith addError body err + let errString = specPrefix spec ++ "1" ++ errBody + return (toLower <$> valid, errString) + where + addError _ Nothing = '?' + addError (Left _) _ = '?' + addError (Right v) (Just e) = toChar (v + e) + +prop_verifyCodex32Checksum_valid :: Property +prop_verifyCodex32Checksum_valid = forAll arbitraryValid verifyCodex32String + +correctable (valid, errString) = Just valid == correctCodex32String errString + +prop_correctCodex32String_BCHError :: Property +prop_correctCodex32String_BCHError = forAll (arbitraryError correctableBCHErrorVector) correctable + +prop_correctCodex32String_LinearError :: Property +prop_correctCodex32String_LinearError = forAll (arbitraryError correctableLinearErrorVector) correctable