diff --git a/Network/HTTP/Enumerator.hs b/Network/HTTP/Enumerator.hs --- a/Network/HTTP/Enumerator.hs +++ b/Network/HTTP/Enumerator.hs @@ -52,7 +52,6 @@ -- * Request bodies , urlEncodedBody -- * Exceptions - , InvalidUrlException (..) , HttpException (..) ) where @@ -61,7 +60,7 @@ import qualified OpenSSL.Session as SSL #else import System.IO (hClose, hSetBuffering, BufferMode (NoBuffering)) -import qualified Network.TLS.Client as TLS +import qualified Network.TLS.Client.Enumerator as TLS import Network (connectTo, PortID (PortNumber)) #endif @@ -73,6 +72,7 @@ import Data.Enumerator hiding (head, map, break) import qualified Data.Enumerator as E import Network.HTTP.Enumerator.HttpParser +import Network.HTTP.Enumerator.Zlib (ungzip) import Control.Exception (throwIO, Exception) import Control.Arrow (first) import Data.Char (toLower) @@ -226,6 +226,7 @@ let headers' = ("Host", hh) : ("Content-Length", S8.pack $ show $ L.length requestBody) + : ("Accept-Encoding", "gzip") : requestHeaders let request = Blaze.toLazyByteString $ mconcat [ Blaze.fromByteString method @@ -248,27 +249,31 @@ ] Right () <- run $ enumList 1 (L.toChunks request) $$ iter run $ enum $$ do - ((_, sc, _), hs) <- iterHeaders + ((_, sc, _), hs) <- catchParser "HTTP headers" iterHeaders let hs' = map (first $ S8.map toLower) hs let mcl = lookup "content-length" hs' - let body' = + let body' x = if ("transfer-encoding", "chunked") `elem` hs' - then iterChunks' + then joinI $ chunkedEnumeratee $$ x else case mcl >>= readMay . S8.unpack of - Just len -> takeLBS len - Nothing -> E.map id - joinI $ body' $$ bodyIter sc hs + Just len -> joinI $ takeLBS len $$ x + Nothing -> x + let decompress x = + if ("content-encoding", "gzip") `elem` hs' + then joinI $ ungzip $$ x + else x + body' $ decompress $ bodyIter sc hs -iterChunks' :: MonadIO m => Enumeratee S.ByteString S.ByteString m a -iterChunks' k@(Continue _) = do - len <- iterChunkHeader +chunkedEnumeratee :: MonadIO m => Enumeratee S.ByteString S.ByteString m a +chunkedEnumeratee k@(Continue _) = do + len <- catchParser "Chunk header" iterChunkHeader if len == 0 then return k else do k' <- takeLBS len k - iterNewline - iterChunks' k' -iterChunks' step = return step + catchParser "End of chunk newline" iterNewline + chunkedEnumeratee k' +chunkedEnumeratee step = return step takeLBS :: MonadIO m => Int -> Enumeratee S.ByteString S.ByteString m a takeLBS 0 step = return step @@ -329,14 +334,6 @@ | otherwise = error $ "Invalid argument to showHex: " ++ show x in ['%', showHex' b, showHex' c] --- | Thrown by 'parseUrl' when a URL could not be parsed correctly. --- --- 'httpRedirect' also uses the 'parseUrl' function to read the location header --- from a server, so it can also throw this exception. -data InvalidUrlException = InvalidUrlException String String - deriving (Show, Typeable) -instance Exception InvalidUrlException - -- | Convert a URL into a 'Request'. -- -- This defaults some of the values in 'Request', such as setting 'method' to @@ -344,19 +341,19 @@ -- -- Since this function uses 'Failure', the return monad can be anything that is -- an instance of 'Failure', such as 'IO' or 'Maybe'. -parseUrl :: Failure InvalidUrlException m => String -> m Request +parseUrl :: Failure HttpException m => String -> m Request parseUrl s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest parseUrl s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest parseUrl x = failure $ InvalidUrlException x "Invalid scheme" -parseUrl1 :: Failure InvalidUrlException m +parseUrl1 :: Failure HttpException m => String -> Bool -> String -> m Request parseUrl1 full sec s = parseUrl2 full sec s' where s' = encodeString s -parseUrl2 :: Failure InvalidUrlException m +parseUrl2 :: Failure HttpException m => String -> Bool -> String -> m Request parseUrl2 full sec s = do port' <- mport @@ -466,32 +463,32 @@ -- 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 :: (MonadIO m, Failure HttpException m, - Failure InvalidUrlException m) - => String -> m L.ByteString +simpleHttp :: (MonadIO m, Failure HttpException m) => String -> m L.ByteString simpleHttp url = do url' <- parseUrl url Response sc _ b <- httpLbsRedirect url' if 200 <= sc && sc < 300 then return b - else failure $ HttpException sc b + else failure $ StatusCodeException sc b --- | Throw by 'simpleHttp' when a response does not have a 2xx status code. -data HttpException = HttpException Int L.ByteString +data HttpException = StatusCodeException Int L.ByteString + | InvalidUrlException String String + | TooManyRedirects + | HttpParserException String deriving (Show, Typeable) instance Exception HttpException -- | Same as 'http', but follows all 3xx redirect status codes that contain a -- location header. httpRedirect - :: (MonadIO m, Failure InvalidUrlException m) + :: (MonadIO m, Failure HttpException m) => (Int -> Headers -> Iteratee S.ByteString m a) -> Request -> m a httpRedirect iter req = - http iter' req + http (iter' (10 :: Int)) req where - iter' code hs + iter' redirects code hs | 300 <= code && code < 400 = case lookup "location" $ map (first $ S8.map toLower) hs of Just l'' -> lift $ do @@ -516,7 +513,9 @@ , path = path l , queryString = queryString l } - httpRedirect iter req' + if redirects == 0 + then failure TooManyRedirects + else http (iter' $ redirects - 1) req' Nothing -> iter code hs | otherwise = iter code hs @@ -532,9 +531,7 @@ -- -- Please see 'lbsIter' for more information on how the 'Response' value is -- created. -httpLbsRedirect :: (MonadIO m, Failure InvalidUrlException m, - Failure HttpException m) - => Request -> m Response +httpLbsRedirect :: (MonadIO m, Failure HttpException m) => Request -> m Response httpLbsRedirect = httpRedirect lbsIter readMay :: Read a => String -> Maybe a @@ -584,3 +581,6 @@ | c < 10 = Blaze.writeByte $ c + 48 | c < 16 = Blaze.writeByte $ c + 55 | otherwise = error $ "hexChar: " ++ show c + +catchParser :: Monad m => String -> Iteratee a m b -> Iteratee a m b +catchParser s i = catchError i (const $ throwError $ HttpParserException s) diff --git a/Network/HTTP/Enumerator/Zlib.hs b/Network/HTTP/Enumerator/Zlib.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Enumerator/Zlib.hs @@ -0,0 +1,34 @@ +module Network.HTTP.Enumerator.Zlib + ( ungzip + ) where + +import Prelude hiding (head) +import Data.Enumerator +import qualified Data.ByteString as S +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) +import Codec.Zlib + +ungzip :: MonadIO m => Enumeratee S.ByteString S.ByteString m b +ungzip inner = do + fzstr <- liftIO $ initInflate $ WindowBits 31 + ungzip' fzstr inner + +ungzip' :: MonadIO m => Inflate -> Enumeratee S.ByteString S.ByteString m b +ungzip' fzstr (Continue k) = do + x <- head + case x of + Nothing -> do + chunk <- liftIO $ finishInflate fzstr + lift $ runIteratee $ k $ Chunks [chunk] + Just bs -> do + chunks <- liftIO $ withInflateInput fzstr bs $ go id + step <- lift $ runIteratee $ k $ Chunks chunks + ungzip' fzstr step + where + go front pop = do + x <- pop + case x of + Nothing -> return $ front [] + Just y -> go (front . (:) y) pop +ungzip' _ step = return step diff --git a/Network/TLS/Cap.hs b/Network/TLS/Cap.hs deleted file mode 100644 --- a/Network/TLS/Cap.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | --- 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 deleted file mode 100644 --- a/Network/TLS/Cipher.hs +++ /dev/null @@ -1,271 +0,0 @@ --- | --- 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 deleted file mode 100644 --- a/Network/TLS/Client.hs +++ /dev/null @@ -1,308 +0,0 @@ -{-# 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/Client/Enumerator.hs b/Network/TLS/Client/Enumerator.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Client/Enumerator.hs @@ -0,0 +1,86 @@ +module Network.TLS.Client.Enumerator + ( clientEnumSimple + , clientEnum + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Enumerator as E +import qualified Control.Monad.IO.Class as Trans + +import Network.TLS.Client +import Network.TLS.SRandom +import Network.TLS.Struct +import Network.TLS.Cipher + +import Control.Monad.State (runStateT) + +import Data.IORef +import System.IO (Handle) + +type IState = IORef TLSStateClient + +newIState :: TLSClientParams -> SRandomGen -> IO IState +newIState params rng = do + ((), tsc) <- runTLSClient (return ()) params rng + newIORef tsc + +clientEnumSimple + :: Trans.MonadIO m + => Handle + -> (E.Iteratee B.ByteString m () -> E.Enumerator B.ByteString m a -> m b) + -> m b +clientEnumSimple h f = do + let clientstate = TLSClientParams + { cpConnectVersion = TLS10 + , cpAllowedVersions = [ TLS10, TLS11 ] + , cpSession = Nothing + , cpCiphers = ciphers + , cpCertificate = Nothing + , cpCallbacks = TLSClientCallbacks + { cbCertificates = Nothing + } + } + srand <- Trans.liftIO makeSRandomGen + clientEnum clientstate srand h f + where + ciphers = + [ cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + ] + +clientEnum :: Trans.MonadIO m + => TLSClientParams -> SRandomGen -> Handle + -> (E.Iteratee B.ByteString m () -> E.Enumerator B.ByteString m a -> m b) + -> m b +clientEnum tcp srg h f = do + istate <- Trans.liftIO $ newIState tcp srg + tlsHelper istate $ connect h + b <- f (iter istate) (enum istate) + tlsHelper istate $ close 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 + tlsHelper istate $ sendData h $ L.fromChunks xs + E.continue go + enum :: Trans.MonadIO m => IState -> E.Enumerator B.ByteString m a + enum istate (E.Continue k) = E.Iteratee $ do + lbs <- tlsHelper istate $ recvData h + let chunks = E.Chunks $ L.toChunks lbs + step <- E.runIteratee $ k chunks + E.runIteratee $ enum istate step + enum _ step = E.returnI step + +tlsHelper :: Trans.MonadIO m => IState -> TLSClient IO a -> m a +tlsHelper istate (TLSClient client) = do + state <- Trans.liftIO $ readIORef istate + (ret, state') <- Trans.liftIO $ runStateT client state + Trans.liftIO $ writeIORef istate state' + return ret diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs deleted file mode 100644 --- a/Network/TLS/Crypto.hs +++ /dev/null @@ -1,110 +0,0 @@ -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 deleted file mode 100644 --- a/Network/TLS/MAC.hs +++ /dev/null @@ -1,59 +0,0 @@ -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 deleted file mode 100644 --- a/Network/TLS/Packet.hs +++ /dev/null @@ -1,435 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Network/TLS/Receiving.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Network/TLS/SRandom.hs +++ /dev/null @@ -1,30 +0,0 @@ --- 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 deleted file mode 100644 --- a/Network/TLS/Sending.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Network/TLS/State.hs +++ /dev/null @@ -1,267 +0,0 @@ --- | --- 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 deleted file mode 100644 --- a/Network/TLS/Struct.hs +++ /dev/null @@ -1,417 +0,0 @@ --- | --- 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 deleted file mode 100644 --- a/Network/TLS/Util.hs +++ /dev/null @@ -1,37 +0,0 @@ -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 deleted file mode 100644 --- a/Network/TLS/Wire.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# 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/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain 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.1 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -25,43 +25,25 @@ , bytestring >= 0.9.1.4 && < 0.10 , transformers >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 - , enumerator >= 0.4 && < 0.5 + , enumerator >= 0.4.1 && < 0.5 , network >= 2.2.1 && < 2.3 , network-bytestring >= 0.1.3 && < 0.2 , 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 + , zlib-bindings >= 0.0.0 && < 0.1 if flag(openssl) build-depends: HsOpenSSL >= 0.8 && < 0.9 cpp-options: -DOPENSSL else - 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 + build-depends: tls >= 0.2 && < 0.3 , mtl >= 1.1 && < 1.2 - , binary >= 0.5.0.2 && < 0.6 exposed-modules: Network.HTTP.Enumerator other-modules: Network.HTTP.Enumerator.HttpParser + Network.HTTP.Enumerator.Zlib 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 + other-modules: Network.TLS.Client.Enumerator ghc-options: -Wall executable http-enumerator