RFC1751 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+91/−118 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- Data/RFC1751.hs +25/−38
- RFC1751.cabal +7/−6
- tests/Tests.hs +15/−23
- tests/Units.hs +44/−51
Data/RFC1751.hs view
@@ -1,48 +1,35 @@ -- | RFC-1751 human-readable 128-bit keys module Data.RFC1751- ( HumanKey()- , humanKey+ ( keyToMnemonic+ , mnemonicToKey ) where +import Control.Applicative+import Control.Monad+ import Data.Binary+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL import Data.Bits import Data.Char import Data.List -maybeToEither :: b -> Maybe a -> Either b a-maybeToEither err m = maybe (Left err) Right m--assertEither :: e -> Bool -> Either e ()-assertEither e cond = if cond then Right () else Left e---- | Data type representing 128-bit keys as 12 English words. Use with--- functions from Data.Binary.-newtype HumanKey = HumanKey [String] deriving (Eq)--instance Show HumanKey where- show (HumanKey ws) = concat $ intersperse " " ws---- | Build a HumanKey instance. Validates input.-humanKey :: String -> Either String HumanKey-humanKey s = do- let ws = words $ map toUpper s- assertEither "Must have 12 words." $ length ws == 12- let (ws1, ws2) = splitAt 6 ws- _ <- wordsToKey ws1- _ <- wordsToKey ws2- return $ HumanKey ws--instance Binary HumanKey where- put (HumanKey ws) = do- let (ws1, ws2) = splitAt 6 ws- either fail put $ wordsToKey ws1- either fail put $ wordsToKey ws2+-- | Decode a mnemonic sentence to a 128-bit key.+mnemonicToKey :: String -> Maybe ByteString+mnemonicToKey s = do+ guard $ length ws == 12+ BL.concat <$> mapM ((encode <$>) . wordsToKey) [ws1, ws2]+ where+ ws = words $ map toUpper s+ (ws1, ws2) = splitAt 6 ws - get = do- key1 <- get- key2 <- get- let ws = keyToWords key1 ++ keyToWords key2- return $ HumanKey $ ws+-- | Encode a 128-bit key to a mnemonic sentence.+keyToMnemonic :: ByteString -> Maybe String+keyToMnemonic k = do+ guard $ BL.length k == 16+ return . unwords . concat $ map (keyToWords . decode) [k1, k2]+ where+ (k1, k2) = BL.splitAt 8 k keyToWords :: Word64 -> [String] keyToWords key =@@ -52,16 +39,16 @@ tempIndices = map (\start -> extract key start 11) [0,11..55] indices = init tempIndices ++ [last tempIndices .|. keyCheckSum] -wordsToKey :: [String] -> Either String Word64+wordsToKey :: [String] -> Maybe Word64 wordsToKey ws = do let findWord w = elemIndex w dict >>= return . fromIntegral maybeIndices = sequence $ map findWord ws- indices <- maybeToEither "Unknown word." maybeIndices+ indices <- maybeIndices let buildKey acc (bits, index) = (index `shift` bits) .|. acc key = foldl buildKey 0 $ zip [53,42..(-2)] indices computedSum = checkSum key providedSum = last indices .&. 0x03- assertEither "Checksum failed." $ providedSum == computedSum+ guard $ providedSum == computedSum return key checkSum :: Word64 -> Word64
RFC1751.cabal view
@@ -2,14 +2,14 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: RFC1751-version: 0.1.0.0+version: 0.2.0.0 synopsis: RFC-1751 library for Haskell description: Convert 128-bit ByteString to/from 12 English words.-homepage: https://github.com/Xeno-Genesis/RFC1751+homepage: https://github.com/xenog/RFC1751 license: PublicDomain license-file: UNLICENSE author: Jean-Pierre Rupp-maintainer: root@xeno-genesis.com+maintainer: root@haskoin.com -- copyright: category: Data build-type: Simple@@ -17,12 +17,13 @@ source-repository head type: git- location: git@github.com:Xeno-Genesis/RFC1751.git+ location: https://github.com/xenog/RFC1751.git library exposed-modules: Data.RFC1751- build-depends: base >=4.6 && <4.7,- binary+ build-depends: base ==4.*,+ binary,+ bytestring test-suite test-haskoin-crypto type: exitcode-stdio-1.0
tests/Tests.hs view
@@ -1,8 +1,10 @@ module Tests (tests) where +import Control.Applicative import Data.Char import Data.Binary-import qualified Data.ByteString.Lazy.Char8 as C+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Maybe import Data.RFC1751 import Test.Framework import Test.Framework.Providers.QuickCheck2@@ -11,36 +13,26 @@ tests = [ testGroup "RFC-1751" [ testProperty "Encode/Decode RFC-1751 keys" decodeEncode- , testProperty "Encode/Decode RFC-1751 keys (lowercase)" decodeEncodeLc+ , testProperty "Encode/Decode RFC-1751 keys (lowercase)" decodeEncodeLC , testProperty "Double 64-bit key" doubleWord64 ] ] -fromRight :: Either a b -> b-fromRight (Right b) = b-fromRight _ = error "Either.fromRight: Left"- decodeEncode :: (Word64, Word64) -> Bool-decodeEncode (w1, w2) =- bs == bs'+decodeEncode (w1, w2) = fromMaybe False $+ (== bs) <$> (mnemonicToKey =<< keyToMnemonic bs) where- bs = encode w1 `C.append` encode w2- hk = decode bs :: HumanKey- bs' = encode hk+ bs = encode w1 `L8.append` encode w2 -decodeEncodeLc :: (Word64, Word64) -> Bool-decodeEncodeLc (w1, w2) =- bs == bs'+decodeEncodeLC :: (Word64, Word64) -> Bool+decodeEncodeLC (w1, w2) = fromMaybe False $+ (== bs) <$> (mnemonicToKey =<< map toLower <$> keyToMnemonic bs) where- bs = encode w1 `C.append` encode w2- hk = decode bs :: HumanKey- hk' = fromRight . humanKey . map toLower $ show hk- bs' = encode hk'+ bs = encode w1 `L8.append` encode w2+ doubleWord64 :: Word64 -> Bool-doubleWord64 w =- ws1 == ws2+doubleWord64 w = fromMaybe False $ do+ (\(x, y) -> x == y) . splitAt 6 . words <$> keyToMnemonic bs where- bs = encode w `C.append` encode w- hk = decode bs :: HumanKey- (ws1, ws2) = splitAt 6 $ words $ show hk+ bs = encode w `L8.append` encode w
tests/Units.hs view
@@ -1,19 +1,20 @@ module Units (tests) where -import Control.Monad-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString.Lazy.Char8 as C+import Control.Applicative++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL import Data.Binary import Data.Bits+import Data.Char import Data.List+import Data.Maybe import Numeric -import Test.HUnit ((@=?))+import Test.HUnit ((@=?), assertBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Data.Maybe- import Data.RFC1751 tests :: [Test]@@ -24,21 +25,21 @@ , testGroup "Decode keys in RFC-1751" . map decodeTest $ zip [1..] vectors , testGroup "Encode keys in RFC-1751 (lowercase)"- . map encodeTest $ zip [1..] vectorsLc+ . map encodeTest $ zip [1..] vectorsLC , testGroup "Decode keys in RFC-1751 (lowercase)"- . map decodeTest $ zip [1..] vectorsLc+ . map decodeTest $ zip [1..] vectorsLC , testGroup "Bad checksums" . map badChecksum $ zip [1..] badChecksumVectors , testGroup "Bad checksums (lowercase)"- . map badChecksum $ zip [1..] badChecksumVectorsLc+ . map badChecksum $ zip [1..] badChecksumVectorsLC , testGroup "Not in dictionary" . map notDict $ zip [1..] notDictVectors , testGroup "Not in dictionary (lowercase)"- . map notDict $ zip [1..] notDictVectorsLc+ . map notDict $ zip [1..] notDictVectorsLC ] ] -type TestVector = (C.ByteString, HumanKey)+type TestVector = (ByteString, String) badChecksumVectors :: [String] badChecksumVectors =@@ -47,8 +48,8 @@ , "BORN ROLL LOVE BEAR AGEE IFFY CUTS MASK MOOD FOWL ROME MIT" ] -badChecksumVectorsLc :: [String]-badChecksumVectorsLc =+badChecksumVectorsLC :: [String]+badChecksumVectorsLC = [ "rash bush milk look bad a avid gaff bait rot pod love" , "tab bore dunk sure cove norm pry if joe myra gwen tent" , "born roll love bear agee iffy cuts mask mood fowl rome mit"@@ -56,7 +57,7 @@ badChecksum :: (Int, String) -> Test badChecksum (i, s) = testCase ("Bad checksum #" ++ show i)- (Left "Checksum failed." @=? humanKey s)+ (assertBool "bad checksum" . isNothing $ mnemonicToKey s) notDictVectors :: [String] notDictVectors =@@ -66,8 +67,8 @@ , "TIE OLDY FEEL DOCK EWE PA EMIT HAVE HIS TOTE SWAN KTUH" ] -notDictVectorsLc :: [String]-notDictVectorsLc =+notDictVectorsLC :: [String]+notDictVectorsLC = [ "phon memo hop nell ret deaf hurt yawn flag mile leo lesk" , "jag such per hash full phon dan they cain bond left coca" , "tent tier lieu rod urge bowl patk hook flew ely man oak"@@ -76,62 +77,54 @@ notDict :: (Int, String) -> Test notDict (i, s) = testCase ("Not in dictionary #" ++ show i)- (Left "Unknown word." @=? humanKey s)--fromRight :: Either a b -> b-fromRight (Right b) = b-fromRight _ = error "Either.fromRight: Left"+ (assertBool "wrong word" . isNothing $ mnemonicToKey s) -integerToBS :: Integer -> C.ByteString-integerToBS 0 = B.pack [0]+integerToBS :: Integer -> ByteString+integerToBS 0 = BL.pack [0] integerToBS i - | i > 0 = B.pack $ reverse $ unfoldr f i+ | i > 0 = BL.pack $ reverse $ unfoldr f i | otherwise = error "integerToBS not defined for negative values" where f 0 = Nothing f x = Just $ (fromInteger x :: Word8, x `shiftR` 8) -hexToBS :: String -> Maybe C.ByteString+hexToBS :: String -> ByteString hexToBS str- | null str = Just C.empty- | otherwise = liftM2 C.append (Just z2) r2+ | null str = BL.empty+ | otherwise = BL.append z2 r2 where - (z,r) = span (== '0') str- z2 = B.replicate (fromIntegral $ length z `div` 2) 0+ (z,r) = span (== '0') $ filter (/= ' ') str+ z2 = BL.replicate (fromIntegral $ length z `div` 2) 0 r1 = readHex r- r2 | null r = Just C.empty- | null r1 = Nothing- | otherwise = Just $ integerToBS $ fst $ head r1--hex2lbs :: String -> C.ByteString-hex2lbs = fromJust . hexToBS . filter (/=' ')+ r2 | null r = BL.empty+ | null r1 = error $ "cannot read hex"+ | otherwise = integerToBS $ fst $ head r1 vectors :: [TestVector] vectors =- [ ( hex2lbs "CCAC 2AED 5910 56BE 4F90 FD44 1C53 4766"- , fromRight $- humanKey "RASH BUSH MILK LOOK BAD BRIM AVID GAFF BAIT ROT POD LOVE"+ [ ( hexToBS "CCAC 2AED 5910 56BE 4F90 FD44 1C53 4766"+ , "RASH BUSH MILK LOOK BAD BRIM AVID GAFF BAIT ROT POD LOVE" )- , ( hex2lbs "EFF8 1F9B FBC6 5350 920C DD74 16DE 8009"- , fromRight $- humanKey "TROD MUTE TAIL WARM CHAR KONG HAAG CITY BORE O TEAL AWL"+ , ( hexToBS "EFF8 1F9B FBC6 5350 920C DD74 16DE 8009"+ , "TROD MUTE TAIL WARM CHAR KONG HAAG CITY BORE O TEAL AWL" ) ] -vectorsLc :: [TestVector]-vectorsLc =- [ ( hex2lbs "ccac 2aed 5910 56be 4f90 fd44 1c53 4766"- , fromRight $- humanKey "rash bush milk look bad brim avid gaff bait rot pod love"+vectorsLC :: [TestVector]+vectorsLC =+ [ ( hexToBS "ccac 2aed 5910 56be 4f90 fd44 1c53 4766"+ , "rash bush milk look bad brim avid gaff bait rot pod love" )- , ( hex2lbs "eff8 1f9b fbc6 5350 920c dd74 16de 8009"- , fromRight $- humanKey "trod mute tail warm char kong haag city bore o teal awl"+ , ( hexToBS "eff8 1f9b fbc6 5350 920c dd74 16de 8009"+ , "trod mute tail warm char kong haag city bore o teal awl" ) ] encodeTest :: (Int, TestVector) -> Test-encodeTest (i, (bs, hk)) = testCase ("Encode #" ++ show i) (bs @=? encode hk)+encodeTest (i, (bs, m)) = testCase ("Encode #" ++ show i)+ (bs @=? fromMaybe BL.empty (mnemonicToKey m)) decodeTest :: (Int, TestVector) -> Test-decodeTest (i, (bs, hk)) = testCase ("Decode #" ++ show i) (hk @=? decode bs)+decodeTest (i, (bs, hk)) = testCase ("Decode #" ++ show i)+ (map toLower hk @=? fromMaybe "" (map toLower <$> keyToMnemonic bs))+