http-enumerator 0.1.0 → 0.1.1
raw patch · 17 files changed
+2650/−178 lines, 17 filesdep +RSAdep +binarydep +blaze-builderdep −tlsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: RSA, binary, blaze-builder, certificate, cryptocipher, cryptohash, random, spoon, vector
Dependencies removed: tls
API changes (from Hackage documentation)
+ Network.HTTP.Enumerator: urlEncodedBody :: Headers -> Request -> Request
- Network.HTTP.Enumerator: httpLbsRedirect :: (Failure InvalidUrlException m, MonadIO m) => Request -> m Response
+ Network.HTTP.Enumerator: httpLbsRedirect :: (MonadIO m, Failure InvalidUrlException m, Failure HttpException m) => Request -> m Response
- Network.HTTP.Enumerator: simpleHttp :: (Failure InvalidUrlException m, Failure HttpException m, MonadIO m) => String -> m ByteString
+ Network.HTTP.Enumerator: simpleHttp :: (MonadIO m, Failure HttpException m, Failure InvalidUrlException m) => String -> m ByteString
Files
- Network/HTTP/Enumerator.hs +127/−154
- Network/HTTP/Enumerator/HttpParser.hs +4/−19
- Network/TLS/Cap.hs +19/−0
- Network/TLS/Cipher.hs +271/−0
- Network/TLS/Client.hs +308/−0
- Network/TLS/Crypto.hs +110/−0
- Network/TLS/MAC.hs +59/−0
- Network/TLS/Packet.hs +435/−0
- Network/TLS/Receiving.hs +218/−0
- Network/TLS/SRandom.hs +30/−0
- Network/TLS/Sending.hs +179/−0
- Network/TLS/State.hs +267/−0
- Network/TLS/Struct.hs +417/−0
- Network/TLS/Util.hs +37/−0
- Network/TLS/Wire.hs +138/−0
- http-enumerator.cabal +26/−4
- test.hs +5/−1
Network/HTTP/Enumerator.hs view
@@ -25,6 +25,15 @@ -- > main = withFile "google.html" WriteMode $ \handle -> do -- > request <- parseUrl "http://google.com/" -- > httpRedirect (\_ _ -> iterHandle handle) request+--+-- The following headers are automatically set by this module, and should not+-- be added to 'requestHeaders':+--+-- * Content-Length+--+-- * Host+--+-- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage). module Network.HTTP.Enumerator ( -- * Perform a request simpleHttp@@ -40,6 +49,8 @@ , parseUrl , withHttpEnumerator , lbsIter+ -- * Request bodies+ , urlEncodedBody -- * Exceptions , InvalidUrlException (..) , HttpException (..)@@ -51,14 +62,7 @@ #else import System.IO (hClose, hSetBuffering, BufferMode (NoBuffering)) import qualified Network.TLS.Client as TLS-import qualified Network.TLS.Struct as TLS-import qualified Network.TLS.Cipher as TLS-import qualified Network.TLS.SRandom as TLS-import qualified Control.Monad.State as MTL-import Data.IORef import Network (connectTo, PortID (PortNumber))-import qualified Codec.Crypto.AES.Random as AESRand-import Control.Applicative ((<$>)) #endif import Network.Socket@@ -72,7 +76,6 @@ import Control.Exception (throwIO, Exception) import Control.Arrow (first) import Data.Char (toLower)-import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) import Control.Failure@@ -83,6 +86,8 @@ import Data.Maybe (fromMaybe) import Data.ByteString.Lazy.Internal (defaultChunkSize) import Codec.Binary.UTF8.String (encodeString)+import qualified Text.Blaze.Builder.Core as Blaze+import Data.Monoid (Monoid (..)) -- | The OpenSSL library requires some initialization of variables to be used, -- and therefore you must call 'withOpenSSL' before using any of its functions.@@ -109,17 +114,38 @@ connect sock (addrAddress addr) return sock -withSocketConn :: MonadIO m => String -> Int -> (HttpConn -> m a) -> m a+withSocketConn :: MonadIO m => String -> Int -> WithConn m a b -> m b withSocketConn host' port' f = do sock <- liftIO $ getSocket host' port'- a <- f HttpConn- { hcRead = B.recv sock- , hcWrite = B.sendAll sock- }+ a <- f+ (writeToIter $ B.sendAll sock)+ (readToEnum $ B.recv sock defaultChunkSize) liftIO $ sClose sock return a -withSslConn :: MonadIO m => String -> Int -> (HttpConn -> m a) -> m a++writeToIter :: MonadIO m+ => (S.ByteString -> IO b) -> Iteratee S.ByteString m ()+writeToIter write =+ continue go+ where+ go EOF = return ()+ go (Chunks bss) = do+ liftIO $ mapM_ write bss+ continue go++readToEnum :: MonadIO m => IO a -> Enumerator a m b+readToEnum read' (Continue k) = do+ bs <- liftIO read'+ step <- lift $ runIteratee $ k $ Chunks [bs]+ readToEnum read' step+readToEnum _ step = returnI step++type WithConn m a b = Iteratee S.ByteString m ()+ -> Enumerator S.ByteString m a+ -> m b++withSslConn :: MonadIO m => String -> Int -> WithConn m a b -> m b withSslConn host' port' f = do #if OPENSSL@@ -127,88 +153,19 @@ sock <- liftIO $ getSocket host' port' ssl <- liftIO $ SSL.connection ctx sock liftIO $ SSL.connect ssl- a <- f HttpConn- { hcRead = SSL.read ssl- , hcWrite = SSL.write ssl- }+ a <- f+ (writeToIter $ SSL.write ssl)+ (readToEnum $ SSL.read ssl defaultChunkSize) liftIO $ SSL.shutdown ssl SSL.Unidirectional return a #else- ranByte <- liftIO $ S.head <$> AESRand.randBytes 1- _ <- liftIO $ AESRand.randBytes (fromIntegral ranByte)- Just clientRandom <- liftIO $ TLS.clientRandom . S.unpack <$> AESRand.randBytes 32- premasterRandom <- liftIO $ (TLS.ClientKeyData . S.unpack) <$> AESRand.randBytes 46- seqInit <- liftIO $ conv . S.unpack <$> AESRand.randBytes 4 handle <- liftIO $ connectTo host' (PortNumber $ fromIntegral port') liftIO $ hSetBuffering handle NoBuffering- let params = TLS.TLSClientParams- TLS.TLS10- [TLS.TLS10]- Nothing- [ TLS.cipher_AES128_SHA1- , TLS.cipher_AES256_SHA1- , TLS.cipher_RC4_128_MD5- , TLS.cipher_RC4_128_SHA1- ]- Nothing- (TLS.TLSClientCallbacks Nothing)-- ((), state) <- liftIO $ TLS.runTLSClient (do- TLS.connect handle clientRandom premasterRandom- ) params $ TLS.makeSRandomGen seqInit- istate <- liftIO $ newIORef state- a <- f HttpConn- { hcRead = \_len -> do- state1 <- readIORef istate- (a, state2) <-- flip MTL.runStateT state1- $ TLS.runTLSC- $ TLS.recvData handle- writeIORef istate state2- return $ S.concat $ L.toChunks a- , hcWrite = \bs -> do- state1 <- readIORef istate- state2 <-- flip MTL.execStateT state1- $ TLS.runTLSC- $ TLS.sendData handle- $ L.fromChunks [bs]- writeIORef istate state2- }- state' <- liftIO $ readIORef istate- _state'' <- liftIO $ flip MTL.execStateT state'- $ TLS.runTLSC $ TLS.close handle+ a <- TLS.clientEnumSimple handle f liftIO $ hClose handle return a--conv :: [Word8] -> Int-conv l = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d- where- [a,b,c,d] = map fromIntegral l #endif -data HttpConn = HttpConn- { hcRead :: Int -> IO S.ByteString- , hcWrite :: S.ByteString -> IO ()- }--connToEnum :: MonadIO m => HttpConn -> Enumerator S.ByteString m a-connToEnum (HttpConn r _) =- Iteratee . loop- where- loop (Continue k) = do-#if DEBUG- bs <- r 5- liftIO $ putStrLn $ "connToEnum: read 2 bytes: " ++ show bs-#else- bs <- liftIO $ r defaultChunkSize-#endif- if S.null bs- then return $ Continue k- else do- runIteratee (k $ Chunks [bs]) >>= loop- loop step = return step- -- | All information on how to connect to a host and what should be sent in the -- HTTP request. --@@ -265,27 +222,32 @@ | port == 80 && not secure = host | port == 443 && secure = host | otherwise = host `S.append` S8.pack (':' : show port)- go hc = do- liftIO $ hcWrite hc $ S.concat- $ method- : " "- : (case S8.uncons path of- Just ('/', _) -> (:) path- _ -> ((:) "/") . ((:) path))- (renderQS queryString [" HTTP/1.1\r\n"])+ go iter enum = do let headers' = ("Host", hh) : ("Content-Length", S8.pack $ show $ L.length requestBody) : requestHeaders- liftIO $ forM_ headers' $ \(k, v) -> hcWrite hc $ S.concat- [ k- , ": "- , v- , "\r\n"- ]- liftIO $ hcWrite hc "\r\n"- liftIO $ mapM_ (hcWrite hc) $ L.toChunks requestBody- run $ connToEnum hc $$ do+ let request = Blaze.toLazyByteString $ mconcat+ [ Blaze.fromByteString method+ , Blaze.fromByteString " "+ , Blaze.fromByteString $+ case S8.uncons path of+ Just ('/', _) -> path+ _ -> S8.cons '/' path+ , renderQS queryString+ , Blaze.fromByteString " HTTP/1.1\r\n"+ , mconcat $ flip map headers' $ \(k, v) -> mconcat+ [ Blaze.fromByteString k+ , Blaze.fromByteString ": "+ , Blaze.fromByteString v+ , Blaze.fromByteString "\r\n"+ ]+ , Blaze.fromByteString "\r\n"+ , mconcat $ map Blaze.fromByteString+ $ L.toChunks requestBody+ ]+ Right () <- run $ enumList 1 (L.toChunks request) $$ iter+ run $ enum $$ do ((_, sc, _), hs) <- iterHeaders let hs' = map (first $ S8.map toLower) hs let mcl = lookup "content-length" hs'@@ -295,33 +257,16 @@ else case mcl >>= readMay . S8.unpack of Just len -> takeLBS len Nothing -> E.map id- bodyStep <- lift $ runIteratee $ bodyIter sc hs- bodyStep' <- body' bodyStep- eres <- lift $ run $ Iteratee $ return bodyStep'- case eres of- Left err -> liftIO $ throwIO err- Right res -> return res+ joinI $ body' $$ bodyIter sc hs iterChunks' :: MonadIO m => Enumeratee S.ByteString S.ByteString m a iterChunks' k@(Continue _) = do-#if DEBUG- liftIO $ putStrLn "iterChunkHeader start"-#endif len <- iterChunkHeader-#if DEBUG- liftIO $ putStrLn $ "iterChunkHeader stop: " ++ show len-#endif if len == 0 then return k else do k' <- takeLBS len k-#if DEBUG- liftIO $ putStrLn "iterNewline start"-#endif iterNewline-#if DEBUG- liftIO $ putStrLn "iterNewline stop"-#endif iterChunks' k' iterChunks' step = return step @@ -345,14 +290,18 @@ else takeLBS len' step' takeLBS _ step = return step -renderQS :: [(S.ByteString, S.ByteString)]- -> [S.ByteString]- -> [S.ByteString]-renderQS [] x = x-renderQS (p:ps) x =- go "?" p ++ concatMap (go "&") ps ++ x+renderQS :: [(S.ByteString, S.ByteString)] -> Blaze.Builder+renderQS [] = mempty+renderQS (p:ps) = mconcat+ $ go "?" p+ : map (go "&") ps where- go sep (k, v) = [sep, escape k, "=", escape v]+ go sep (k, v) = mconcat+ [ Blaze.fromByteString sep+ , Blaze.fromByteString $ escape k+ , Blaze.fromByteString "="+ , Blaze.fromByteString $ escape v+ ] escape = S8.concatMap (S8.pack . encodeUrlChar) encodeUrlCharPI :: Char -> String@@ -495,13 +444,7 @@ -- memory. If you want constant memory usage, you'll need to write your own -- iteratee and use 'http' or 'httpRedirect' directly. lbsIter :: Monad m => Int -> Headers -> Iteratee S.ByteString m Response-lbsIter sc hs = do-#if DEBUG- b <- fmap L.fromChunks consume'-#else- b <- fmap L.fromChunks consume-#endif- return $ Response sc hs b+lbsIter sc hs = fmap (Response sc hs . L.fromChunks) consume -- | Download the specified 'Request', returning the results as a 'Response'. --@@ -517,27 +460,14 @@ httpLbs :: MonadIO m => Request -> m Response httpLbs = http lbsIter -#if DEBUG-consume' =- liftI step- where- step chunk = case chunk of- Chunks [] -> Continue $ returnI . step- Chunks xs -> Continue $ \stream -> do- liftIO $ putStrLn $ "consume': received Chunks: " ++ show xs- returnI $ step stream- EOF -> Yield [] EOF-#endif- -- | Download the specified URL, following any redirects, and return the -- response body. -- -- This function will 'failure' an 'HttpException' for any response with a -- non-2xx status code. It uses 'parseUrl' to parse the input. This function -- essentially wraps 'httpLbsRedirect'.-simpleHttp :: ( Failure InvalidUrlException m- , Failure HttpException m- , MonadIO m)+simpleHttp :: (MonadIO m, Failure HttpException m,+ Failure InvalidUrlException m) => String -> m L.ByteString simpleHttp url = do url' <- parseUrl url@@ -586,7 +516,7 @@ , path = path l , queryString = queryString l }- http iter req'+ httpRedirect iter req' Nothing -> iter code hs | otherwise = iter code hs @@ -602,8 +532,8 @@ -- -- Please see 'lbsIter' for more information on how the 'Response' value is -- created.-httpLbsRedirect :: ( Failure InvalidUrlException m- , MonadIO m)+httpLbsRedirect :: (MonadIO m, Failure InvalidUrlException m,+ Failure HttpException m) => Request -> m Response httpLbsRedirect = httpRedirect lbsIter @@ -611,3 +541,46 @@ readMay s = case reads s of [] -> Nothing (x, _):_ -> Just x++-- | Add url-encoded paramters to the 'Request'.+--+-- This sets a new 'requestBody', adds a content-type request header and+-- changes the 'method' to POST.+urlEncodedBody :: Headers -> Request -> Request+urlEncodedBody headers req = req+ { requestBody = body+ , method = "POST"+ , requestHeaders =+ (ct, "application/x-www-form-urlencoded")+ : filter (\(x, _) -> x /= ct) (requestHeaders req)+ }+ where+ ct = "Content-Type"+ body = Blaze.toLazyByteString $ body' headers+ body' [] = mempty+ body' [x] = pair x+ body' (x:xs) = pair x `mappend` Blaze.singleton 38 `mappend` body' xs+ pair (x, y)+ | S.null y = single x+ | otherwise =+ single x `mappend` Blaze.singleton 61 `mappend` single y+ single = Blaze.writeList go . S.unpack+ go 32 = Blaze.writeByte 43 -- space to plus+ go c | unreserved c = Blaze.writeByte c+ go c =+ let x = shiftR c 4+ y = c .&. 15+ in Blaze.writeByte 37 `mappend` hexChar x `mappend` hexChar y+ unreserved 45 = True -- hyphen+ unreserved 46 = True -- period+ unreserved 95 = True -- underscore+ unreserved 126 = True -- tilde+ unreserved c+ | 48 <= c && c <= 57 = True -- 0 - 9+ | 65 <= c && c <= 90 = True -- A - Z+ | 97 <= c && c <= 122 = True -- A - Z+ unreserved _ = False+ hexChar c+ | c < 10 = Blaze.writeByte $ c + 48+ | c < 16 = Blaze.writeByte $ c + 55+ | otherwise = error $ "hexChar: " ++ show c
Network/HTTP/Enumerator/HttpParser.hs view
@@ -49,8 +49,8 @@ parseHeaders :: Parser (Status, [Header]) parseHeaders = do- s <- parseStatus- h <- manyTill parseHeader newline+ s <- parseStatus <?> "HTTP status line"+ h <- manyTill parseHeader newline <?> "Response headers" return (s, h) iterHeaders :: Monad m => Iteratee S.ByteString m (Status, [Header])@@ -75,15 +75,6 @@ then newline >> parseStatus else return (ver, statCode', statMsg) -iterChunks :: Monad m => Iteratee S.ByteString m [S.ByteString]-iterChunks = iterParser parseChunks--parseChunks :: Parser [S.ByteString]-parseChunks = manyTill parseChunk zeroChunk--zeroChunk :: Parser ()-zeroChunk = word8 48 >> (newline <|> attribs) -- 0- parseChunkHeader :: Parser Int parseChunkHeader = do len <- hexs@@ -92,17 +83,11 @@ return len iterChunkHeader :: Monad m => Iteratee S.ByteString m Int-iterChunkHeader = iterParser parseChunkHeader+iterChunkHeader =+ iterParser (parseChunkHeader <?> "Chunked transfer encoding header") iterNewline :: Monad m => Iteratee S.ByteString m () iterNewline = iterParser newline--parseChunk :: Parser S.ByteString-parseChunk = do- len <- parseChunkHeader- bs <- take len- newline- return bs attribs :: Parser () attribs = do
+ Network/TLS/Cap.hs view
@@ -0,0 +1,19 @@+-- |+-- Module : Network.TLS.Cap+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--++module Network.TLS.Cap+ ( hasHelloExtensions+ , hasExplicitBlockIV+ ) where++import Network.TLS.Struct++hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool++hasHelloExtensions ver = ver >= TLS12+hasExplicitBlockIV ver = ver >= TLS11
+ Network/TLS/Cipher.hs view
@@ -0,0 +1,271 @@+-- |+-- Module : Network.TLS.Cipher+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Cipher+ ( CipherTypeFunctions(..)+ , CipherKeyExchangeType(..)+ , Cipher(..)+ , cipherExchangeNeedMoreData++ -- * builtin ciphers for ease of use, might move later to a tls-ciphers library+ , cipher_null_null+ , cipher_RC4_128_MD5+ , cipher_RC4_128_SHA1+ , cipher_AES128_SHA1+ , cipher_AES256_SHA1+ , cipher_AES128_SHA256+ , cipher_AES256_SHA256+ ) where++import Data.Word+import Network.TLS.Struct (Version(..))+import Network.TLS.MAC+import qualified Data.Vector.Unboxed as Vector (fromList, toList)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++import qualified Codec.Crypto.AES as AES+import qualified Crypto.Cipher.RC4 as RC4++-- FIXME convert to newtype+type Key = B.ByteString+type IV = B.ByteString++data CipherTypeFunctions =+ CipherNoneF -- special value for 0+ | CipherBlockF (Key -> IV -> B.ByteString -> B.ByteString)+ (Key -> IV -> B.ByteString -> B.ByteString)+ | CipherStreamF (Key -> IV)+ (IV -> B.ByteString -> (B.ByteString, IV))+ (IV -> B.ByteString -> (B.ByteString, IV))++data CipherKeyExchangeType =+ CipherKeyExchangeRSA+ | CipherKeyExchangeDHE_RSA+ | CipherKeyExchangeECDHE_RSA+ | CipherKeyExchangeDHE_DSS+ | CipherKeyExchangeDH_DSS+ | CipherKeyExchangeDH_RSA+ | CipherKeyExchangeECDH_ECDSA+ | CipherKeyExchangeECDH_RSA+ | CipherKeyExchangeECDHE_ECDSA++data Cipher = Cipher+ { cipherID :: Word16+ , cipherName :: String+ , cipherDigestSize :: Word8+ , cipherKeySize :: Word8+ , cipherIVSize :: Word8+ , cipherKeyBlockSize :: Word8+ , cipherPaddingSize :: Word8+ , cipherKeyExchange :: CipherKeyExchangeType+ , cipherHMAC :: B.ByteString -> B.ByteString -> B.ByteString+ , cipherF :: CipherTypeFunctions+ , cipherMinVer :: Maybe Version+ }++instance Show Cipher where+ show c = cipherName c++cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool+cipherExchangeNeedMoreData CipherKeyExchangeRSA = False+cipherExchangeNeedMoreData CipherKeyExchangeDHE_RSA = True+cipherExchangeNeedMoreData CipherKeyExchangeECDHE_RSA = True+cipherExchangeNeedMoreData CipherKeyExchangeDHE_DSS = True+cipherExchangeNeedMoreData CipherKeyExchangeDH_DSS = False+cipherExchangeNeedMoreData CipherKeyExchangeDH_RSA = False+cipherExchangeNeedMoreData CipherKeyExchangeECDH_ECDSA = True+cipherExchangeNeedMoreData CipherKeyExchangeECDH_RSA = True+cipherExchangeNeedMoreData CipherKeyExchangeECDHE_ECDSA = True++repack :: Int -> B.ByteString -> [B.ByteString]+repack bs x =+ if B.length x > bs+ then+ let (c1, c2) = B.splitAt bs x in+ B.pack (B.unpack c1) : repack 16 c2+ else+ [ x ]++lazyToStrict :: L.ByteString -> B.ByteString+lazyToStrict = B.concat . L.toChunks++aes128_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes128_cbc_encrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Encrypt d16+ where d16 = L.fromChunks $ repack 16 d++aes128_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes128_cbc_decrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Decrypt d16+ where d16 = L.fromChunks $ repack 16 d++aes256_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes256_cbc_encrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Encrypt d16+ where d16 = L.fromChunks $ repack 16 d++aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes256_cbc_decrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Decrypt d16+ where d16 = L.fromChunks $ repack 32 d++toIV :: RC4.Ctx -> IV+toIV (v, x, y) = B.pack (x : y : Vector.toList v)++toCtx :: IV -> RC4.Ctx+toCtx iv =+ case B.unpack iv of+ x:y:l -> (Vector.fromList l, x, y)+ _ -> (Vector.fromList [], 0, 0)++initF_rc4 :: Key -> IV+initF_rc4 key = toIV $ RC4.initCtx (B.unpack key)++encryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)+encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encrypt (toCtx iv) d++decryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)+decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.decrypt (toCtx iv) e++{-+TLS 1.0 ciphers definition++CipherSuite TLS_NULL_WITH_NULL_NULL = { 0x00,0x00 };+CipherSuite TLS_RSA_WITH_NULL_MD5 = { 0x00,0x01 };+CipherSuite TLS_RSA_WITH_NULL_SHA = { 0x00,0x02 };+CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x03 };+CipherSuite TLS_RSA_WITH_RC4_128_MD5 = { 0x00,0x04 };+CipherSuite TLS_RSA_WITH_RC4_128_SHA = { 0x00,0x05 };+CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5 = { 0x00,0x06 };+CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA = { 0x00,0x07 };+CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x08 };+CipherSuite TLS_RSA_WITH_DES_CBC_SHA = { 0x00,0x09 };+CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0A };+CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0B };+CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA = { 0x00,0x0C };+CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0D };+CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0E };+CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA = { 0x00,0x0F };+CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x10 };+CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 };+CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA = { 0x00,0x12 };+CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x13 };+CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 };+CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA = { 0x00,0x15 };+CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x16 };+CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x17 };+CipherSuite TLS_DH_anon_WITH_RC4_128_MD5 = { 0x00,0x18 };+CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 };+CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA = { 0x00,0x1A };+CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA = { 0x00,0x1B };+-}++{-+ - some builtin ciphers description+ -}++cipher_null_null :: Cipher+cipher_null_null = Cipher+ { cipherID = 0x0+ , cipherName = "null-null"+ , cipherDigestSize = 0+ , cipherKeySize = 0+ , cipherIVSize = 0+ , cipherKeyBlockSize = 0+ , cipherPaddingSize = 0+ , cipherHMAC = (\_ _ -> B.empty)+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherNoneF+ , cipherMinVer = Nothing+ }++cipher_RC4_128_MD5 :: Cipher+cipher_RC4_128_MD5 = Cipher+ { cipherID = 0x04+ , cipherName = "RSA-rc4-128-md5"+ , cipherDigestSize = 16+ , cipherKeySize = 16+ , cipherIVSize = 0+ , cipherKeyBlockSize = 2 * (16 + 16 + 0)+ , cipherPaddingSize = 0+ , cipherHMAC = hmacMD5+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4+ , cipherMinVer = Nothing+ }++cipher_RC4_128_SHA1 :: Cipher+cipher_RC4_128_SHA1 = Cipher+ { cipherID = 0x05+ , cipherName = "RSA-rc4-128-sha1"+ , cipherDigestSize = 20+ , cipherKeySize = 16+ , cipherIVSize = 0+ , cipherKeyBlockSize = 2 * (20 + 16 + 0)+ , cipherPaddingSize = 0+ , cipherHMAC = hmacSHA1+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4+ , cipherMinVer = Nothing+ }++cipher_AES128_SHA1 :: Cipher+cipher_AES128_SHA1 = Cipher+ { cipherID = 0x2f+ , cipherName = "RSA-aes128-sha1"+ , cipherDigestSize = 20+ , cipherKeySize = 16+ , cipherIVSize = 16+ , cipherKeyBlockSize = 2 * (20 + 16 + 16)+ , cipherPaddingSize = 16+ , cipherHMAC = hmacSHA1+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt+ , cipherMinVer = Just SSL3+ }++cipher_AES256_SHA1 :: Cipher+cipher_AES256_SHA1 = Cipher+ { cipherID = 0x35+ , cipherName = "RSA-aes256-sha1"+ , cipherDigestSize = 20+ , cipherKeySize = 32+ , cipherIVSize = 16+ , cipherKeyBlockSize = 2 * (20 + 32 + 16)+ , cipherPaddingSize = 16+ , cipherHMAC = hmacSHA1+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt+ , cipherMinVer = Just SSL3+ }++cipher_AES128_SHA256 :: Cipher+cipher_AES128_SHA256 = Cipher+ { cipherID = 0x3c+ , cipherName = "RSA-aes128-sha256"+ , cipherDigestSize = 32+ , cipherKeySize = 16+ , cipherIVSize = 16+ , cipherKeyBlockSize = 2 * (32 + 16 + 16)+ , cipherPaddingSize = 16+ , cipherHMAC = hmacSHA256+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt+ , cipherMinVer = Just TLS12+ }++cipher_AES256_SHA256 :: Cipher+cipher_AES256_SHA256 = Cipher+ { cipherID = 0x3d+ , cipherName = "RSA-aes256-sha256"+ , cipherDigestSize = 32+ , cipherKeySize = 32+ , cipherIVSize = 16+ , cipherKeyBlockSize = 2 * (32 + 32 + 16)+ , cipherPaddingSize = 16+ , cipherHMAC = hmacSHA256+ , cipherKeyExchange = CipherKeyExchangeRSA+ , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt+ , cipherMinVer = Just TLS12+ }
+ Network/TLS/Client.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++-- |+-- Module : Network.TLS.Client+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Client module contains the necessary calls to create a connecting TLS socket+-- aka. a client socket.+--+module Network.TLS.Client+ ( TLSClientParams(..)+ , TLSClientCallbacks(..)+ , TLSStateClient+ , newIState+ -- * low level packet sending receiving.+ , recvPacket+ , sendPacket+ -- * API, warning probably subject to change+ , connect+ , sendData+ , recvData+ , close+ -- * Enumerator interface+ , clientEnum+ , clientEnumSimple+ ) where++import Data.Maybe+import Data.Word+import Control.Applicative ((<$>))+import Data.Certificate.X509+import Network.TLS.Cipher+import Network.TLS.Struct+import Network.TLS.Packet+import Network.TLS.State+import Network.TLS.Sending+import Network.TLS.Receiving+import Network.TLS.SRandom+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import System.IO (Handle, hFlush)+import Data.List (find)+import Data.IORef+import qualified Data.Enumerator as E+import qualified Control.Monad.IO.Class as Trans+import qualified Control.Monad.Trans.Class as Trans+import qualified Codec.Crypto.AES.Random as AESRand+import Data.Bits+import Control.Monad (when, unless)++data TLSClientCallbacks = TLSClientCallbacks+ { cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates+ }++instance Show TLSClientCallbacks where+ show _ = "[callbacks]"++data TLSClientParams = TLSClientParams+ { cpConnectVersion :: Version -- ^ client version we're sending by default+ , cpAllowedVersions :: [Version] -- ^ allowed versions from the server+ , cpSession :: Maybe [Word8] -- ^ session for this connection+ , cpCiphers :: [Cipher] -- ^ all ciphers for this connection+ , cpCertificate :: Maybe Certificate -- ^ an optional client certificate+ , cpCallbacks :: TLSClientCallbacks -- ^ user callbacks+ } deriving (Show)++data TLSStateClient = TLSStateClient+ { scParams :: TLSClientParams -- ^ client params and config for this connection+ , scTLSState :: TLSState -- ^ client TLS State for this connection+ , scCertRequested :: Bool -- ^ mark that the server requested a certificate+ } deriving (Show)++type IState = IORef TLSStateClient++newIState :: TLSClientParams -> SRandomGen -> IO IState+newIState params rng = newIORef $ TLSStateClient+ { scParams = params+ , scTLSState = state+ , scCertRequested = False+ }+ where+ state = (newTLSState rng) { stVersion = cpConnectVersion params, stClientContext = True }++{- | receive a single TLS packet or on error a TLSError -}+recvPacket :: IState -> Handle -> IO (Either TLSError Packet)+recvPacket istate handle = do+ hdr <- B.hGet handle 5 >>= return . decodeHeader+ case hdr of+ Left err -> return $ Left err+ Right header@(Header _ _ readlen) -> do+ content <- B.hGet handle (fromIntegral readlen)+ runIStateWrapper (readPacket header (EncryptedData content)) istate++newtype IStateWrapper a = IStateWrapper { runIStateWrapper :: IState -> IO a }+instance Monad IStateWrapper where+ return = IStateWrapper . const . return+ (IStateWrapper f) >>= g = IStateWrapper $ \ i -> do+ x <- f i+ runIStateWrapper (g x) i+instance MonadTLSState IStateWrapper where+ getTLSState = IStateWrapper $ fmap scTLSState . readIORef+ putTLSState s = IStateWrapper $ \i -> do+ cs <- readIORef i+ writeIORef i cs { scTLSState = s }++{- | send a single TLS packet -}+sendPacket :: IState -> Handle -> Packet -> IO ()+sendPacket istate handle pkt = do+ dataToSend <- runIStateWrapper (writePacket pkt) istate+ B.hPut handle dataToSend++recvServerHello :: IState -> Handle -> IO ()+recvServerHello istate handle = do+ state' <- readIORef istate+ let ciphers = cpCiphers $ scParams state'+ let allowedvers = cpAllowedVersions $ scParams state'+ let callbacks = cpCallbacks $ scParams state'+ pkt <- recvPacket istate handle+ let hs = case pkt of+ Right (Handshake h) -> h+ Left err -> error ("error received: " ++ show err)+ Right x -> error ("unexpected packet received, expecting handshake " ++ show x)+ case hs of+ ServerHello ver _ _ cipher _ _ -> do+ case find ((==) ver) allowedvers of+ Nothing -> error ("received version which is not allowed: " ++ show ver)+ Just _ -> do+ state <- readIORef istate+ let st = state { scTLSState = (scTLSState state) { stVersion = ver } }+ writeIORef istate st++ case find ((==) cipher . cipherID) ciphers of+ Nothing -> error "no cipher in common with the server"+ Just c -> do+ state <- readIORef istate+ let st = state { scTLSState = (scTLSState state) { stCipher = Just c } }+ writeIORef istate st+ recvServerHello istate handle+ CertRequest _ _ _ -> do+ sc <- readIORef istate+ writeIORef istate sc { scCertRequested = True }+ recvServerHello istate handle+ Certificates certs -> do+ valid <- maybe (return True) (\cb -> cb certs) (cbCertificates callbacks)+ unless valid $ error "certificates received deemed invalid by user"+ recvServerHello istate handle+ ServerHelloDone -> return ()+ _ -> error "unexpected handshake message received in server hello messages"++connectSendClientHello :: IState -> Handle -> ClientRandom -> IO ()+connectSendClientHello istate handle crand = do+ state <- readIORef istate+ let ver = cpConnectVersion $ scParams state+ let ciphers = cpCiphers $ scParams state+ sendPacket istate handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing)++connectSendClientCertificate :: IState -> Handle -> IO ()+connectSendClientCertificate istate handle = do+ certRequested <- scCertRequested <$> readIORef istate+ when certRequested $ do+ clientCert <- cpCertificate . scParams <$> readIORef istate+ sendPacket istate handle $ Handshake (Certificates $ maybe [] (:[]) clientCert)++connectSendClientKeyXchg :: IState -> Handle -> ClientKeyData -> IO ()+connectSendClientKeyXchg istate handle prerand = do+ ver <- cpConnectVersion . scParams <$> readIORef istate+ sendPacket istate handle $ Handshake (ClientKeyXchg ver prerand)++connectSendFinish :: IState -> Handle -> IO ()+connectSendFinish istate handle = do+ cf <- runIStateWrapper (getHandshakeDigest True) istate+ sendPacket istate handle (Handshake $ Finished $ B.unpack cf)++{- | connect through a handle as a new TLS connection. -}+connect :: IState -> Handle -> ClientRandom -> ClientKeyData -> IO ()+connect istate handle crand premasterRandom = do+ connectSendClientHello istate handle crand+ recvServerHello istate handle+ connectSendClientCertificate istate handle++ connectSendClientKeyXchg istate handle premasterRandom++ {- maybe send certificateVerify -}+ {- FIXME not implemented yet -}++ sendPacket istate handle (ChangeCipherSpec)+ hFlush handle++ {- send Finished -}+ connectSendFinish istate handle+ + {- receive changeCipherSpec -}+ pktCCS <- recvPacket istate handle+ case pktCCS of+ Right ChangeCipherSpec -> return ()+ x -> error ("unexpected reply. expecting change cipher spec " ++ show x)++ {- receive Finished -}+ pktFin <- recvPacket istate handle+ case pktFin of+ Right (Handshake (Finished _)) -> return ()+ x -> error ("unexpected reply. expecting finished " ++ show x)++ return ()++sendDataChunk :: IState -> Handle -> B.ByteString -> IO ()+sendDataChunk istate handle d =+ if B.length d > 16384+ then do+ let (sending, remain) = B.splitAt 16384 d+ sendPacket istate handle $ AppData sending+ sendDataChunk istate handle remain+ else+ sendPacket istate handle $ AppData d++{- | sendData sends a bunch of data -}+sendData :: IState -> Handle -> L.ByteString -> IO ()+sendData istate handle d = mapM_ (sendDataChunk istate handle) (L.toChunks d)++{- | recvData get data out of Data packet, and automatically try to renegociate if+ - a Handshake HelloRequest is received -}+recvData :: IState -> Handle -> IO L.ByteString+recvData istate handle = do+ pkt <- recvPacket istate handle+ case pkt of+ Right (AppData x) -> return $ L.fromChunks [x]+ Right (Handshake HelloRequest) -> do+ -- SECURITY FIXME audit the rng here..+ state <- readIORef istate+ let st = scTLSState state+ let (bytes, rng') = getRandomBytes (stRandomGen st) 32+ let (premaster, rng'') = getRandomBytes rng' 46+ writeIORef istate $ state { scTLSState = st { stRandomGen = rng'' } }+ let crand = fromJust $ clientRandom bytes+ connect istate handle crand (ClientKeyData $ B.pack premaster)+ recvData istate handle+ Left err -> error ("error received: " ++ show err)+ _ -> error "unexpected item"++{- | close a TLS connection.+ - note that it doesn't close the handle, but just signal we're going to close+ - the connection to the other side -}+close :: IState -> Handle -> IO ()+close istate handle = do+ sendPacket istate handle $ Alert (AlertLevel_Warning, CloseNotify)++clientEnumSimple+ :: Trans.MonadIO m+ => Handle+ -> (E.Iteratee B.ByteString m () -> E.Enumerator B.ByteString m a -> m b)+ -> m b+clientEnumSimple h f = do+ ranByte <- Trans.liftIO $ B.head <$> AESRand.randBytes 1+ _ <- Trans.liftIO $ AESRand.randBytes (fromIntegral ranByte)+ clientRandom' <- Trans.liftIO $ fromJust . clientRandom . B.unpack <$> AESRand.randBytes 32+ premasterRandom <- Trans.liftIO $ ClientKeyData <$> AESRand.randBytes 46+ seqInit <- Trans.liftIO $ conv . B.unpack <$> AESRand.randBytes 4+ let clientstate = TLSClientParams+ { cpConnectVersion = TLS10+ , cpAllowedVersions = [ TLS10, TLS11 ]+ , cpSession = Nothing+ , cpCiphers = ciphers+ , cpCertificate = Nothing+ , cpCallbacks = TLSClientCallbacks+ { cbCertificates = Nothing+ }+ }+ clientEnum clientstate (makeSRandomGen seqInit) h clientRandom' premasterRandom f+ where+ ciphers =+ [ cipher_AES128_SHA1+ , cipher_AES256_SHA1+ , cipher_RC4_128_MD5+ , cipher_RC4_128_SHA1+ ]+ conv l = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d+ where+ [a,b,c,d] = map fromIntegral l++clientEnum :: Trans.MonadIO m+ => TLSClientParams -> SRandomGen -> Handle -> ClientRandom -> ClientKeyData+ -> (E.Iteratee B.ByteString m () -> E.Enumerator B.ByteString m a -> m b)+ -> m b+clientEnum tcp srg h cr ckd f = do+ istate <- Trans.liftIO $ newIState tcp srg+ Trans.liftIO $ connect istate h cr ckd+ b <- f (iter istate) (enum istate)+ Trans.liftIO $ close istate h+ return b+ where+ iter :: Trans.MonadIO m => IState -> E.Iteratee B.ByteString m ()+ iter istate =+ E.continue go+ where+ go E.EOF = return ()+ go (E.Chunks xs) = do+ Trans.liftIO $ sendData istate h $ L.fromChunks xs+ E.continue go+ enum :: Trans.MonadIO m => IState -> E.Enumerator B.ByteString m a+ enum istate (E.Continue k) = do+ lbs <- Trans.liftIO $ recvData istate h+ let chunks = E.Chunks $ L.toChunks lbs+ step <- Trans.lift $ E.runIteratee $ k chunks+ enum istate step+ enum _ step = E.returnI step
+ Network/TLS/Crypto.hs view
@@ -0,0 +1,110 @@+module Network.TLS.Crypto+ ( HashType(..)+ , HashCtx++ -- * incremental interface with algorithm type wrapping for genericity+ , initHash+ , updateHash+ , finalizeHash++ -- * single pass lazy bytestring interface for each algorithm+ , hashMD5+ , hashSHA1+ -- * incremental interface for each algorithm+ , initMD5+ , updateMD5+ , finalizeMD5+ , initSHA1+ , updateSHA1+ , finalizeSHA1++ -- * RSA stuff+ , PublicKey(..)+ , PrivateKey(..)+ , rsaEncrypt+ , rsaDecrypt+ ) where++import qualified Data.CryptoHash.SHA1 as SHA1+import qualified Data.CryptoHash.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++data HashCtx =+ SHA1 !SHA1.Ctx+ | MD5 !MD5.Ctx++instance Show HashCtx where+ show (SHA1 _) = "sha1"+ show (MD5 _) = "md5"++data HashType = HashTypeSHA1 | HashTypeMD5++{- MD5 -}++initMD5 :: MD5.Ctx+initMD5 = MD5.init++updateMD5 :: MD5.Ctx -> ByteString -> MD5.Ctx+updateMD5 = MD5.update++finalizeMD5 :: MD5.Ctx -> ByteString+finalizeMD5 = MD5.finalize++hashMD5 :: ByteString -> ByteString+hashMD5 = MD5.hash++{- SHA1 -}++initSHA1 :: SHA1.Ctx+initSHA1 = SHA1.init++updateSHA1 :: SHA1.Ctx -> ByteString -> SHA1.Ctx+updateSHA1 = SHA1.update++finalizeSHA1 :: SHA1.Ctx -> ByteString+finalizeSHA1 = SHA1.finalize++hashSHA1 :: ByteString -> ByteString+hashSHA1 = SHA1.hash++{- generic Hashing -}++initHash :: HashType -> HashCtx+initHash HashTypeSHA1 = SHA1 (initSHA1)+initHash HashTypeMD5 = MD5 (initMD5)++updateHash :: HashCtx -> B.ByteString -> HashCtx+updateHash (SHA1 ctx) = SHA1 . updateSHA1 ctx+updateHash (MD5 ctx) = MD5 . updateMD5 ctx++finalizeHash :: HashCtx -> B.ByteString+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++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 ]++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 ]
+ Network/TLS/MAC.hs view
@@ -0,0 +1,59 @@+module Network.TLS.MAC+ ( hmacMD5+ , hmacSHA1+ , hmacSHA256+ , prf_MD5+ , prf_SHA1+ , 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 Data.ByteString as B+import Data.ByteString (ByteString)+import Data.Bits (xor)++hmac :: (ByteString -> ByteString) -> Int -> ByteString -> ByteString -> ByteString+hmac f bl secret msg =+ f $! B.append opad (f $! B.append ipad msg)+ where+ opad = B.map (xor 0x5c) k'+ ipad = B.map (xor 0x36) k'++ k' = B.append kt pad+ where+ kt = if B.length secret > fromIntegral bl then f secret else secret+ pad = B.replicate (fromIntegral bl - B.length kt) 0++hmacMD5 :: ByteString -> ByteString -> ByteString+hmacMD5 secret msg = hmac MD5.hash 64 secret msg++hmacSHA1 :: ByteString -> ByteString -> ByteString+hmacSHA1 secret msg = hmac SHA1.hash 64 secret msg++hmacSHA256 :: ByteString -> ByteString -> ByteString+hmacSHA256 secret msg = hmac SHA256.hash 64 secret msg++hmacIter :: (ByteString -> ByteString -> ByteString) -> ByteString -> ByteString -> ByteString -> Int -> [ByteString]+hmacIter f secret seed aprev len =+ let an = f secret aprev in+ let out = f secret (B.concat [an, seed]) in+ let digestsize = fromIntegral $ B.length out in+ if digestsize >= len+ then [ B.take (fromIntegral len) out ]+ else out : hmacIter f secret seed an (len - digestsize)++prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString+prf_SHA1 secret seed len = B.concat $ hmacIter hmacSHA1 secret seed seed len++prf_MD5 :: ByteString -> ByteString -> Int -> ByteString+prf_MD5 secret seed len = B.concat $ hmacIter hmacMD5 secret seed seed len++prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString+prf_MD5SHA1 secret seed len =+ B.pack $ B.zipWith xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+ where+ slen = B.length secret+ s1 = B.take (slen `div` 2 + slen `mod` 2) secret+ s2 = B.drop (slen `div` 2) secret
+ Network/TLS/Packet.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Network.TLS.Packet+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Packet module contains everything necessary to serialize and deserialize things+-- with only explicit parameters, no TLS state is involved here.+--+module Network.TLS.Packet+ (+ -- * marshall functions for header messages+ decodeHeader+ , encodeHeader++ -- * marshall functions for alert messages+ , decodeAlert+ , encodeAlert++ -- * marshall functions for handshake messages+ , decodeHandshakeHeader+ , decodeHandshake+ , encodeHandshake+ , encodeHandshakeHeader+ , encodeHandshakeContent++ -- * marshall functions for change cipher spec message+ , decodeChangeCipherSpec+ , encodeChangeCipherSpec++ -- * generate things for packet content+ , generateMasterSecret+ , generateKeyBlock+ , generateClientFinished+ , generateServerFinished+ ) where++import Network.TLS.Struct+import Network.TLS.Cap+import Network.TLS.Wire+import Data.Either (partitionEithers)+import Data.Maybe (fromJust, isNothing)+import Control.Applicative ((<$>))+import Control.Monad+import Control.Monad.Error+import Data.Certificate.X509+import Network.TLS.Crypto+import Network.TLS.MAC+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as L++{-+ - decode and encode headers+ -}+decodeHeader :: ByteString -> Either TLSError Header+decodeHeader = runGet $ do+ ty <- getWord8+ major <- getWord8+ minor <- getWord8+ len <- getWord16+ case (valToType ty, verOfNum (major, minor)) of+ (Just y, Just v) -> return $ Header y v len+ (Nothing, _) -> throwError (Error_Packet "invalid type")+ (_, Nothing) -> throwError (Error_Packet "invalid version")++encodeHeader :: Header -> ByteString+encodeHeader (Header pt ver len) =+ {- FIXME check len <= 2^14 -}+ runPut (putWord8 (valOfType pt) >> putWord8 major >> putWord8 minor >> putWord16 len)+ where (major, minor) = numericalVer ver++{-+ - decode and encode ALERT+ -}++decodeAlert :: ByteString -> Either TLSError (AlertLevel, AlertDescription)+decodeAlert = runGet $ do+ al <- getWord8+ ad <- getWord8+ case (valToType al, valToType ad) of+ (Just a, Just d) -> return (a, d)+ (Nothing, _) -> throwError (Error_Packet "missing alert level")+ (_, Nothing) -> throwError (Error_Packet "missing alert description")++encodeAlert :: (AlertLevel, AlertDescription) -> ByteString+encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad))++{- decode and encode HANDSHAKE -}++decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, Bytes)+decodeHandshakeHeader = runGet $ do+ tyopt <- getWord8 >>= return . valToType+ ty <- if isNothing tyopt+ then throwError (Error_Unknown_Type "handshake type")+ else return $ fromJust tyopt+ len <- getWord24+ content <- getBytes len+ empty <- isEmpty+ unless empty (throwError (Error_Internal_Packet_Remaining 1))+ return (ty, content)++decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake+decodeHandshake ver ty = runGet $ case ty of+ HandshakeType_HelloRequest -> decodeHelloRequest+ HandshakeType_ClientHello -> decodeClientHello+ HandshakeType_ServerHello -> decodeServerHello+ HandshakeType_Certificate -> decodeCertificates+ HandshakeType_ServerKeyXchg -> decodeServerKeyXchg ver+ HandshakeType_CertRequest -> decodeCertRequest ver+ HandshakeType_ServerHelloDone -> decodeServerHelloDone+ HandshakeType_CertVerify -> decodeCertVerify+ HandshakeType_ClientKeyXchg -> decodeClientKeyXchg+ HandshakeType_Finished -> decodeFinished ver++decodeHelloRequest :: Get Handshake+decodeHelloRequest = return HelloRequest++decodeClientHello :: Get Handshake+decodeClientHello = do+ ver <- getVersion+ random <- getClientRandom32+ session <- getSession+ ciphers <- getWords16+ compressions <- getWords8+ r <- remaining+ exts <- if hasHelloExtensions ver && r > 0+ then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just+ else return Nothing+ return $ ClientHello ver random session ciphers compressions exts++decodeServerHello :: Get Handshake+decodeServerHello = do+ ver <- getVersion+ random <- getServerRandom32+ session <- getSession+ cipherid <- getWord16+ compressionid <- getWord8+ r <- remaining+ exts <- if hasHelloExtensions ver && r > 0+ then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just+ else return Nothing+ return $ ServerHello ver random session cipherid compressionid exts++decodeServerHelloDone :: Get Handshake+decodeServerHelloDone = return ServerHelloDone++decodeCertificates :: Get Handshake+decodeCertificates = do+ certslen <- getWord24+ certs <- getCerts certslen >>= return . map (decodeCertificate . L.fromChunks . (:[]))+ let (l, r) = partitionEithers certs+ if length l > 0+ then throwError $ Error_Certificate $ show l+ else return $ Certificates r++decodeFinished :: Version -> Get Handshake+decodeFinished ver = do+ -- unfortunately passing the verify_data_size here would be tedious for >=TLS12,+ -- so just return the remaining string.+ len <- if ver >= TLS12+ then remaining+ else if ver == SSL3 then return 36+ else return 12+ opaque <- getBytes (fromIntegral len)+ return $ Finished $ B.unpack opaque++getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ]+getSignatureHashAlgorithm 0 = return []+getSignatureHashAlgorithm len = do+ h <- fromJust . valToType <$> getWord8+ s <- fromJust . valToType <$> getWord8+ xs <- getSignatureHashAlgorithm (len - 2)+ return ((h, s) : xs)++decodeCertRequest :: Version -> Get Handshake+decodeCertRequest ver = do+ certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8++ sigHashAlgs <- if ver >= TLS12+ then do+ sighashlen <- getWord16+ Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen)+ else return Nothing+ dNameLen <- getWord16+ when (ver < TLS12 && dNameLen < 3) $ throwError (Error_Misc "certrequest distinguishname not of the correct size")+ dName <- getBytes $ fromIntegral dNameLen+ return $ CertRequest certTypes sigHashAlgs (B.unpack dName)++decodeCertVerify :: Get Handshake+decodeCertVerify =+ {- FIXME -}+ return $ CertVerify []++decodeClientKeyXchg :: Get Handshake+decodeClientKeyXchg = do+ ver <- getVersion+ ran <- getClientKeyData46+ return $ ClientKeyXchg ver ran++-- FIXME need to work out how we marshall an opaque number+--numberise :: ByteString -> Integer+numberise _ = 0++decodeServerKeyXchg_DH :: Get ServerDHParams+decodeServerKeyXchg_DH = do+ p <- getWord16 >>= getBytes . fromIntegral+ g <- getWord16 >>= getBytes . fromIntegral+ y <- getWord16 >>= getBytes . fromIntegral+ return $ ServerDHParams { dh_p = numberise p, dh_g = numberise g, dh_Ys = numberise y }++decodeServerKeyXchg_RSA :: Get ServerRSAParams+decodeServerKeyXchg_RSA = do+ modulus <- getWord16 >>= getBytes . fromIntegral+ expo <- getWord16 >>= getBytes . fromIntegral+ return $ ServerRSAParams { rsa_modulus = numberise modulus, rsa_exponent = numberise expo }++decodeServerKeyXchg :: Version -> Get Handshake+decodeServerKeyXchg ver = do+ -- mostly unimplemented+ skxAlg <- case ver of+ TLS12 -> return $ SKX_RSA Nothing+ TLS10 -> do+ rsaparams <- decodeServerKeyXchg_RSA+ return $ SKX_RSA $ Just rsaparams+ _ -> do+ return $ SKX_RSA Nothing+ return (ServerKeyXchg skxAlg)++encodeHandshake :: Handshake -> ByteString+encodeHandshake o =+ let content = runPut $ encodeHandshakeContent o in+ let len = fromIntegral $ B.length content in+ let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in+ B.concat [ header, content ]++encodeHandshakeHeader :: HandshakeType -> Int -> Put+encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len++encodeHandshakeContent :: Handshake -> Put++encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts) = do+ putVersion version+ putClientRandom32 random+ putSession session+ putWords16 cipherIDs+ putWords8 compressionIDs+ putExtensions exts+ return ()++encodeHandshakeContent (ServerHello version random session cipherID compressionID exts) =+ putVersion version >> putServerRandom32 random >> putSession session+ >> putWord16 cipherID >> putWord8 compressionID+ >> putExtensions exts >> return ()++encodeHandshakeContent (Certificates certs) =+ putWord24 len >> putBytes certbs+ where+ certbs = runPut $ mapM_ putCert certs+ len = fromIntegral $ B.length certbs++encodeHandshakeContent (ClientKeyXchg version random) = do+ putVersion version+ putClientKeyData46 random++encodeHandshakeContent (ServerKeyXchg _) = do+ -- FIXME+ return ()++encodeHandshakeContent (HelloRequest) = return ()+encodeHandshakeContent (ServerHelloDone) = return ()++encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do+ putWords8 (map valOfType certTypes)+ case sigAlgs of+ Nothing -> return ()+ Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l+ putBytes $ B.pack certAuthorities++encodeHandshakeContent (CertVerify _) = undefined++encodeHandshakeContent (Finished opaque) = mapM_ putWord8 opaque++{- marshall helpers -}+getVersion :: Get Version+getVersion = do+ major <- getWord8+ minor <- getWord8+ case verOfNum (major, minor) of+ Just v -> return v+ Nothing -> throwError (Error_Unknown_Version major minor)++putVersion :: Version -> Put+putVersion ver = putWord8 major >> putWord8 minor+ where (major, minor) = numericalVer ver++{- FIXME make sure it return error if not 32 available -}+getRandom32 :: Get Bytes+getRandom32 = getBytes 32++getServerRandom32 :: Get ServerRandom+getServerRandom32 = ServerRandom <$> getRandom32++getClientRandom32 :: Get ClientRandom+getClientRandom32 = ClientRandom <$> getRandom32++putRandom32 :: Bytes -> Put+putRandom32 = putBytes++putClientRandom32 :: ClientRandom -> Put+putClientRandom32 (ClientRandom r) = putRandom32 r++putServerRandom32 :: ServerRandom -> Put+putServerRandom32 (ServerRandom r) = putRandom32 r++getClientKeyData46 :: Get ClientKeyData+getClientKeyData46 = ClientKeyData <$> getBytes 46++putClientKeyData46 :: ClientKeyData -> Put+putClientKeyData46 (ClientKeyData d) = putBytes d++getSession :: Get Session+getSession = do+ len8 <- getWord8+ case fromIntegral len8 of+ 0 -> return $ Session Nothing+ len -> Session . Just <$> getBytes len++putSession :: Session -> Put+putSession (Session session) =+ case session of+ Nothing -> putWord8 0+ Just s -> putWord8 (fromIntegral $ B.length s) >> putBytes s++getCerts :: Int -> Get [Bytes]+getCerts 0 = return []+getCerts len = do+ certlen <- getWord24+ cert <- getBytes certlen+ certxs <- getCerts (len - certlen - 3)+ return (cert : certxs)++putCert :: Certificate -> Put+putCert cert = putWord24 (fromIntegral $ B.length content) >> putBytes content+ where content = B.concat $ L.toChunks $ encodeCertificate cert++getExtensions :: Int -> Get [Extension]+getExtensions 0 = return []+getExtensions len = do+ extty <- getWord16+ extdatalen <- getWord16+ extdata <- getBytes $ fromIntegral extdatalen+ extxs <- getExtensions (len - fromIntegral extdatalen - 4)+ return $ (extty, B.unpack extdata) : extxs++putExtension :: Extension -> Put+putExtension (ty, l) = do+ putWord16 ty+ putWord16 (fromIntegral $ length l)+ putBytes (B.pack l)++putExtensions :: Maybe [Extension] -> Put+putExtensions Nothing = return ()+putExtensions (Just es) =+ putWord16 (fromIntegral $ B.length extbs) >> putBytes extbs+ where+ extbs = runPut $ mapM_ putExtension es++{-+ - decode and encode ALERT+ -}++decodeChangeCipherSpec :: ByteString -> Either TLSError ()+decodeChangeCipherSpec b = do+ case runGet getWord8 b of+ Left e -> Left e+ Right x ->+ if x == 1+ then Right ()+ else Left $ Error_Misc "unknown change cipher spec content"++encodeChangeCipherSpec :: ByteString+encodeChangeCipherSpec = runPut (putWord8 1)++{-+ - generate things for packet content+ -}+generateMasterSecret_TLS, generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes+generateMasterSecret_TLS premasterSecret (ClientRandom c) (ServerRandom s) =+ prf_MD5SHA1 premasterSecret seed 48+ where+ seed = B.concat [ BC.pack "master secret", c, s ]++generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) =+ B.concat $ map (computeMD5 . BC.pack) [ "A", "BB", "CCC" ]+ where+ computeMD5 label = hashMD5 $ B.concat [ premasterSecret, computeSHA1 label ]+ computeSHA1 label = hashSHA1 $ B.concat [ label, premasterSecret, c, s ]++generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes+generateMasterSecret ver =+ if ver < TLS10 then generateMasterSecret_SSL else generateMasterSecret_TLS++generateKeyBlock :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes+generateKeyBlock (ClientRandom c) (ServerRandom s) mastersecret kbsize =+ prf_MD5SHA1 mastersecret seed kbsize+ where+ seed = B.concat [ BC.pack "key expansion", s, c ]++generateFinished_TLS :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes+generateFinished_TLS label mastersecret md5ctx sha1ctx =+ prf_MD5SHA1 mastersecret seed 12+ where+ seed = B.concat [ label, finalizeHash md5ctx, finalizeHash sha1ctx ]++generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes+generateFinished_SSL sender mastersecret md5ctx sha1ctx =+ B.concat [md5hash, sha1hash]+ where+ md5hash = hashMD5 $ B.concat [ mastersecret, pad2, md5left ]+ sha1hash = hashSHA1 $ B.concat [ mastersecret, pad2, sha1left ]+ pad2 = B.empty -- FIXME+ md5left = hashMD5 B.empty+ sha1left = hashSHA1 B.empty++generateClientFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes+generateClientFinished ver =+ if ver < TLS10 then generateFinished_SSL "CLNT" else generateFinished_TLS (BC.pack "client finished")++generateServerFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes+generateServerFinished ver =+ if ver < TLS10 then generateFinished_SSL "SRVR" else generateFinished_TLS (BC.pack "server finished")
+ Network/TLS/Receiving.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}++-- |+-- Module : Network.TLS.Receiving+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Receiving module contains calls related to unmarshalling packets according+-- to the TLS state+--+module Network.TLS.Receiving (+ readPacket+ ) where++import Control.Applicative ((<$>))+import Control.Monad.State+import Control.Monad.Error+import Data.Maybe++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++import Network.TLS.Util+import Network.TLS.Cap+import Network.TLS.Struct+import Network.TLS.Packet+import Network.TLS.State+import Network.TLS.Cipher+import Network.TLS.Crypto+import Network.TLS.SRandom+import Data.Certificate.X509++newtype TLSRead a = TLSR { runTLSR :: ErrorT TLSError (State TLSState) a }+ deriving (Monad, MonadError TLSError)++instance Functor TLSRead where+ fmap f = TLSR . fmap f . runTLSR++instance MonadTLSState TLSRead where+ putTLSState x = TLSR (lift $ put x)+ getTLSState = TLSR (lift get)++runTLSRead :: MonadTLSState m => TLSRead a -> m (Either TLSError a)+runTLSRead f = do+ st <- getTLSState+ let (a, newst) = runState (runErrorT (runTLSR f)) st+ putTLSState newst+ return a++returnEither :: Either TLSError a -> TLSRead a+returnEither (Left err) = throwError err+returnEither (Right a) = return a++readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet)+readPacket hdr@(Header ProtocolType_AppData _ _) content =+ runTLSRead (AppData <$> decryptContent hdr content)++readPacket hdr@(Header ProtocolType_Alert _ _) content =+ runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert)++readPacket hdr@(Header ProtocolType_ChangeCipherSpec _ _) content = runTLSRead $ do+ dcontent <- decryptContent hdr content+ returnEither $ decodeChangeCipherSpec dcontent+ switchRxEncryption+ isClientContext >>= \cc -> when (not cc) setKeyBlock+ return ChangeCipherSpec++readPacket hdr@(Header ProtocolType_Handshake ver _) content =+ runTLSRead (decryptContent hdr content >>= processHsPacket ver)++decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)+decryptRSA econtent = do+ rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake+ return $ rsaDecrypt rsapriv (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)++processClientKeyXchg :: Version -> ByteString -> TLSRead ()+processClientKeyXchg ver content = do+ {- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -}+ expectedVer <- getTLSState >>= return . hstClientVersion . fromJust . stHandshake+ if expectedVer /= ver+ then setMasterSecretRandom content+ else setMasterSecret content++processClientFinished :: FinishedData -> TLSRead ()+processClientFinished fdata = do+ cc <- getTLSState >>= return . stClientContext+ expected <- getHandshakeDigest (not cc)+ when (expected /= B.pack fdata) $ do+ -- FIXME don't fail, but report the error so that the code can send a BadMac Alert.+ fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata))+ return ()++processHsPacket :: Version -> ByteString -> TLSRead Packet+processHsPacket ver dcontent = do+ (ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent+ -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.+ content <- case ty of+ HandshakeType_ClientKeyXchg -> do+ copt <- decryptRSA econtent+ return $ maybe econtent id copt+ _ ->+ return econtent+ hs <- case (ty, decodeHandshake ver ty content) of+ (_, Right x) -> return x+ (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff)+ (_, Left err) -> throwError err+ clientmode <- isClientContext+ case hs of+ ClientHello cver ran _ _ _ _ -> unless clientmode $ do+ startHandshakeClient cver ran+ ServerHello sver ran _ _ _ _ -> when clientmode $ do+ setServerRandom ran+ setVersion sver+ Certificates certs -> when clientmode $ do processCertificates certs+ ClientKeyXchg cver _ -> unless clientmode $ do+ processClientKeyXchg cver content+ Finished fdata -> processClientFinished fdata+ _ -> return ()+ when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent)+ return $ Handshake hs+++decryptContent :: Header -> EncryptedData -> TLSRead ByteString+decryptContent hdr e@(EncryptedData b) = do+ st <- getTLSState+ if stRxEncrypted st+ then decryptData e >>= getCipherData hdr+ else return b++getCipherData :: Header -> CipherData -> TLSRead ByteString+getCipherData hdr cdata = do+ -- check if the MAC is valid.+ macValid <- case cipherDataMAC cdata of+ Nothing -> return True+ Just digest -> do+ let (Header pt ver _) = hdr+ let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)+ expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata+ if expected_digest == digest+ then return True+ else return False++ -- check if the padding is filled with the correct pattern if it exists+ paddingValid <- case cipherDataPadding cdata of+ Nothing -> return True+ Just pad -> do+ let b = B.length pad - 1+ return $ maybe True (const False) $ B.find (/= fromIntegral b) pad++ unless (and $! [ macValid, paddingValid ]) $ do+ throwError $ Error_Digest ([], [])++ return $ cipherDataContent cdata++decryptData :: EncryptedData -> TLSRead CipherData+decryptData (EncryptedData econtent) = do+ st <- getTLSState++ assert "decrypt data"+ [ ("cipher", isNothing $ stCipher st)+ , ("crypt state", isNothing $ stRxCryptState st) ]++ let cipher = fromJust $ stCipher st+ let cst = fromJust $ stRxCryptState st+ let padding_size = fromIntegral $ cipherPaddingSize cipher+ let digestSize = fromIntegral $ cipherDigestSize cipher+ let writekey = cstKey cst++ case cipherF cipher of+ CipherNoneF -> fail "none decrypt"+ CipherBlockF _ decryptF -> do+ {- update IV -}+ let (iv, econtent') =+ if hasExplicitBlockIV $ stVersion st+ then B.splitAt (fromIntegral $ cipherIVSize cipher) econtent+ else (cstIV cst, econtent)+ let newiv = fromJust $ takelast padding_size econtent'+ putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }++ let content' = decryptF writekey iv econtent'+ let paddinglength = fromIntegral (B.last content') + 1+ let contentlen = B.length content' - paddinglength - digestSize+ let (content, mac, padding) = fromJust $ partition3 content' (contentlen, digestSize, paddinglength)+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just padding+ }+ CipherStreamF initF _ decryptF -> do+ let iv = cstIV cst+ let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent+ {- update Ctx -}+ let contentlen = B.length content' - digestSize+ let (content, mac, _) = fromJust $ partition3 content' (contentlen, digestSize, 0)+ putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }++processCertificates :: [Certificate] -> TLSRead ()+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 }+ setPublicKey pk+ _ -> return ()
+ Network/TLS/SRandom.hs view
@@ -0,0 +1,30 @@+-- this is probably not a very good random interface, nor it has any good randomness capability.+-- the module is just here until a really good CPRNG implementation come up..+module Network.TLS.SRandom+ ( SRandomGen+ , makeSRandomGen+ , getRandomByte+ , getRandomBytes+ ) where++import System.Random+import Control.Arrow (first)+import Data.Word++type SRandomGen = StdGen++makeSRandomGen :: Int -> SRandomGen+makeSRandomGen i = mkStdGen i++getRandomByte :: SRandomGen -> (Word8, SRandomGen)+getRandomByte rng = first fromIntegral $ next rng++getRandomBytes :: SRandomGen -> Int -> ([Word8], SRandomGen)+getRandomBytes rng n =+ let list = helper rng n in+ (map fst list, snd $ last list)+ where+ helper _ 0 = []+ helper g i =+ let (b, g') = getRandomByte g in+ (b, g') : helper g' (i-1)
+ Network/TLS/Sending.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module : Network.TLS.Sending+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Sending module contains calls related to marshalling packets according+-- to the TLS state +--+module Network.TLS.Sending (+ writePacket+ ) where++import Control.Monad.State+import Data.Maybe++import Data.ByteString (ByteString)+import qualified Data.ByteString as B++import Network.TLS.Util+import Network.TLS.Cap+import Network.TLS.Wire+import Network.TLS.Struct+import Network.TLS.Packet+import Network.TLS.State+import Network.TLS.Cipher+import Network.TLS.Crypto++{-+ - 'makePacketData' create a Header and a content bytestring related to a packet+ - this doesn't change any state+ -}+makePacketData :: MonadTLSState m => Packet -> m (Header, ByteString)+makePacketData pkt = do+ ver <- getTLSState >>= return . stVersion+ content <- writePacketContent pkt+ let hdr = Header (packetType pkt) ver (fromIntegral $ B.length content)+ return (hdr, content)++{-+ - Handshake data need to update a digest+ -}+processPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)+processPacketData dat@(Header ty _ _, content) = do+ when (ty == ProtocolType_Handshake) (updateHandshakeDigest content)+ return dat++{-+ - when Tx Encrypted is set, we pass the data through encryptContent, otherwise+ - we just return the packet+ -}+encryptPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)+encryptPacketData dat = do+ st <- getTLSState+ if stTxEncrypted st+ then encryptContent dat+ else return dat++{-+ - ChangeCipherSpec state change need to be handled after encryption otherwise+ - its own packet would be encrypted with the new context, instead of beeing sent+ - under the current context+ -}+postprocessPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)+postprocessPacketData dat@(Header ProtocolType_ChangeCipherSpec _ _, _) =+ switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return dat++postprocessPacketData dat = return dat++{-+ - marshall packet data+ -}+encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString+encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]+++{-+ - writePacket transform a packet into marshalled data related to current state+ - and updating state on the go+ -}+writePacket :: MonadTLSState m => Packet -> m ByteString+writePacket pkt = makePacketData pkt >>= processPacketData >>=+ encryptPacketData >>= postprocessPacketData >>= encodePacket++{------------------------------------------------------------------------------}+{- SENDING Helpers -}+{------------------------------------------------------------------------------}++{- if the RSA encryption fails we just return an empty bytestring, and let the protocol+ - fail by itself; however it would be probably better to just report it since it's an internal problem.+ -}+encryptRSA :: MonadTLSState m => ByteString -> m ByteString+encryptRSA content = do+ 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+ putTLSState (st { stRandomGen = g' })+ return econtent++encryptContent :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)+encryptContent (hdr@(Header pt ver _), content) = do+ digest <- makeDigest True hdr content+ encrypted_msg <- encryptData $ B.concat [content, digest]+ let hdrnew = Header pt ver (fromIntegral $ B.length encrypted_msg)+ return (hdrnew, encrypted_msg)++encryptData :: MonadTLSState m => ByteString -> m ByteString+encryptData content = do+ st <- getTLSState++ assert "encrypt data"+ [ ("cipher", isNothing $ stCipher st)+ , ("crypt state", isNothing $ stTxCryptState st) ]++ let cipher = fromJust $ stCipher st+ let cst = fromJust $ stTxCryptState st+ let padding_size = fromIntegral $ cipherPaddingSize cipher++ let msg_len = B.length content+ let padding = if padding_size > 0+ then+ let padbyte = padding_size - (msg_len `mod` padding_size) in+ let padbyte' = if padbyte == 0 then padding_size else padbyte in+ B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else+ B.empty+ let writekey = cstKey cst++ econtent <- case cipherF cipher of+ CipherNoneF -> fail "none encrypt"+ CipherBlockF encrypt _ -> do+ let iv = cstIV cst+ let e = encrypt writekey iv (B.concat [ content, padding ])+ let newiv = fromJust $ takelast (fromIntegral $ cipherIVSize cipher) e+ putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ return $ if hasExplicitBlockIV $ stVersion st+ then B.concat [iv,e]+ else e+ CipherStreamF initF encryptF _ -> do+ let iv = cstIV cst+ let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content+ putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ return e+ return econtent++encodePacketContent :: Packet -> ByteString+encodePacketContent (Handshake h) = encodeHandshake h+encodePacketContent (Alert a) = encodeAlert a+encodePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec+encodePacketContent (AppData x) = x++writePacketContent :: MonadTLSState m => Packet -> m ByteString+writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do+ let premastersecret = runPut $ encodeHandshakeContent ckx+ setMasterSecret premastersecret+ econtent <- encryptRSA premastersecret+ let extralength = runPut $ putWord16 $ fromIntegral $ B.length econtent+ let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) (fromIntegral (B.length econtent + 2))+ return $ B.concat [hdr, extralength, econtent]++writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do+ cc <- isClientContext+ when cc (startHandshakeClient ver crand)+ return $ encodePacketContent pkt++writePacketContent pkt@(Handshake (ServerHello ver srand _ _ _ _)) = do+ cc <- isClientContext+ unless cc $ do+ setVersion ver+ setServerRandom srand+ return $ encodePacketContent pkt++writePacketContent pkt = return $ encodePacketContent pkt
+ Network/TLS/State.hs view
@@ -0,0 +1,267 @@+-- |+-- Module : Network.TLS.State+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the State module contains calls related to state initialization/manipulation+-- which is use by the Receiving module and the Sending module.+--+module Network.TLS.State+ ( TLSState(..)+ , TLSHandshakeState(..)+ , TLSCryptState(..)+ , TLSMacState(..)+ , MonadTLSState, getTLSState, putTLSState, modifyTLSState+ , newTLSState+ , assert -- FIXME move somewhere else (Internal.hs ?)+ , finishHandshakeTypeMaterial+ , finishHandshakeMaterial+ , makeDigest+ , setMasterSecret+ , setPublicKey+ , setPrivateKey+ , setKeyBlock+ , setVersion+ , setCipher+ , setServerRandom+ , switchTxEncryption+ , switchRxEncryption+ , isClientContext+ , startHandshakeClient+ , updateHandshakeDigest+ , getHandshakeDigest+ , endHandshake+ ) where++import Data.Word+import Data.Maybe (fromJust, isNothing)+import Network.TLS.Util+import Network.TLS.Struct+import Network.TLS.SRandom+import Network.TLS.Wire+import Network.TLS.Packet+import Network.TLS.Crypto+import Network.TLS.Cipher+import qualified Data.ByteString as B+import Control.Monad++assert :: Monad m => String -> [(String,Bool)] -> m ()+assert fctname list = forM_ list $ \ (name, assumption) -> do+ when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed")++data TLSCryptState = TLSCryptState+ { cstKey :: !Bytes+ , cstIV :: !Bytes+ , cstMacSecret :: !Bytes+ } deriving (Show)++data TLSMacState = TLSMacState+ { msSequence :: Word64+ } deriving (Show)++data TLSHandshakeState = TLSHandshakeState+ { hstClientVersion :: !(Version)+ , hstClientRandom :: !ClientRandom+ , hstServerRandom :: !(Maybe ServerRandom)+ , hstMasterSecret :: !(Maybe Bytes)+ , hstRSAPublicKey :: !(Maybe PublicKey)+ , hstRSAPrivateKey :: !(Maybe PrivateKey)+ , hstHandshakeDigest :: Maybe (HashCtx, HashCtx) -- FIXME could be only 1 hash in tls12+ } deriving (Show)++data TLSState = TLSState+ { stClientContext :: Bool+ , stVersion :: !Version+ , stHandshake :: !(Maybe TLSHandshakeState)+ , stTxEncrypted :: Bool+ , stRxEncrypted :: Bool+ , stTxCryptState :: !(Maybe TLSCryptState)+ , stRxCryptState :: !(Maybe TLSCryptState)+ , stTxMacState :: !(Maybe TLSMacState)+ , stRxMacState :: !(Maybe TLSMacState)+ , stCipher :: Maybe Cipher+ , stRandomGen :: SRandomGen+ } deriving (Show)++class (Monad m) => MonadTLSState m where+ getTLSState :: m TLSState+ putTLSState :: TLSState -> m ()++newTLSState :: SRandomGen -> TLSState+newTLSState rng = TLSState+ { stClientContext = False+ , stVersion = TLS10+ , stHandshake = Nothing+ , stTxEncrypted = False+ , stRxEncrypted = False+ , stTxCryptState = Nothing+ , stRxCryptState = Nothing+ , stTxMacState = Nothing+ , stRxMacState = Nothing+ , stCipher = Nothing+ , stRandomGen = rng+ }++modifyTLSState :: (MonadTLSState m) => (TLSState -> TLSState) -> m ()+modifyTLSState f = getTLSState >>= \st -> putTLSState (f st)++makeDigest :: (MonadTLSState m) => Bool -> Header -> Bytes -> m Bytes+makeDigest w hdr content = do+ st <- getTLSState+ assert "make digest"+ [ ("cipher", isNothing $ stCipher st)+ , ("crypt state", isNothing $ if w then stTxCryptState st else stRxCryptState st)+ , ("mac state", isNothing $ if w then stTxMacState st else stRxMacState st) ]+ let cst = fromJust $ if w then stTxCryptState st else stRxCryptState st+ let ms = fromJust $ if w then stTxMacState st else stRxMacState st+ let cipher = fromJust $ stCipher st++ let hmac_msg = B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ]+ let digest = (cipherHMAC cipher) (cstMacSecret cst) hmac_msg++ let newms = ms { msSequence = (msSequence ms) + 1 }++ modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })+ return digest++finishHandshakeTypeMaterial :: HandshakeType -> Bool+finishHandshakeTypeMaterial HandshakeType_ClientHello = True+finishHandshakeTypeMaterial HandshakeType_ServerHello = True+finishHandshakeTypeMaterial HandshakeType_Certificate = True+finishHandshakeTypeMaterial HandshakeType_HelloRequest = False+finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True+finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True+finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True+finishHandshakeTypeMaterial HandshakeType_CertRequest = True+finishHandshakeTypeMaterial HandshakeType_CertVerify = False+finishHandshakeTypeMaterial HandshakeType_Finished = True++finishHandshakeMaterial :: Handshake -> Bool+finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake++switchTxEncryption :: MonadTLSState m => m ()+switchTxEncryption = getTLSState >>= putTLSState . (\st -> st { stTxEncrypted = True })++switchRxEncryption :: MonadTLSState m => m ()+switchRxEncryption = getTLSState >>= putTLSState . (\st -> st { stRxEncrypted = True })++setServerRandom :: MonadTLSState m => ServerRandom -> m ()+setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran })++setMasterSecret :: MonadTLSState m => Bytes -> m ()+setMasterSecret premastersecret = do+ st <- getTLSState+ hasValidHandshake "master secret"+ assert "set master secret"+ [ ("server random", (isNothing $ hstServerRandom $ fromJust $ stHandshake st)) ]++ updateHandshake "master secret" (\hst ->+ let ms = generateMasterSecret (stVersion st) premastersecret (hstClientRandom hst) (fromJust $ hstServerRandom hst) in+ hst { hstMasterSecret = Just ms } )+ return ()++setPublicKey :: MonadTLSState m => PublicKey -> m ()+setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk })++setPrivateKey :: MonadTLSState m => PrivateKey -> m ()+setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk })++setKeyBlock :: MonadTLSState m => m ()+setKeyBlock = do+ st <- getTLSState++ let hst = fromJust $ stHandshake st+ assert "set key block"+ [ ("cipher", (isNothing $ stCipher st))+ , ("server random", (isNothing $ hstServerRandom hst))+ , ("master secret", (isNothing $ hstMasterSecret hst))+ ]++ let cc = stClientContext st+ let cipher = fromJust $ stCipher st+ let keyblockSize = fromIntegral $ cipherKeyBlockSize cipher+ let digestSize = fromIntegral $ cipherDigestSize cipher+ let keySize = fromIntegral $ cipherKeySize cipher+ let ivSize = fromIntegral $ cipherIVSize cipher+ let kb = generateKeyBlock (hstClientRandom hst)+ (fromJust $ hstServerRandom hst)+ (fromJust $ hstMasterSecret hst) keyblockSize++ let (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =+ fromJust $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize)++ let cstClient = TLSCryptState+ { cstKey = cWriteKey+ , cstIV = cWriteIV+ , cstMacSecret = cMACSecret }+ let cstServer = TLSCryptState+ { cstKey = sWriteKey+ , cstIV = sWriteIV+ , cstMacSecret = sMACSecret }+ let msClient = TLSMacState { msSequence = 0 }+ let msServer = TLSMacState { msSequence = 0 }+ putTLSState $ st+ { stTxCryptState = Just $ if cc then cstClient else cstServer+ , stRxCryptState = Just $ if cc then cstServer else cstClient+ , stTxMacState = Just $ if cc then msClient else msServer+ , stRxMacState = Just $ if cc then msServer else msClient+ }++setCipher :: MonadTLSState m => Cipher -> m ()+setCipher cipher = getTLSState >>= putTLSState . (\st -> st { stCipher = Just cipher })++setVersion :: MonadTLSState m => Version -> m ()+setVersion ver = getTLSState >>= putTLSState . (\st -> st { stVersion = ver })++isClientContext :: MonadTLSState m => m Bool+isClientContext = getTLSState >>= return . stClientContext++-- create a new empty handshake state+newEmptyHandshake :: Version -> ClientRandom -> TLSHandshakeState+newEmptyHandshake ver crand = TLSHandshakeState+ { hstClientVersion = ver+ , hstClientRandom = crand+ , hstServerRandom = Nothing+ , hstMasterSecret = Nothing+ , hstRSAPublicKey = Nothing+ , hstRSAPrivateKey = Nothing+ , hstHandshakeDigest = Nothing+ }++startHandshakeClient :: MonadTLSState m => Version -> ClientRandom -> m ()+startHandshakeClient ver crand = do+ -- FIXME check if handshake is already not null+ chs <- getTLSState >>= return . stHandshake+ when (isNothing chs) $+ modifyTLSState (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand })++hasValidHandshake :: MonadTLSState m => String -> m ()+hasValidHandshake name = getTLSState >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ]++updateHandshake :: MonadTLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m ()+updateHandshake n f = do+ hasValidHandshake n+ modifyTLSState (\st -> st { stHandshake = maybe Nothing (Just . f) (stHandshake st) })++updateHandshakeDigest :: MonadTLSState m => Bytes -> m ()+updateHandshakeDigest content = updateHandshake "update digest" (\hs ->+ let (c1, c2) = case hstHandshakeDigest hs of+ Nothing -> (initHash HashTypeSHA1, initHash HashTypeMD5)+ Just (sha1ctx, md5ctx) -> (sha1ctx, md5ctx) in+ let nc1 = updateHash c1 content in+ let nc2 = updateHash c2 content in+ hs { hstHandshakeDigest = Just (nc1, nc2) }+ )++getHandshakeDigest :: MonadTLSState m => Bool -> m Bytes+getHandshakeDigest client = do+ st <- getTLSState+ let hst = fromJust $ stHandshake st+ let (sha1ctx, md5ctx) = fromJust $ hstHandshakeDigest hst+ let msecret = fromJust $ hstMasterSecret hst+ return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret md5ctx sha1ctx++endHandshake :: MonadTLSState m => m ()+endHandshake = modifyTLSState (\st -> st { stHandshake = Nothing })
+ Network/TLS/Struct.hs view
@@ -0,0 +1,417 @@+-- |+-- Module : Network.TLS.Struct+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Struct module contains all definitions and values of the TLS protocol+--+module Network.TLS.Struct+ ( Bytes+ , Version(..)+ , ConnectionEnd(..)+ , CipherType(..)+ , CipherData(..)+ , Extension+ , EncryptedData(..)+ , CertificateType(..)+ , HashAlgorithm(..)+ , SignatureAlgorithm(..)+ , ProtocolType(..)+ , TLSError(..)+ , ServerDHParams(..)+ , ServerRSAParams(..)+ , ServerKeyXchgAlgorithmData(..)+ , Packet(..)+ , Header(..)+ , ServerRandom(..)+ , ClientRandom(..)+ , ClientKeyData(..)+ , serverRandom+ , clientRandom+ , FinishedData+ , Session(..)+ , AlertLevel(..)+ , AlertDescription(..)+ , HandshakeType(..)+ , Handshake(..)+ , numericalVer+ , verOfNum+ , TypeValuable, valOfType, valToType+ , packetType+ , typeOfHandshake+ ) where++import Data.ByteString (ByteString, pack)+import Data.Word+import Data.Certificate.X509++type Bytes = ByteString++data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord)++data ConnectionEnd = ConnectionServer | ConnectionClient+data CipherType = CipherStream | CipherBlock | CipherAEAD++data CipherData = CipherData+ { cipherDataContent :: Bytes+ , cipherDataMAC :: Maybe Bytes+ , cipherDataPadding :: Maybe Bytes+ } deriving (Show,Eq)++data CertificateType =+ CertificateType_RSA_Sign -- TLS10+ | CertificateType_DSS_Sign -- TLS10+ | CertificateType_RSA_Fixed_DH -- TLS10+ | CertificateType_DSS_Fixed_DH -- TLS10+ | CertificateType_RSA_Ephemeral_dh -- TLS12+ | CertificateType_DSS_Ephemeral_dh -- TLS12+ | CertificateType_fortezza_dms -- TLS12+ | CertificateType_Unknown Word8+ deriving (Show,Eq)++data HashAlgorithm =+ HashNone+ | HashMD5+ | HashSHA1+ | HashSHA224+ | HashSHA256+ | HashSHA384+ | HashSHA512+ | HashOther Word8+ deriving (Show,Eq)++data SignatureAlgorithm =+ SignatureAnonymous+ | SignatureRSA+ | SignatureDSS+ | SignatureECDSA+ | SignatureOther Word8+ deriving (Show,Eq)++data ProtocolType =+ ProtocolType_ChangeCipherSpec+ | ProtocolType_Alert+ | ProtocolType_Handshake+ | ProtocolType_AppData+ deriving (Eq, Show)++data TLSError =+ Error_Misc String+ | Error_Certificate String+ | Error_Digest ([Word8], [Word8])+ | Error_Packet String+ | Error_Packet_Size_Mismatch (Int, Int)+ | Error_Internal_Packet_Remaining Int+ | Error_Internal_Packet_ByteProcessed Int Int Int+ | Error_Unknown_Version Word8 Word8+ | Error_Unknown_Type String+ deriving (Eq, Show)++data Packet =+ Handshake Handshake+ | Alert (AlertLevel, AlertDescription)+ | ChangeCipherSpec+ | AppData ByteString+ deriving (Show,Eq)++data Header = Header ProtocolType Version Word16 deriving (Show, Eq)++newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq)+newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq)+newtype ClientKeyData = ClientKeyData Bytes deriving (Show, Eq)+newtype Session = Session (Maybe Bytes) deriving (Show, Eq)+type CipherID = Word16+type CompressionID = Word8+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++serverRandom :: [Word8] -> Maybe ServerRandom+serverRandom l = constrRandom32 ServerRandom l++clientRandom :: [Word8] -> Maybe ClientRandom+clientRandom l = constrRandom32 ClientRandom l++newtype EncryptedData = EncryptedData ByteString+ deriving (Show)++data AlertLevel =+ AlertLevel_Warning+ | AlertLevel_Fatal+ deriving (Show,Eq)++data AlertDescription =+ CloseNotify+ | UnexpectedMessage+ | BadRecordMac+ | DecryptionFailed+ | RecordOverflow+ | DecompressionFailure+ | HandshakeFailure+ | BadCertificate+ | UnsupportedCertificate+ | CertificateRevoked+ | CertificateExpired+ | CertificateUnknown+ | IllegalParameter+ | UnknownCa+ | AccessDenied+ | DecodeError+ | DecryptError+ | ExportRestriction+ | ProtocolVersion+ | InsufficientSecurity+ | InternalError+ | UserCanceled+ | NoRenegotiation+ deriving (Show,Eq)++data HandshakeType =+ HandshakeType_HelloRequest+ | HandshakeType_ClientHello+ | HandshakeType_ServerHello+ | HandshakeType_Certificate+ | HandshakeType_ServerKeyXchg+ | HandshakeType_CertRequest+ | HandshakeType_ServerHelloDone+ | HandshakeType_CertVerify+ | HandshakeType_ClientKeyXchg+ | HandshakeType_Finished+ deriving (Show,Eq)++data ServerDHParams = ServerDHParams+ { dh_p :: Integer -- ^ prime modulus+ , dh_g :: Integer -- ^ generator+ , dh_Ys :: Integer -- ^ public value (g^X mod p)+ } deriving (Show,Eq)++data ServerRSAParams = ServerRSAParams+ { rsa_modulus :: Integer+ , rsa_exponent :: Integer+ } deriving (Show,Eq)++data ServerKeyXchgAlgorithmData =+ SKX_DH_Anon ServerDHParams+ | SKX_DHE_DSS ServerDHParams [Word8]+ | SKX_DHE_RSA ServerDHParams [Word8]+ | SKX_RSA (Maybe ServerRSAParams)+ | SKX_DH_DSS (Maybe ServerRSAParams)+ | SKX_DH_RSA (Maybe ServerRSAParams)+ deriving (Show,Eq)++data Handshake =+ ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] (Maybe [Extension])+ | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID (Maybe [Extension])+ | Certificates [Certificate]+ | HelloRequest+ | ServerHelloDone+ | ClientKeyXchg Version ClientKeyData+ | ServerKeyXchg ServerKeyXchgAlgorithmData+ | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8]+ | CertVerify [Word8]+ | Finished FinishedData+ deriving (Show,Eq)++packetType :: Packet -> ProtocolType+packetType (Handshake _) = ProtocolType_Handshake+packetType (Alert _) = ProtocolType_Alert+packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec+packetType (AppData _) = ProtocolType_AppData++typeOfHandshake :: Handshake -> HandshakeType+typeOfHandshake (ClientHello _ _ _ _ _ _) = HandshakeType_ClientHello+typeOfHandshake (ServerHello _ _ _ _ _ _) = HandshakeType_ServerHello+typeOfHandshake (Certificates _) = HandshakeType_Certificate+typeOfHandshake (HelloRequest) = HandshakeType_HelloRequest+typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone+typeOfHandshake (ClientKeyXchg _ _) = HandshakeType_ClientKeyXchg+typeOfHandshake (ServerKeyXchg _) = HandshakeType_ServerKeyXchg+typeOfHandshake (CertRequest _ _ _) = HandshakeType_CertRequest+typeOfHandshake (CertVerify _) = HandshakeType_CertVerify+typeOfHandshake (Finished _) = HandshakeType_Finished++numericalVer :: Version -> (Word8, Word8)+numericalVer SSL2 = (2, 0)+numericalVer SSL3 = (3, 0)+numericalVer TLS10 = (3, 1)+numericalVer TLS11 = (3, 2)+numericalVer TLS12 = (3, 3)++verOfNum :: (Word8, Word8) -> Maybe Version+verOfNum (2, 0) = Just SSL2+verOfNum (3, 0) = Just SSL3+verOfNum (3, 1) = Just TLS10+verOfNum (3, 2) = Just TLS11+verOfNum (3, 3) = Just TLS12+verOfNum _ = Nothing++class TypeValuable a where+ valOfType :: a -> Word8+ valToType :: Word8 -> Maybe a++instance TypeValuable ConnectionEnd where+ valOfType ConnectionServer = 0+ valOfType ConnectionClient = 1++ valToType 0 = Just ConnectionServer+ valToType 1 = Just ConnectionClient+ valToType _ = Nothing++instance TypeValuable CipherType where+ valOfType CipherStream = 0+ valOfType CipherBlock = 1+ valOfType CipherAEAD = 2++ valToType 0 = Just CipherStream+ valToType 1 = Just CipherBlock+ valToType 2 = Just CipherAEAD+ valToType _ = Nothing++instance TypeValuable ProtocolType where+ valOfType ProtocolType_ChangeCipherSpec = 20+ valOfType ProtocolType_Alert = 21+ valOfType ProtocolType_Handshake = 22+ valOfType ProtocolType_AppData = 23++ valToType 20 = Just ProtocolType_ChangeCipherSpec+ valToType 21 = Just ProtocolType_Alert+ valToType 22 = Just ProtocolType_Handshake+ valToType 23 = Just ProtocolType_AppData+ valToType _ = Nothing++instance TypeValuable HandshakeType where+ valOfType HandshakeType_HelloRequest = 0+ valOfType HandshakeType_ClientHello = 1+ valOfType HandshakeType_ServerHello = 2+ valOfType HandshakeType_Certificate = 11+ valOfType HandshakeType_ServerKeyXchg = 12+ valOfType HandshakeType_CertRequest = 13+ valOfType HandshakeType_ServerHelloDone = 14+ valOfType HandshakeType_CertVerify = 15+ valOfType HandshakeType_ClientKeyXchg = 16+ valOfType HandshakeType_Finished = 20++ valToType 0 = Just HandshakeType_HelloRequest+ valToType 1 = Just HandshakeType_ClientHello+ valToType 2 = Just HandshakeType_ServerHello+ valToType 11 = Just HandshakeType_Certificate+ valToType 12 = Just HandshakeType_ServerKeyXchg+ valToType 13 = Just HandshakeType_CertRequest+ valToType 14 = Just HandshakeType_ServerHelloDone+ valToType 15 = Just HandshakeType_CertVerify+ valToType 16 = Just HandshakeType_ClientKeyXchg+ valToType 20 = Just HandshakeType_Finished+ valToType _ = Nothing++instance TypeValuable AlertLevel where+ valOfType AlertLevel_Warning = 1+ valOfType AlertLevel_Fatal = 2++ valToType 1 = Just AlertLevel_Warning+ valToType 2 = Just AlertLevel_Fatal+ valToType _ = Nothing++instance TypeValuable AlertDescription where+ valOfType CloseNotify = 0+ valOfType UnexpectedMessage = 10+ valOfType BadRecordMac = 20+ valOfType DecryptionFailed = 21+ valOfType RecordOverflow = 22+ valOfType DecompressionFailure = 30+ valOfType HandshakeFailure = 40+ valOfType BadCertificate = 42+ valOfType UnsupportedCertificate = 43+ valOfType CertificateRevoked = 44+ valOfType CertificateExpired = 45+ valOfType CertificateUnknown = 46+ valOfType IllegalParameter = 47+ valOfType UnknownCa = 48+ valOfType AccessDenied = 49+ valOfType DecodeError = 50+ valOfType DecryptError = 51+ valOfType ExportRestriction = 60+ valOfType ProtocolVersion = 70+ valOfType InsufficientSecurity = 71+ valOfType InternalError = 80+ valOfType UserCanceled = 90+ valOfType NoRenegotiation = 100++ valToType 0 = Just CloseNotify+ valToType 10 = Just UnexpectedMessage+ valToType 20 = Just BadRecordMac+ valToType 21 = Just DecryptionFailed+ valToType 22 = Just RecordOverflow+ valToType 30 = Just DecompressionFailure+ valToType 40 = Just HandshakeFailure+ valToType 42 = Just BadCertificate+ valToType 43 = Just UnsupportedCertificate+ valToType 44 = Just CertificateRevoked+ valToType 45 = Just CertificateExpired+ valToType 46 = Just CertificateUnknown+ valToType 47 = Just IllegalParameter+ valToType 48 = Just UnknownCa+ valToType 49 = Just AccessDenied+ valToType 50 = Just DecodeError+ valToType 51 = Just DecryptError+ valToType 60 = Just ExportRestriction+ valToType 70 = Just ProtocolVersion+ valToType 71 = Just InsufficientSecurity+ valToType 80 = Just InternalError+ valToType 90 = Just UserCanceled+ valToType 100 = Just NoRenegotiation+ valToType _ = Nothing++instance TypeValuable CertificateType where+ valOfType CertificateType_RSA_Sign = 1+ valOfType CertificateType_DSS_Sign = 2+ valOfType CertificateType_RSA_Fixed_DH = 3+ valOfType CertificateType_DSS_Fixed_DH = 4+ valOfType CertificateType_RSA_Ephemeral_dh = 5+ valOfType CertificateType_DSS_Ephemeral_dh = 6+ valOfType CertificateType_fortezza_dms = 20+ valOfType (CertificateType_Unknown i) = i++ valToType 1 = Just CertificateType_RSA_Sign+ valToType 2 = Just CertificateType_DSS_Sign+ valToType 3 = Just CertificateType_RSA_Fixed_DH+ valToType 4 = Just CertificateType_DSS_Fixed_DH+ valToType 5 = Just CertificateType_RSA_Ephemeral_dh+ valToType 6 = Just CertificateType_DSS_Ephemeral_dh+ valToType 20 = Just CertificateType_fortezza_dms+ valToType i = Just (CertificateType_Unknown i)++instance TypeValuable HashAlgorithm where+ valOfType HashNone = 0+ valOfType HashMD5 = 1+ valOfType HashSHA1 = 2+ valOfType HashSHA224 = 3+ valOfType HashSHA256 = 4+ valOfType HashSHA384 = 5+ valOfType HashSHA512 = 6+ valOfType (HashOther i) = i++ valToType 0 = Just HashNone+ valToType 1 = Just HashMD5+ valToType 2 = Just HashSHA1+ valToType 3 = Just HashSHA224+ valToType 4 = Just HashSHA256+ valToType 5 = Just HashSHA384+ valToType 6 = Just HashSHA512+ valToType i = Just (HashOther i)++instance TypeValuable SignatureAlgorithm where+ valOfType SignatureAnonymous = 0+ valOfType SignatureRSA = 1+ valOfType SignatureDSS = 2+ valOfType SignatureECDSA = 3+ valOfType (SignatureOther i) = i++ valToType 0 = Just SignatureAnonymous+ valToType 1 = Just SignatureRSA+ valToType 2 = Just SignatureDSS+ valToType 3 = Just SignatureECDSA+ valToType i = Just (SignatureOther i)
+ Network/TLS/Util.hs view
@@ -0,0 +1,37 @@+module Network.TLS.Util+ ( sub+ , takelast+ , partition3+ , partition6+ ) where++import Network.TLS.Struct (Bytes)+import Network.TLS.Wire+import qualified Data.ByteString as B++sub :: Bytes -> Int -> Int -> Maybe Bytes+sub b offset len+ | B.length b < offset + len = Nothing+ | otherwise = Just $ B.take len $ snd $ B.splitAt offset b++takelast :: Int -> Bytes -> Maybe Bytes+takelast i b+ | B.length b >= i = sub b (B.length b - i) i+ | otherwise = Nothing++partition3 :: Bytes -> (Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes)+partition3 bytes (d1,d2,d3) = either (const Nothing) Just $ (flip runGet) bytes $ do+ p1 <- getBytes d1+ p2 <- getBytes d2+ p3 <- getBytes d3+ return (p1,p2,p3)++partition6 :: Bytes -> (Int,Int,Int,Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes, Bytes)+partition6 bytes (d1,d2,d3,d4,d5,d6) = either (const Nothing) Just $ (flip runGet) bytes $ do+ p1 <- getBytes d1+ p2 <- getBytes d2+ p3 <- getBytes d3+ p4 <- getBytes d4+ p5 <- getBytes d5+ p6 <- getBytes d6+ return (p1,p2,p3,p4,p5,p6)
+ Network/TLS/Wire.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,FlexibleInstances #-}++-- |+-- Module : Network.TLS.Wire+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Wire module is a specialized Binary package related to the TLS protocol.+-- all multibytes values are written as big endian.+--+module Network.TLS.Wire+ ( Get+ , runGet+ , remaining+ , bytesRead+ , getWord8+ , getWords8+ , getWord16+ , getWords16+ , getWord24+ , getBytes+ , processBytes+ , isEmpty+ , Put+ , runPut+ , putWord8+ , putWords8+ , putWord16+ , putWords16+ , putWord24+ , putBytes+ , encodeWord64+ ) where++import qualified Data.Binary.Get as G+import qualified Data.Binary.Put as P+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Control.Applicative ((<$>))+import Control.Monad.Error+import Data.Word+import Data.Bits+import Network.TLS.Struct++instance Error TLSError where+ noMsg = Error_Misc ""+ strMsg = Error_Misc++newtype Get a = GE { runGE :: ErrorT TLSError G.Get a }+ deriving (Monad, MonadError TLSError)++instance Functor Get where+ fmap f = GE . fmap f . runGE++liftGet :: G.Get a -> Get a+liftGet = GE . lift++runGet :: Get a -> Bytes -> Either TLSError a+runGet f b = G.runGet (runErrorT (runGE f)) (L.fromChunks [b])++remaining :: Get Int+remaining = fromIntegral <$> liftGet G.remaining++bytesRead :: Get Int+bytesRead = fromIntegral <$> liftGet G.bytesRead++getWord8 :: Get Word8+getWord8 = liftGet G.getWord8++getWords8 :: Get [Word8]+getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8++getWord16 :: Get Word16+getWord16 = liftGet G.getWord16be++getWords16 :: Get [Word16]+getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16++getWord24 :: Get Int+getWord24 = do+ a <- fromIntegral <$> getWord8+ b <- fromIntegral <$> getWord8+ c <- fromIntegral <$> getWord8+ return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c++getBytes :: Int -> Get Bytes+getBytes i = liftGet $ G.getBytes i++processBytes :: Int -> Get a -> Get a+processBytes i f = do+ r1 <- bytesRead+ ret <- f+ r2 <- bytesRead+ if r2 == (r1 + i)+ then return ret+ else throwError (Error_Internal_Packet_ByteProcessed r1 r2 i)+ +isEmpty :: Get Bool+isEmpty = liftGet G.isEmpty++type Put = P.Put++putWord8 :: Word8 -> Put+putWord8 = P.putWord8++putWords8 :: [Word8] -> Put+putWords8 l = do+ P.putWord8 $ fromIntegral (length l)+ mapM_ P.putWord8 l++putWord16 :: Word16 -> Put+putWord16 = P.putWord16be++putWords16 :: [Word16] -> Put+putWords16 l = do+ putWord16 $ 2 * (fromIntegral $ length l)+ mapM_ putWord16 l++putWord24 :: Int -> Put+putWord24 i = do+ let a = fromIntegral ((i `shiftR` 16) .&. 0xff)+ let b = fromIntegral ((i `shiftR` 8) .&. 0xff)+ let c = fromIntegral (i .&. 0xff)+ mapM_ P.putWord8 [a,b,c]++putBytes :: Bytes -> Put+putBytes = P.putByteString++lazyToBytes :: L.ByteString -> Bytes+lazyToBytes = B.concat . L.toChunks++runPut :: Put -> Bytes+runPut = lazyToBytes . P.runPut++encodeWord64 :: Word64 -> Bytes+encodeWord64 = runPut . P.putWord64be
http-enumerator.cabal view
@@ -1,5 +1,5 @@ name: http-enumerator-version: 0.1.0+version: 0.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -7,7 +7,7 @@ synopsis: HTTP client package with enumerator interface and HTTPS support. description: This package uses attoparsec for parsing the actual contents of the HTTP connection. The only gotcha is the withHttpEnumerator function, otherwise should do exactly what you expect.-category: Web+category: Web, Enumerator stability: Experimental cabal-version: >= 1.6 build-type: Simple@@ -31,15 +31,37 @@ , attoparsec >= 0.8.0.2 && < 0.9 , attoparsec-enumerator >= 0.2 && < 0.3 , utf8-string >= 0.3.4 && < 0.4+ , blaze-builder >= 0.1 && < 0.2 if flag(openssl) build-depends: HsOpenSSL >= 0.8 && < 0.9 cpp-options: -DOPENSSL else- build-depends: tls >= 0.1.2 && < 0.2+ build-depends: AES >= 0.2.7 && < 0.3+ , RSA >= 1.0.5 && < 1.1+ , certificate >= 0.2.1 && < 0.3+ , cryptocipher >= 0.1 && < 0.2+ , cryptohash >= 0.5.2 && < 0.6+ , random >= 1.0 && < 1.1+ , vector >= 0.6 && < 0.7+ , spoon >= 0.3 && < 0.4 , mtl >= 1.1 && < 1.2- , AES >= 0.2.7 && < 0.3+ , binary >= 0.5.0.2 && < 0.6 exposed-modules: Network.HTTP.Enumerator other-modules: Network.HTTP.Enumerator.HttpParser+ if ! flag(openssl)+ other-modules: Network.TLS.Client+ Network.TLS.SRandom+ Network.TLS.Cipher+ Network.TLS.Struct+ Network.TLS.Receiving+ Network.TLS.Sending+ Network.TLS.State+ Network.TLS.Packet+ Network.TLS.MAC+ Network.TLS.Crypto+ Network.TLS.Cap+ Network.TLS.Util+ Network.TLS.Wire ghc-options: -Wall executable http-enumerator
test.hs view
@@ -12,7 +12,11 @@ main = withSocketsDo $ withHttpEnumerator $ do [url] <- getArgs _req2 <- parseUrl url- Response sc hs b <- httpLbsRedirect _req2+ let req = urlEncodedBody+ [ ("foo", "bar")+ , ("baz%%38**.8fn", "bin")+ ] _req2+ Response sc hs b <- httpLbsRedirect req #if DEBUG return () #else