RSA.hs (5769B)
1 module Cryptopals.RSA ( 2 Key(..) 3 , Keypair(..) 4 , keygen 5 6 , bitl 7 8 , unroll 9 , roll 10 , unroll' 11 , roll' 12 13 , modinv 14 , modinv' 15 16 , encrypt 17 , decrypt 18 19 , pkcs1v1p5encode 20 , pkcs1v1p5verify 21 , asnSha512 22 , asnSha1 23 24 , sign 25 , verify 26 ) where 27 28 import qualified Crypto.Number.Prime as P 29 import qualified Cryptopals.DH as DH 30 import qualified Cryptopals.Digest.Pure.SHA as CS 31 import qualified Data.Binary as DB 32 import qualified Data.Bits as B 33 import qualified Data.ByteString as BS 34 import qualified Data.ByteString.Lazy as BL 35 import qualified Math.NumberTheory.Logarithms as L 36 import Numeric.Natural 37 38 -- bit length 39 bitl :: Natural -> Int 40 bitl (fromIntegral -> n) 41 | n > 0 = succ . L.integerLog2' $ n 42 | otherwise = 0 43 44 -- big-endian natural encoding 45 unroll :: Natural -> BS.ByteString 46 unroll nat = case nat of 47 0 -> BS.singleton 0 48 _ -> BS.reverse $ BS.unfoldr step nat 49 where 50 step 0 = Nothing 51 step i = Just (fromIntegral i, i `B.shiftR` 8) 52 53 -- big-endian bytestring decoding 54 roll :: BS.ByteString -> Natural 55 roll = BS.foldl' unstep 0 where 56 unstep a b = a `B.shiftL` 8 B..|. fromIntegral b 57 58 -- little-endian natural encoding 59 unroll' :: Natural -> BS.ByteString 60 unroll' nat = case nat of 61 0 -> BS.singleton 0 62 _ -> BS.unfoldr step nat 63 where 64 step 0 = Nothing 65 step i = Just (fromIntegral i, i `B.shiftR` 8) 66 67 -- little-endian bytestring decoding 68 roll' :: BS.ByteString -> Natural 69 roll' = BS.foldr unstep 0 where 70 unstep b a = a `B.shiftL` 8 B..|. fromIntegral b 71 72 -- egcd/modinv adapted from https://rosettacode.org/wiki/Modular_inverse 73 74 -- for a, b, return x, y, g such that ax + by = g for g = gcd(a, b) 75 egcd :: Integer -> Integer -> (Integer, Integer, Integer) 76 egcd a 0 = (1, 0, a) 77 egcd a b = 78 let (q, r) = a `quotRem` b 79 (s, t, g) = egcd b r 80 in (t, s - q * t, g) 81 82 -- for a, m return x such that ax = 1 mod m 83 modinv :: Natural -> Natural -> Maybe Natural 84 modinv (fromIntegral -> a) (fromIntegral -> m) 85 | g == 1 = Just (pos i) 86 | otherwise = Nothing 87 where 88 (i, _, g) = egcd a m 89 pos x 90 | x < 0 = fromIntegral (x + m) 91 | otherwise = fromIntegral x 92 93 -- unsafe modinv 94 modinv' :: Natural -> Natural -> Natural 95 modinv' a m = case modinv a m of 96 Just x -> x 97 Nothing -> error "modinv': no modular inverse" 98 99 data Key = 100 Sec Natural Natural 101 | Pub Natural Natural 102 deriving (Eq, Show) 103 104 data Keypair = Keypair { 105 sec :: Key 106 , pub :: Key 107 } deriving (Eq, Show) 108 109 keygen :: Int -> IO Keypair 110 keygen siz = loop where 111 loop = do 112 p <- fromIntegral <$> P.generatePrime siz 113 q <- fromIntegral <$> P.generatePrime siz 114 let n = p * q 115 et = pred p * pred q 116 e = 3 117 md = modinv e et 118 case md of 119 Nothing -> loop 120 Just d -> pure $ Keypair (Sec d n) (Pub e n) 121 122 -- XX padding for crypt ops / other hash functions for signatures 123 124 encrypt :: Key -> BS.ByteString -> BS.ByteString 125 encrypt key msg = case key of 126 Sec {} -> error "encrypt: need public key" 127 Pub e n -> unroll (DH.modexp (roll msg) e n) 128 129 decrypt :: Key -> BS.ByteString -> BS.ByteString 130 decrypt key cip = case key of 131 Pub {} -> error "decrypt: need secret key" 132 Sec d n -> unroll (DH.modexp (roll cip) d n) 133 134 -- sign using SHA512 135 sign :: Key -> BS.ByteString -> (BS.ByteString, BS.ByteString) 136 sign key msg = case key of 137 Pub {} -> error "sign: need secret key" 138 Sec d n -> 139 let padded = pkcs1v1p5encode key msg 140 in (msg, unroll (DH.modexp (roll padded) d n)) 141 142 -- verify using broken pkcs1 (SHA512) verification 143 verify :: Key -> BS.ByteString -> BS.ByteString -> Bool 144 verify key msg sig = case key of 145 Sec {} -> error "verify: need public key" 146 Pub e n -> 147 let h = BL.toStrict $ CS.bytestringDigest (CS.sha512 (BL.fromStrict msg)) 148 r = DH.modexp (roll sig) e n 149 in case pkcs1v1p5verify (BS.cons 0 (unroll r)) of -- BE-storage hack 150 Nothing -> False 151 Just l -> h == l 152 153 -- pkcs#1 v1.5-encode a message (using SHA512) 154 pkcs1v1p5encode :: Key -> BS.ByteString -> BS.ByteString 155 pkcs1v1p5encode key msg = 156 BS.cons 0x00 (BS.snoc (BS.cons 0x01 ffs) 0x00) <> asnSha512 <> has 157 where 158 siz = case key of 159 Pub _ n -> BS.length (unroll n) 160 Sec _ n -> BS.length (unroll n) 161 len = fromIntegral siz - (3 + BS.length (asnSha512 <> has)) 162 ffs = BS.replicate len 0xff 163 has = BL.toStrict $ CS.bytestringDigest (CS.sha512 (BL.fromStrict msg)) 164 165 -- sloppy pkcs#1 v1.5 verification (SHA512); doesn't verify the length 166 -- of the padding 167 pkcs1v1p5verify :: BS.ByteString -> Maybe BS.ByteString 168 pkcs1v1p5verify = checknul where 169 checknul bs = case BS.uncons bs of 170 Nothing -> Nothing 171 Just (w, etc) 172 | w == 0x00 -> checksoh etc 173 | otherwise -> Nothing 174 175 checksoh bs = case BS.uncons bs of 176 Nothing -> Nothing 177 Just (w, etc) 178 | w == 0x01 -> check255 etc 179 | otherwise -> Nothing 180 181 check255 bs = case BS.uncons bs of 182 Nothing -> Nothing 183 Just (w, etc) 184 | w == 0xff -> check255 etc 185 | w == 0x00 -> checkasn asnSha512 etc 186 | otherwise -> Nothing 187 188 checkasn asn bs = case BS.uncons bs of 189 Nothing -> Nothing 190 Just (w, etc) -> case BS.uncons asn of 191 Nothing -> checkhash bs 192 Just (h, t) 193 | w == h -> checkasn t etc 194 | otherwise -> Nothing 195 196 checkhash bs = 197 let has = BS.take 64 bs 198 in if BS.length has == 64 199 then pure has 200 else Nothing 201 202 -- ASN.1 encoding of SHA512 203 asnSha512 :: BS.ByteString 204 asnSha512 = BS.pack [ 205 0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48 206 , 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04 207 , 0x40 208 ] 209 210 -- ASN.1 encoding of SHA1 211 asnSha1 :: BS.ByteString 212 asnSha1 = BS.pack [ 213 0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03 214 , 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14 215 ]