tls 0.2 → 0.3
raw patch · 13 files changed
+167/−81 lines, 13 filesdep +cerealdep +crypto-apidep −RSAdep −spoondep ~QuickCheckdep ~basedep ~certificate
Dependencies added: cereal, crypto-api
Dependencies removed: RSA, spoon
Dependency ranges changed: QuickCheck, base, certificate, cryptocipher, cryptohash, mtl
Files
- Network/TLS/Cipher.hs +3/−3
- Network/TLS/Client.hs +2/−2
- Network/TLS/Crypto.hs +33/−29
- Network/TLS/MAC.hs +3/−3
- Network/TLS/Packet.hs +3/−3
- Network/TLS/Receiving.hs +7/−5
- Network/TLS/SRandom.hs +74/−13
- Network/TLS/Sending.hs +3/−3
- Network/TLS/Server.hs +12/−6
- Network/TLS/Struct.hs +6/−5
- Stunnel.hs +5/−2
- Tests.hs +7/−0
- tls.cabal +9/−7
Network/TLS/Cipher.hs view
@@ -24,9 +24,9 @@ import Data.Word import Network.TLS.Struct (Version(..)) -import qualified Data.CryptoHash.SHA256 as SHA256-import qualified Data.CryptoHash.SHA1 as SHA1-import qualified Data.CryptoHash.MD5 as MD5+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.MD5 as MD5 import qualified Data.Vector.Unboxed as Vector (fromList, toList) import qualified Data.ByteString.Lazy as L
Network/TLS/Client.hs view
@@ -76,7 +76,7 @@ instance MonadTrans TLSClient where lift = TLSClient . lift -instance Monad m => Functor (TLSClient m) where+instance (Functor m, Monad m) => Functor (TLSClient m) where fmap f = TLSClient . fmap f . runTLSC runTLSClientST :: TLSClient m a -> TLSStateClient -> m (a, TLSStateClient)@@ -147,7 +147,7 @@ connectSendClientKeyXchg :: Handle -> TLSClient IO () connectSendClientKeyXchg handle = do- prerand <- ClientKeyData . B.pack <$> withTLSRNG (\rng -> getRandomBytes rng 46)+ prerand <- ClientKeyData <$> withTLSRNG (\rng -> getRandomBytes rng 46) ver <- cpConnectVersion . scParams <$> get sendPacket handle $ Handshake (ClientKeyXchg ver prerand)
Network/TLS/Crypto.hs view
@@ -18,28 +18,42 @@ , updateSHA1 , finalizeSHA1 - -- * RSA stuff+ -- * key exchange generic interface , PublicKey(..) , PrivateKey(..)- , rsaEncrypt- , rsaDecrypt+ , kxEncrypt+ , kxDecrypt+ , KxError(..) ) where -import qualified Data.CryptoHash.SHA1 as SHA1-import qualified Data.CryptoHash.MD5 as MD5+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString)-import Codec.Crypto.RSA (PublicKey(..), PrivateKey(..))-import qualified Codec.Crypto.RSA as RSA-import Control.Spoon-import Control.Arrow (first)-import System.Random+import qualified Crypto.Cipher.RSA as RSA+import Crypto.Random (CryptoRandomGen) +data PublicKey = PubRSA RSA.PublicKey++data PrivateKey = PrivRSA RSA.PrivateKey++instance Show PublicKey where+ show (_) = "PublicKey(..)"++instance Show PrivateKey where+ show (_) = "privateKey(..)"++data KxError = RSAError RSA.Error+ deriving (Show)+ data HashCtx = SHA1 !SHA1.Ctx | MD5 !MD5.Ctx +data KeyXchg =+ KxRSA RSA.PublicKey RSA.PrivateKey+ deriving (Show)+ instance Show HashCtx where show (SHA1 _) = "sha1" show (MD5 _) = "md5"@@ -88,23 +102,13 @@ finalizeHash (SHA1 ctx) = finalizeSHA1 ctx finalizeHash (MD5 ctx) = finalizeMD5 ctx -{- RSA reexport and maybification -}--{- on using spoon:- because we use rsa Encrypt/Decrypt in a pure context, catching the exception- when the key is not correctly set or the data isn't correct.- need to fix the RSA package to return "Either String X".--}--lazyToStrict :: L.ByteString -> B.ByteString-lazyToStrict = B.concat . L.toChunks+{- key exchange methods encrypt and decrypt for each supported algorithm -}+generalizeRSAError :: Either RSA.Error a -> Either KxError a+generalizeRSAError (Left e) = Left (RSAError e)+generalizeRSAError (Right x) = Right x -rsaEncrypt :: RandomGen g => g -> PublicKey -> B.ByteString -> Maybe (B.ByteString, g)-rsaEncrypt g pk b = maybe Nothing (Just . first lazyToStrict) $ teaspoon (RSA.rsaes_pkcs1_v1_5_encrypt g pk blazy)- where- blazy = L.fromChunks [ b ]+kxEncrypt :: CryptoRandomGen g => g -> PublicKey -> ByteString -> Either KxError (ByteString, g)+kxEncrypt g (PubRSA pk) b = generalizeRSAError $ RSA.encrypt g pk b -rsaDecrypt :: PrivateKey -> B.ByteString -> Maybe B.ByteString-rsaDecrypt pk b = maybe Nothing (Just . lazyToStrict) $ teaspoon (RSA.rsaes_pkcs1_v1_5_decrypt pk blazy)- where- blazy = L.fromChunks [ b ]+kxDecrypt :: PrivateKey -> ByteString -> Either KxError ByteString+kxDecrypt (PrivRSA pk) b = generalizeRSAError $ RSA.decrypt pk b
Network/TLS/MAC.hs view
@@ -9,9 +9,9 @@ , prf_MD5SHA1 ) where -import qualified Data.CryptoHash.MD5 as MD5-import qualified Data.CryptoHash.SHA1 as SHA1-import qualified Data.CryptoHash.SHA256 as SHA256+import qualified Crypto.Hash.MD5 as MD5+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString as B import Data.ByteString (ByteString) import Data.Bits (xor)
Network/TLS/Packet.hs view
@@ -387,9 +387,9 @@ -} decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec b = do- x <- runGet getWord8 b- if x == 1 then Right () else Left $ Error_Misc "unknown change cipher spec content"+decodeChangeCipherSpec = runGet $ do+ x <- getWord8+ when (x /= 1) (throwError $ Error_Misc "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1)
Network/TLS/Receiving.hs view
@@ -33,6 +33,8 @@ import Network.TLS.SRandom import Data.Certificate.X509 +import qualified Crypto.Cipher.RSA as RSA+ newtype TLSRead a = TLSR { runTLSR :: ErrorT TLSError (State TLSState) a } deriving (Monad, MonadError TLSError) @@ -102,7 +104,7 @@ content <- case ty of HandshakeType_ClientKeyXchg -> do copt <- decryptRSA econtent- return $ maybe econtent id copt+ return $ either (const econtent) id copt _ -> return econtent hs <- case (ty, decodeHandshake ver ty content) of@@ -123,18 +125,18 @@ _ -> return () return $ Handshake hs -decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)+decryptRSA :: MonadTLSState m => ByteString -> m (Either KxError ByteString) decryptRSA econtent = do ver <- return . stVersion =<< getTLSState rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake- return $ rsaDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent)+ return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) setMasterSecretRandom :: ByteString -> TLSRead () setMasterSecretRandom content = do st <- getTLSState let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content) putTLSState $ st { stRandomGen = g' }- setMasterSecret (B.pack bytes)+ setMasterSecret bytes processClientKeyXchg :: Version -> ByteString -> TLSRead () processClientKeyXchg ver content = do@@ -239,6 +241,6 @@ processCertificates certs = do case certPubKey $ head certs of PubKey _ (PubKeyRSA (lm, m, e)) -> do- let pk = PublicKey { public_size = fromIntegral lm, public_n = m, public_e = e }+ let pk = PubRSA (RSA.PublicKey { RSA.public_sz = fromIntegral lm, RSA.public_n = m, RSA.public_e = e }) setPublicKey pk _ -> return ()
Network/TLS/SRandom.hs view
@@ -3,29 +3,90 @@ module Network.TLS.SRandom ( SRandomGen , makeSRandomGen- , getRandomByte , getRandomBytes ) where -import System.Random-import Control.Arrow (first) import Data.Word-import Codec.Crypto.AES.Random+import Control.Arrow (first)+import Crypto.Random+import System.Random+import System.Crypto.Random (getEntropy)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Codec.Crypto.AES as AES+import Data.Bits (xor, shiftL)+import Data.Serialize -type SRandomGen = AESGen+{-+ - the following CPRNG is an AES cbc based counter system.+ -+ - 16 bytes IV, 16 bytes counter, 32 bytes key+ - (IV `xor` counter) `aes` key -> 16 bytes output+ -} -makeSRandomGen :: IO SRandomGen-makeSRandomGen = newAESGen+data Word128 = Word128 !Word64 !Word64 -getRandomByte :: SRandomGen -> (Word8, SRandomGen)-getRandomByte rng = first fromIntegral $ next rng+data SRandomGen = RNG !ByteString !Word128 !ByteString -getRandomBytes :: SRandomGen -> Int -> ([Word8], SRandomGen)+instance Show SRandomGen where+ show _ = "srandomgen[..]"++put128 :: Word128 -> ByteString+put128 (Word128 a b) = runPut (putWord64host a >> putWord64host b)++get128 :: ByteString -> Word128+get128 = either (\_ -> Word128 0 0) id . runGet (getWord64host >>= \a -> (getWord64host >>= \b -> return $ Word128 a b))++add1 :: Word128 -> Word128+add1 (Word128 a b) = if b == 0xffffffffffffffff then Word128 (a+1) 0 else Word128 a (b+1)++toBigInt :: Word128 -> Integer+toBigInt (Word128 a b) = ((fromIntegral a) `shiftL` 64) + fromIntegral b++make :: B.ByteString -> Either GenError SRandomGen+make b+ | B.length b < 64 = Left NotEnoughEntropy+ | otherwise = Right $ RNG iv (get128 cnt) key+ where+ key = B.take 32 left2+ (cnt, left2) = B.splitAt 16 left1+ (iv, left1) = B.splitAt 16 b++chunkSize :: Int+chunkSize = 16++nextChunk :: SRandomGen -> (ByteString, SRandomGen)+nextChunk (RNG iv counter key) = (chunk, newrng)+ where+ newrng = RNG chunk (add1 counter) key+ chunk = AES.crypt' AES.CBC key iv AES.Encrypt bytes+ bytes = iv `bxor` (put128 counter)+ bxor a b = B.pack $ B.zipWith xor a b++makeSRandomGen :: IO (Either GenError SRandomGen)+makeSRandomGen = getEntropy 64 >>= return . make++getRandomBytes :: SRandomGen -> Int -> (ByteString, SRandomGen) getRandomBytes rng n = let list = helper rng n in- (map fst list, snd $ last list)+ (B.concat $ map fst list, snd $ last list) where helper _ 0 = [] helper g i =- let (b, g') = getRandomByte g in- (b, g') : helper g' (i-1)+ let (b, g') = nextChunk g in+ if chunkSize >= i+ then [ (B.take i b, g') ]+ else (b, g') : helper g' (i-chunkSize)++instance CryptoRandomGen SRandomGen where+ newGen = make+ genSeedLength = 64+ genBytes len rng = Right $ getRandomBytes rng len+ reseed b rng = Right rng++instance RandomGen SRandomGen where+ split _ = error "split not supported on SRandomGen"+ next rng = (fromIntegral $ toBigInt w, rng')+ where+ (w, rng') = first get128 $ nextChunk rng+
Network/TLS/Sending.hs view
@@ -108,9 +108,9 @@ st <- getTLSState let g = stRandomGen st let rsakey = fromJust $ hstRSAPublicKey $ fromJust $ stHandshake st- case rsaEncrypt g rsakey content of- Nothing -> fail "no RSA key selected"- Just (econtent, g') -> do+ case kxEncrypt g rsakey content of+ Left err -> fail ("rsa encrypt failed: " ++ show err)+ Right (econtent, g') -> do putTLSState (st { stRandomGen = g' }) return econtent
Network/TLS/Server.hs view
@@ -31,10 +31,10 @@ import Control.Monad.Trans import Control.Monad.State import Control.Applicative ((<$>))-import Codec.Crypto.RSA (PrivateKey(..)) import Data.Certificate.X509 import qualified Data.Certificate.Key as CertificateKey import Network.TLS.Cipher+import Network.TLS.Crypto import Network.TLS.Struct import Network.TLS.Packet import Network.TLS.State@@ -44,6 +44,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import System.IO (Handle, hFlush)+import qualified Crypto.Cipher.RSA as RSA type TLSServerCert = (B.ByteString, Certificate, CertificateKey.PrivateKey) @@ -78,7 +79,7 @@ instance MonadTrans TLSServer where lift = TLSServer . lift -instance Monad m => Functor (TLSServer m) where+instance (Monad m, Functor m) => Functor (TLSServer m) where fmap f = TLSServer . fmap f . runTLSC runTLSServerST :: TLSServer m a -> TLSStateServer -> m (a, TLSStateServer)@@ -145,10 +146,15 @@ -- the necessary bits set. let needkeyxchg = cipherExchangeNeedMoreData $ cipherKeyExchange cipher - let privkey = PrivateKey- { private_size = fromIntegral $ CertificateKey.privKey_lenmodulus privkeycert- , private_n = CertificateKey.privKey_modulus privkeycert- , private_d = CertificateKey.privKey_private_exponant privkeycert+ let privkey = PrivRSA $ RSA.PrivateKey+ { RSA.private_sz = fromIntegral $ CertificateKey.privKey_lenmodulus privkeycert+ , RSA.private_n = CertificateKey.privKey_modulus privkeycert+ , RSA.private_d = CertificateKey.privKey_private_exponant privkeycert+ , RSA.private_p = CertificateKey.privKey_p1 privkeycert+ , RSA.private_q = CertificateKey.privKey_p2 privkeycert+ , RSA.private_dP = CertificateKey.privKey_exp1 privkeycert+ , RSA.private_dQ = CertificateKey.privKey_exp2 privkeycert+ , RSA.private_qinv = CertificateKey.privKey_coef privkeycert } setPrivateKey privkey
Network/TLS/Struct.hs view
@@ -43,7 +43,8 @@ , typeOfHandshake ) where -import Data.ByteString (ByteString, pack)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B (length) import Data.Word import Data.Certificate.X509 @@ -128,13 +129,13 @@ type FinishedData = [Word8] type Extension = (Word16, [Word8]) -constrRandom32 :: (Bytes -> a) -> [Word8] -> Maybe a-constrRandom32 constr l = if length l == 32 then Just (constr $ pack l) else Nothing+constrRandom32 :: (Bytes -> a) -> Bytes -> Maybe a+constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing -serverRandom :: [Word8] -> Maybe ServerRandom+serverRandom :: Bytes -> Maybe ServerRandom serverRandom l = constrRandom32 ServerRandom l -clientRandom :: [Word8] -> Maybe ClientRandom+clientRandom :: Bytes -> Maybe ClientRandom clientRandom l = constrRandom32 ClientRandom l newtype EncryptedData = EncryptedData ByteString
Stunnel.hs view
@@ -53,9 +53,12 @@ return () +getRandomGen :: IO SRandomGen+getRandomGen = makeSRandomGen >>= either (fail . show) (return . id)+ mainClient :: String -> Int -> IO () mainClient host port = do- rng <- makeSRandomGen+ rng <- getRandomGen handle <- connectTo host (PortNumber $ fromIntegral port) hSetBuffering handle NoBuffering@@ -82,7 +85,7 @@ lift $ putStrLn "end" clientProcess ((certdata, cert), pk) (handle, src) = do- rng <- makeSRandomGen+ rng <- getRandomGen let serverstate = S.TLSServerParams { S.spAllowedVersions = [TLS10,TLS11]
Tests.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} import Text.Printf import Data.Word import Test.QuickCheck@@ -28,11 +29,14 @@ , ProtocolType_Handshake , ProtocolType_AppData ] +#if MIN_VERSION_QuickCheck(2,3,0)+#else instance Arbitrary Word8 where arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int) instance Arbitrary Word16 where arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int)+#endif instance Arbitrary Header where arbitrary = do@@ -97,6 +101,9 @@ , maxSuccess = 500 , maxDiscard = 2000 , maxSize = 500+#if MIN_VERSION_QuickCheck(2,3,0)+ , chatty = True+#endif } run_test n t = putStr (" " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith args t
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.2+Version: 0.3 Description: native TLS protocol implementation, focusing on purity and more type-checking. .@@ -30,15 +30,17 @@ Default: False Library- Build-Depends: base >= 3 && < 5,+ Build-Depends: base >= 3 && < 7, mtl,- cryptohash,+ cryptohash >= 0.6, binary >= 0.5,+ cereal, bytestring, vector, random,- AES, RSA, spoon,- cryptocipher,+ AES,+ crypto-api >= 0.2,+ cryptocipher >= 0.2, certificate >= 0.3 Exposed-modules: Network.TLS.Client Network.TLS.Server@@ -60,7 +62,7 @@ Executable stunnel Main-is: Stunnel.hs if flag(executable)- Build-Depends: network, haskell98, RSA+ Build-Depends: network, haskell98 Buildable: True else Buildable: False@@ -69,7 +71,7 @@ Main-is: Tests.hs if flag(test) Buildable: True- Build-Depends: base >= 3 && < 5, HUnit, QuickCheck >= 2 && < 2.3, bytestring, random+ Build-Depends: base >= 3 && < 7, HUnit, QuickCheck >= 2, bytestring, random else Buildable: False