diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -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 diff --git a/Network/HTTP/Enumerator/HttpParser.hs b/Network/HTTP/Enumerator/HttpParser.hs --- a/Network/HTTP/Enumerator/HttpParser.hs +++ b/Network/HTTP/Enumerator/HttpParser.hs @@ -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 diff --git a/Network/TLS/Cap.hs b/Network/TLS/Cap.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Cap.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Network.TLS.Cap +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Cipher.hs @@ -0,0 +1,271 @@ +-- | +-- Module : Network.TLS.Cipher +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 + } diff --git a/Network/TLS/Client.hs b/Network/TLS/Client.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Client.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +-- | +-- Module : Network.TLS.Client +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Crypto.hs @@ -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 ] diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/MAC.hs @@ -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 diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Packet.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.TLS.Packet +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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") diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Receiving.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} + +-- | +-- Module : Network.TLS.Receiving +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 () diff --git a/Network/TLS/SRandom.hs b/Network/TLS/SRandom.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/SRandom.hs @@ -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) diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Sending.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Network.TLS.Sending +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/State.hs @@ -0,0 +1,267 @@ +-- | +-- Module : Network.TLS.State +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 }) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Struct.hs @@ -0,0 +1,417 @@ +-- | +-- Module : Network.TLS.Struct +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Util.hs @@ -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) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Wire.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving,FlexibleInstances #-} + +-- | +-- Module : Network.TLS.Wire +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/http-enumerator.cabal b/http-enumerator.cabal --- a/http-enumerator.cabal +++ b/http-enumerator.cabal @@ -1,5 +1,5 @@ name: http-enumerator -version: 0.1.0 +version: 0.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -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