http-enumerator 0.1.1 → 0.2.0

raw patch · 19 files changed

+172/−2552 lines, 19 filesdep +tlsdep +zlib-bindingsdep −AESdep −RSAdep −binarydep ~enumeratorsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: tls, zlib-bindings

Dependencies removed: AES, RSA, binary, certificate, cryptocipher, cryptohash, random, spoon, vector

Dependency ranges changed: enumerator

API changes (from Hackage documentation)

Files

• Network/HTTP/Enumerator.hs +38/−38
• Network/HTTP/Enumerator/Zlib.hs +34/−0
• Network/TLS/Cap.hs +0/−19
• Network/TLS/Cipher.hs +0/−271
• Network/TLS/Client.hs +0/−308
• Network/TLS/Client/Enumerator.hs +86/−0
• Network/TLS/Crypto.hs +0/−110
• Network/TLS/MAC.hs +0/−59
• Network/TLS/Packet.hs +0/−435
• Network/TLS/Receiving.hs +0/−218
• Network/TLS/SRandom.hs +0/−30
• Network/TLS/Sending.hs +0/−179
• Network/TLS/State.hs +0/−267
• Network/TLS/Struct.hs +0/−417
• Network/TLS/Util.hs +0/−37
• Network/TLS/Wire.hs +0/−138
• Setup.hs +0/−2
• Setup.lhs +8/−0
• http-enumerator.cabal +6/−24

@@ -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)

@@ -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

@@ -1,19 +0,0 @@--- |--- Module      : Network.TLS.Cap--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown-----module Network.TLS.Cap-	( hasHelloExtensions-	, hasExplicitBlockIV-	) where--import Network.TLS.Struct--hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool--hasHelloExtensions ver = ver >= TLS12-hasExplicitBlockIV ver = ver >= TLS11

@@ -1,271 +0,0 @@--- |--- Module      : Network.TLS.Cipher--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown----module Network.TLS.Cipher-	( CipherTypeFunctions(..)-	, CipherKeyExchangeType(..)-	, Cipher(..)-	, cipherExchangeNeedMoreData--	-- * builtin ciphers for ease of use, might move later to a tls-ciphers library-	, cipher_null_null-	, cipher_RC4_128_MD5-	, cipher_RC4_128_SHA1-	, cipher_AES128_SHA1-	, cipher_AES256_SHA1-	, cipher_AES128_SHA256-	, cipher_AES256_SHA256-	) where--import Data.Word-import Network.TLS.Struct (Version(..))-import Network.TLS.MAC-import qualified Data.Vector.Unboxed as Vector (fromList, toList)-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as B--import qualified Codec.Crypto.AES as AES-import qualified Crypto.Cipher.RC4 as RC4---- FIXME convert to newtype-type Key = B.ByteString-type IV = B.ByteString--data CipherTypeFunctions =-	  CipherNoneF -- special value for 0-	| CipherBlockF (Key -> IV -> B.ByteString -> B.ByteString)-	               (Key -> IV -> B.ByteString -> B.ByteString)-	| CipherStreamF (Key -> IV)-	                (IV -> B.ByteString -> (B.ByteString, IV))-	                (IV -> B.ByteString -> (B.ByteString, IV))--data CipherKeyExchangeType =-	  CipherKeyExchangeRSA-	| CipherKeyExchangeDHE_RSA-	| CipherKeyExchangeECDHE_RSA-	| CipherKeyExchangeDHE_DSS-	| CipherKeyExchangeDH_DSS-	| CipherKeyExchangeDH_RSA-	| CipherKeyExchangeECDH_ECDSA-	| CipherKeyExchangeECDH_RSA-	| CipherKeyExchangeECDHE_ECDSA--data Cipher = Cipher-	{ cipherID           :: Word16-	, cipherName         :: String-	, cipherDigestSize   :: Word8-	, cipherKeySize      :: Word8-	, cipherIVSize       :: Word8-	, cipherKeyBlockSize :: Word8-	, cipherPaddingSize  :: Word8-	, cipherKeyExchange  :: CipherKeyExchangeType-	, cipherHMAC         :: B.ByteString -> B.ByteString -> B.ByteString-	, cipherF            :: CipherTypeFunctions-	, cipherMinVer       :: Maybe Version-	}--instance Show Cipher where-	show c = cipherName c--cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool-cipherExchangeNeedMoreData CipherKeyExchangeRSA         = False-cipherExchangeNeedMoreData CipherKeyExchangeDHE_RSA     = True-cipherExchangeNeedMoreData CipherKeyExchangeECDHE_RSA   = True-cipherExchangeNeedMoreData CipherKeyExchangeDHE_DSS     = True-cipherExchangeNeedMoreData CipherKeyExchangeDH_DSS      = False-cipherExchangeNeedMoreData CipherKeyExchangeDH_RSA      = False-cipherExchangeNeedMoreData CipherKeyExchangeECDH_ECDSA  = True-cipherExchangeNeedMoreData CipherKeyExchangeECDH_RSA    = True-cipherExchangeNeedMoreData CipherKeyExchangeECDHE_ECDSA = True--repack :: Int -> B.ByteString -> [B.ByteString]-repack bs x =-	if B.length x > bs-		then-			let (c1, c2) = B.splitAt bs x in-			B.pack (B.unpack c1) : repack 16 c2-		else-			[ x ]--lazyToStrict :: L.ByteString -> B.ByteString-lazyToStrict = B.concat . L.toChunks--aes128_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes128_cbc_encrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Encrypt d16-	where d16 = L.fromChunks $ repack 16 d--aes128_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes128_cbc_decrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Decrypt d16-	where d16 = L.fromChunks $ repack 16 d--aes256_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes256_cbc_encrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Encrypt d16-	where d16 = L.fromChunks $ repack 16 d--aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString-aes256_cbc_decrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Decrypt d16-	where d16 = L.fromChunks $ repack 32 d--toIV :: RC4.Ctx -> IV-toIV (v, x, y) = B.pack (x : y : Vector.toList v)--toCtx :: IV -> RC4.Ctx-toCtx iv =-	case B.unpack iv of-		x:y:l -> (Vector.fromList l, x, y)-		_     -> (Vector.fromList [], 0, 0)--initF_rc4 :: Key -> IV-initF_rc4 key     = toIV $ RC4.initCtx (B.unpack key)--encryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)-encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encrypt (toCtx iv) d--decryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)-decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.decrypt (toCtx iv) e--{--TLS 1.0 ciphers definition--CipherSuite TLS_NULL_WITH_NULL_NULL               = { 0x00,0x00 };-CipherSuite TLS_RSA_WITH_NULL_MD5                 = { 0x00,0x01 };-CipherSuite TLS_RSA_WITH_NULL_SHA                 = { 0x00,0x02 };-CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5        = { 0x00,0x03 };-CipherSuite TLS_RSA_WITH_RC4_128_MD5              = { 0x00,0x04 };-CipherSuite TLS_RSA_WITH_RC4_128_SHA              = { 0x00,0x05 };-CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5    = { 0x00,0x06 };-CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA             = { 0x00,0x07 };-CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA     = { 0x00,0x08 };-CipherSuite TLS_RSA_WITH_DES_CBC_SHA              = { 0x00,0x09 };-CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA         = { 0x00,0x0A };-CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA  = { 0x00,0x0B };-CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA           = { 0x00,0x0C };-CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA      = { 0x00,0x0D };-CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA  = { 0x00,0x0E };-CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA           = { 0x00,0x0F };-CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA      = { 0x00,0x10 };-CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 };-CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA          = { 0x00,0x12 };-CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA     = { 0x00,0x13 };-CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 };-CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA          = { 0x00,0x15 };-CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA     = { 0x00,0x16 };-CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5    = { 0x00,0x17 };-CipherSuite TLS_DH_anon_WITH_RC4_128_MD5          = { 0x00,0x18 };-CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 };-CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA          = { 0x00,0x1A };-CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA     = { 0x00,0x1B };--}--{-- - some builtin ciphers description- -}--cipher_null_null :: Cipher-cipher_null_null = Cipher-	{ cipherID           = 0x0-	, cipherName         = "null-null"-	, cipherDigestSize   = 0-	, cipherKeySize      = 0-	, cipherIVSize       = 0-	, cipherKeyBlockSize = 0-	, cipherPaddingSize  = 0-	, cipherHMAC         = (\_ _ -> B.empty)-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherNoneF-	, cipherMinVer       = Nothing-	}--cipher_RC4_128_MD5 :: Cipher-cipher_RC4_128_MD5 = Cipher-	{ cipherID           = 0x04-	, cipherName         = "RSA-rc4-128-md5"-	, cipherDigestSize   = 16-	, cipherKeySize      = 16-	, cipherIVSize       = 0-	, cipherKeyBlockSize = 2 * (16 + 16 + 0)-	, cipherPaddingSize  = 0-	, cipherHMAC         = hmacMD5-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4-	, cipherMinVer       = Nothing-	}--cipher_RC4_128_SHA1 :: Cipher-cipher_RC4_128_SHA1 = Cipher-	{ cipherID           = 0x05-	, cipherName         = "RSA-rc4-128-sha1"-	, cipherDigestSize   = 20-	, cipherKeySize      = 16-	, cipherIVSize       = 0-	, cipherKeyBlockSize = 2 * (20 + 16 + 0)-	, cipherPaddingSize  = 0-	, cipherHMAC         = hmacSHA1-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4-	, cipherMinVer       = Nothing-	}--cipher_AES128_SHA1 :: Cipher-cipher_AES128_SHA1 = Cipher-	{ cipherID           = 0x2f-	, cipherName         = "RSA-aes128-sha1"-	, cipherDigestSize   = 20-	, cipherKeySize      = 16-	, cipherIVSize       = 16-	, cipherKeyBlockSize = 2 * (20 + 16 + 16)-	, cipherPaddingSize  = 16-	, cipherHMAC         = hmacSHA1-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt-	, cipherMinVer       = Just SSL3-	}--cipher_AES256_SHA1 :: Cipher-cipher_AES256_SHA1 = Cipher-	{ cipherID           = 0x35-	, cipherName         = "RSA-aes256-sha1"-	, cipherDigestSize   = 20-	, cipherKeySize      = 32-	, cipherIVSize       = 16-	, cipherKeyBlockSize = 2 * (20 + 32 + 16)-	, cipherPaddingSize  = 16-	, cipherHMAC         = hmacSHA1-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt-	, cipherMinVer       = Just SSL3-	}--cipher_AES128_SHA256 :: Cipher-cipher_AES128_SHA256 = Cipher-	{ cipherID           = 0x3c-	, cipherName         = "RSA-aes128-sha256"-	, cipherDigestSize   = 32-	, cipherKeySize      = 16-	, cipherIVSize       = 16-	, cipherKeyBlockSize = 2 * (32 + 16 + 16)-	, cipherPaddingSize  = 16-	, cipherHMAC         = hmacSHA256-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt-	, cipherMinVer       = Just TLS12-	}--cipher_AES256_SHA256 :: Cipher-cipher_AES256_SHA256 = Cipher-	{ cipherID           = 0x3d-	, cipherName         = "RSA-aes256-sha256"-	, cipherDigestSize   = 32-	, cipherKeySize      = 32-	, cipherIVSize       = 16-	, cipherKeyBlockSize = 2 * (32 + 32 + 16)-	, cipherPaddingSize  = 16-	, cipherHMAC         = hmacSHA256-	, cipherKeyExchange  = CipherKeyExchangeRSA-	, cipherF            = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt-	, cipherMinVer       = Just TLS12-	}

@@ -1,308 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}---- |--- Module      : Network.TLS.Client--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the Client module contains the necessary calls to create a connecting TLS socket--- aka. a client socket.----module Network.TLS.Client-	( TLSClientParams(..)-	, TLSClientCallbacks(..)-	, TLSStateClient-	, newIState-	-- * low level packet sending receiving.-	, recvPacket-	, sendPacket-	-- * API, warning probably subject to change-	, connect-	, sendData-	, recvData-	, close-    -- * Enumerator interface-    , clientEnum-    , clientEnumSimple-	) where--import Data.Maybe-import Data.Word-import Control.Applicative ((<$>))-import Data.Certificate.X509-import Network.TLS.Cipher-import Network.TLS.Struct-import Network.TLS.Packet-import Network.TLS.State-import Network.TLS.Sending-import Network.TLS.Receiving-import Network.TLS.SRandom-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import System.IO (Handle, hFlush)-import Data.List (find)-import Data.IORef-import qualified Data.Enumerator as E-import qualified Control.Monad.IO.Class as Trans-import qualified Control.Monad.Trans.Class as Trans-import qualified Codec.Crypto.AES.Random as AESRand-import Data.Bits-import Control.Monad (when, unless)--data TLSClientCallbacks = TLSClientCallbacks-	{ cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates-	}--instance Show TLSClientCallbacks where-	show _ = "[callbacks]"--data TLSClientParams = TLSClientParams-	{ cpConnectVersion  :: Version            -- ^ client version we're sending by default-	, cpAllowedVersions :: [Version]          -- ^ allowed versions from the server-	, cpSession         :: Maybe [Word8]      -- ^ session for this connection-	, cpCiphers         :: [Cipher]           -- ^ all ciphers for this connection-	, cpCertificate     :: Maybe Certificate  -- ^ an optional client certificate-	, cpCallbacks       :: TLSClientCallbacks -- ^ user callbacks-	} deriving (Show)--data TLSStateClient = TLSStateClient-	{ scParams   :: TLSClientParams -- ^ client params and config for this connection-	, scTLSState :: TLSState        -- ^ client TLS State for this connection-	, scCertRequested :: Bool       -- ^ mark that the server requested a certificate-	} deriving (Show)--type IState = IORef TLSStateClient--newIState :: TLSClientParams -> SRandomGen -> IO IState-newIState params rng = newIORef $ TLSStateClient-    { scParams = params-    , scTLSState = state-    , scCertRequested = False-    }-  where-    state = (newTLSState rng) { stVersion = cpConnectVersion params, stClientContext = True }--{- | receive a single TLS packet or on error a TLSError -}-recvPacket :: IState -> Handle -> IO (Either TLSError Packet)-recvPacket istate handle = do-	hdr <- B.hGet handle 5 >>= return . decodeHeader-	case hdr of-		Left err                          -> return $ Left err-		Right header@(Header _ _ readlen) -> do-			content <- B.hGet handle (fromIntegral readlen)-			runIStateWrapper (readPacket header (EncryptedData content)) istate--newtype IStateWrapper a = IStateWrapper { runIStateWrapper :: IState -> IO a }-instance Monad IStateWrapper where-	return = IStateWrapper . const . return-	(IStateWrapper f) >>= g = IStateWrapper $ \ i -> do-		x <- f i-		runIStateWrapper (g x) i-instance MonadTLSState IStateWrapper where-	getTLSState = IStateWrapper $ fmap scTLSState . readIORef-	putTLSState s = IStateWrapper $ \i -> do-		cs <- readIORef i-		writeIORef i cs { scTLSState = s }--{- | send a single TLS packet -}-sendPacket :: IState -> Handle -> Packet -> IO ()-sendPacket istate handle pkt = do-	dataToSend <- runIStateWrapper (writePacket pkt) istate-	B.hPut handle dataToSend--recvServerHello :: IState -> Handle -> IO ()-recvServerHello istate handle = do-	state' <- readIORef istate-	let ciphers = cpCiphers $ scParams state'-	let allowedvers = cpAllowedVersions $ scParams state'-	let callbacks = cpCallbacks $ scParams state'-	pkt <- recvPacket istate handle-	let hs = case pkt of-		Right (Handshake h) -> h-		Left err            -> error ("error received: " ++ show err)-		Right x             -> error ("unexpected packet received, expecting handshake " ++ show x)-	case hs of-		ServerHello ver _ _ cipher _ _ -> do-			case find ((==) ver) allowedvers of-				Nothing -> error ("received version which is not allowed: " ++ show ver)-				Just _  -> do-					state <- readIORef istate-					let st = state { scTLSState = (scTLSState state) { stVersion = ver } }-					writeIORef istate st--			case find ((==) cipher . cipherID) ciphers of-				Nothing -> error "no cipher in common with the server"-				Just c  -> do-					state <- readIORef istate-					let st = state { scTLSState = (scTLSState state) { stCipher = Just c } }-					writeIORef istate st-			recvServerHello istate handle-		CertRequest _ _ _  -> do-			sc <- readIORef istate-			writeIORef istate sc { scCertRequested = True }-			recvServerHello istate handle-		Certificates certs -> do-			valid <- maybe (return True) (\cb -> cb certs) (cbCertificates callbacks)-			unless valid $ error "certificates received deemed invalid by user"-			recvServerHello istate handle-		ServerHelloDone    -> return ()-		_                  -> error "unexpected handshake message received in server hello messages"--connectSendClientHello :: IState -> Handle -> ClientRandom -> IO ()-connectSendClientHello istate handle crand = do-	state <- readIORef istate-	let ver = cpConnectVersion $ scParams state-	let ciphers = cpCiphers $ scParams state-	sendPacket istate handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing)--connectSendClientCertificate :: IState -> Handle -> IO ()-connectSendClientCertificate istate handle = do-	certRequested <- scCertRequested <$> readIORef istate-	when certRequested $ do-		clientCert <- cpCertificate . scParams <$> readIORef istate-		sendPacket istate handle $ Handshake (Certificates $ maybe [] (:[]) clientCert)--connectSendClientKeyXchg :: IState -> Handle -> ClientKeyData -> IO ()-connectSendClientKeyXchg istate handle prerand = do-	ver <- cpConnectVersion . scParams <$> readIORef istate-	sendPacket istate handle $ Handshake (ClientKeyXchg ver prerand)--connectSendFinish :: IState -> Handle -> IO ()-connectSendFinish istate handle = do-	cf <- runIStateWrapper (getHandshakeDigest True) istate-	sendPacket istate handle (Handshake $ Finished $ B.unpack cf)--{- | connect through a handle as a new TLS connection. -}-connect :: IState -> Handle -> ClientRandom -> ClientKeyData -> IO ()-connect istate handle crand premasterRandom = do-	connectSendClientHello istate handle crand-	recvServerHello istate handle-	connectSendClientCertificate istate handle--	connectSendClientKeyXchg istate handle premasterRandom--	{- maybe send certificateVerify -}-	{- FIXME not implemented yet -}--	sendPacket istate handle (ChangeCipherSpec)-	hFlush handle--	{- send Finished -}-	connectSendFinish istate handle-	-	{- receive changeCipherSpec -}-	pktCCS <- recvPacket istate handle-	case pktCCS of-		Right ChangeCipherSpec -> return ()-		x                      -> error ("unexpected reply. expecting change cipher spec  " ++ show x)--	{- receive Finished -}-	pktFin <- recvPacket istate handle-	case pktFin of-		Right (Handshake (Finished _)) -> return ()-		x                              -> error ("unexpected reply. expecting finished " ++ show x)--	return ()--sendDataChunk :: IState -> Handle -> B.ByteString -> IO ()-sendDataChunk istate handle d =-	if B.length d > 16384-		then do-			let (sending, remain) = B.splitAt 16384 d-			sendPacket istate handle $ AppData sending-			sendDataChunk istate handle remain-		else-			sendPacket istate handle $ AppData d--{- | sendData sends a bunch of data -}-sendData :: IState -> Handle -> L.ByteString -> IO ()-sendData istate handle d = mapM_ (sendDataChunk istate handle) (L.toChunks d)--{- | recvData get data out of Data packet, and automatically try to renegociate if- - a Handshake HelloRequest is received -}-recvData :: IState -> Handle -> IO L.ByteString-recvData istate handle = do-	pkt <- recvPacket istate handle-	case pkt of-		Right (AppData x) -> return $ L.fromChunks [x]-		Right (Handshake HelloRequest) -> do-			-- SECURITY FIXME audit the rng here..-			state <- readIORef istate-			let st = scTLSState state-			let (bytes, rng') = getRandomBytes (stRandomGen st) 32-			let (premaster, rng'') = getRandomBytes rng' 46-			writeIORef istate $ state { scTLSState = st { stRandomGen = rng'' } }-			let crand = fromJust $ clientRandom bytes-			connect istate handle crand (ClientKeyData $ B.pack premaster)-			recvData istate handle-		Left err          -> error ("error received: " ++ show err)-		_                 -> error "unexpected item"--{- | close a TLS connection.- - note that it doesn't close the handle, but just signal we're going to close- - the connection to the other side -}-close :: IState -> Handle -> IO ()-close istate handle = do-	sendPacket istate handle $ Alert (AlertLevel_Warning, CloseNotify)--clientEnumSimple-    :: Trans.MonadIO m-    => Handle-    -> (E.Iteratee B.ByteString m () -> E.Enumerator B.ByteString m a -> m b)-    -> m b-clientEnumSimple h f = do-	ranByte <- Trans.liftIO $ B.head <$> AESRand.randBytes 1-	_ <- Trans.liftIO $ AESRand.randBytes (fromIntegral ranByte)-	clientRandom' <- Trans.liftIO $ fromJust . clientRandom . B.unpack <$> AESRand.randBytes 32-	premasterRandom <- Trans.liftIO $ ClientKeyData <$> AESRand.randBytes 46-	seqInit <- Trans.liftIO $ conv . B.unpack <$> AESRand.randBytes 4-	let clientstate = TLSClientParams-		{ cpConnectVersion = TLS10-		, cpAllowedVersions = [ TLS10, TLS11 ]-		, cpSession = Nothing-		, cpCiphers = ciphers-		, cpCertificate = Nothing-		, cpCallbacks = TLSClientCallbacks-			{ cbCertificates = Nothing-			}-		}-	clientEnum clientstate (makeSRandomGen seqInit) h clientRandom' premasterRandom f-  where-    ciphers =-        [ cipher_AES128_SHA1-        , cipher_AES256_SHA1-        , cipher_RC4_128_MD5-        , cipher_RC4_128_SHA1-        ]-    conv l = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d-        where-            [a,b,c,d] = map fromIntegral l--clientEnum :: Trans.MonadIO m-           => TLSClientParams -> SRandomGen -> Handle -> ClientRandom -> ClientKeyData-           -> (E.Iteratee B.ByteString m () -> E.Enumerator B.ByteString m a -> m b)-           -> m b-clientEnum tcp srg h cr ckd f = do-    istate <- Trans.liftIO $ newIState tcp srg-    Trans.liftIO $ connect istate h cr ckd-    b <- f (iter istate) (enum istate)-    Trans.liftIO $ close istate h-    return b-  where-    iter :: Trans.MonadIO m => IState -> E.Iteratee B.ByteString m ()-    iter istate =-        E.continue go-      where-        go E.EOF = return ()-        go (E.Chunks xs) = do-            Trans.liftIO $ sendData istate h $ L.fromChunks xs-            E.continue go-    enum :: Trans.MonadIO m => IState -> E.Enumerator B.ByteString m a-    enum istate (E.Continue k) = do-		lbs <- Trans.liftIO $ recvData istate h-		let chunks = E.Chunks $ L.toChunks lbs-		step <- Trans.lift $ E.runIteratee $ k chunks-		enum istate step-    enum _ step = E.returnI step

@@ -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

@@ -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 ]

@@ -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

@@ -1,435 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- |--- Module      : Network.TLS.Packet--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the Packet module contains everything necessary to serialize and deserialize things--- with only explicit parameters, no TLS state is involved here.----module Network.TLS.Packet-	(-	-- * marshall functions for header messages-	  decodeHeader-	, encodeHeader--	-- * marshall functions for alert messages-	, decodeAlert-	, encodeAlert--	-- * marshall functions for handshake messages-	, decodeHandshakeHeader-	, decodeHandshake-	, encodeHandshake-	, encodeHandshakeHeader-	, encodeHandshakeContent--	-- * marshall functions for change cipher spec message-	, decodeChangeCipherSpec-	, encodeChangeCipherSpec--	-- * generate things for packet content-	, generateMasterSecret-	, generateKeyBlock-	, generateClientFinished-	, generateServerFinished-	) where--import Network.TLS.Struct-import Network.TLS.Cap-import Network.TLS.Wire-import Data.Either (partitionEithers)-import Data.Maybe (fromJust, isNothing)-import Control.Applicative ((<$>))-import Control.Monad-import Control.Monad.Error-import Data.Certificate.X509-import Network.TLS.Crypto-import Network.TLS.MAC-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as L--{-- - decode and encode headers- -}-decodeHeader :: ByteString -> Either TLSError Header-decodeHeader = runGet $ do-	ty <- getWord8-	major <- getWord8-	minor <- getWord8-	len <- getWord16-	case (valToType ty, verOfNum (major, minor)) of-		(Just y, Just v) -> return $ Header y v len-		(Nothing, _)     -> throwError (Error_Packet "invalid type")-		(_, Nothing)     -> throwError (Error_Packet "invalid version")--encodeHeader :: Header -> ByteString-encodeHeader (Header pt ver len) =-	{- FIXME check len <= 2^14 -}-	runPut (putWord8 (valOfType pt) >> putWord8 major >> putWord8 minor >> putWord16 len)-	where (major, minor) = numericalVer ver--{-- - decode and encode ALERT- -}--decodeAlert :: ByteString -> Either TLSError (AlertLevel, AlertDescription)-decodeAlert = runGet $ do-	al <- getWord8-	ad <- getWord8-	case (valToType al, valToType ad) of-		(Just a, Just d) -> return (a, d)-		(Nothing, _)     -> throwError (Error_Packet "missing alert level")-		(_, Nothing)     -> throwError (Error_Packet "missing alert description")--encodeAlert :: (AlertLevel, AlertDescription) -> ByteString-encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad))--{- decode and encode HANDSHAKE -}--decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, Bytes)-decodeHandshakeHeader = runGet $ do-	tyopt <- getWord8 >>= return . valToType-	ty <- if isNothing tyopt-		then throwError (Error_Unknown_Type "handshake type")-		else return $ fromJust tyopt-	len <- getWord24-	content <- getBytes len-	empty <- isEmpty-	unless empty (throwError (Error_Internal_Packet_Remaining 1))-	return (ty, content)--decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake-decodeHandshake ver ty = runGet $ case ty of-	HandshakeType_HelloRequest    -> decodeHelloRequest-	HandshakeType_ClientHello     -> decodeClientHello-	HandshakeType_ServerHello     -> decodeServerHello-	HandshakeType_Certificate     -> decodeCertificates-	HandshakeType_ServerKeyXchg   -> decodeServerKeyXchg ver-	HandshakeType_CertRequest     -> decodeCertRequest ver-	HandshakeType_ServerHelloDone -> decodeServerHelloDone-	HandshakeType_CertVerify      -> decodeCertVerify-	HandshakeType_ClientKeyXchg   -> decodeClientKeyXchg-	HandshakeType_Finished        -> decodeFinished ver--decodeHelloRequest :: Get Handshake-decodeHelloRequest = return HelloRequest--decodeClientHello :: Get Handshake-decodeClientHello = do-	ver          <- getVersion-	random       <- getClientRandom32-	session      <- getSession-	ciphers      <- getWords16-	compressions <- getWords8-	r            <- remaining-	exts <- if hasHelloExtensions ver && r > 0-		then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just-		else return Nothing-	return $ ClientHello ver random session ciphers compressions exts--decodeServerHello :: Get Handshake-decodeServerHello = do-	ver           <- getVersion-	random        <- getServerRandom32-	session       <- getSession-	cipherid      <- getWord16-	compressionid <- getWord8-	r             <- remaining-	exts <- if hasHelloExtensions ver && r > 0-		then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just-		else return Nothing-	return $ ServerHello ver random session cipherid compressionid exts--decodeServerHelloDone :: Get Handshake-decodeServerHelloDone = return ServerHelloDone--decodeCertificates :: Get Handshake-decodeCertificates = do-	certslen <- getWord24-	certs <- getCerts certslen >>= return . map (decodeCertificate . L.fromChunks . (:[]))-	let (l, r) = partitionEithers certs-	if length l > 0-		then throwError $ Error_Certificate $ show l-		else return $ Certificates r--decodeFinished :: Version -> Get Handshake-decodeFinished ver = do-	-- unfortunately passing the verify_data_size here would be tedious for >=TLS12,-	-- so just return the remaining string.-	len <- if ver >= TLS12-		then remaining-		else if ver == SSL3 then return 36-			else return 12-	opaque <- getBytes (fromIntegral len)-	return $ Finished $ B.unpack opaque--getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ]-getSignatureHashAlgorithm 0   = return []-getSignatureHashAlgorithm len = do-	h <- fromJust . valToType <$> getWord8-	s <- fromJust . valToType <$> getWord8-	xs <- getSignatureHashAlgorithm (len - 2)-	return ((h, s) : xs)--decodeCertRequest :: Version -> Get Handshake-decodeCertRequest ver = do-	certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8--	sigHashAlgs <- if ver >= TLS12-		then do-			sighashlen <- getWord16-			Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen)-		else return Nothing-	dNameLen <- getWord16-	when (ver < TLS12 && dNameLen < 3) $ throwError (Error_Misc "certrequest distinguishname not of the correct size")-	dName <- getBytes $ fromIntegral dNameLen-	return $ CertRequest certTypes sigHashAlgs (B.unpack dName)--decodeCertVerify :: Get Handshake-decodeCertVerify =-	{- FIXME -}-	return $ CertVerify []--decodeClientKeyXchg :: Get Handshake-decodeClientKeyXchg = do-	ver <- getVersion-	ran <- getClientKeyData46-	return $ ClientKeyXchg ver ran---- FIXME need to work out how we marshall an opaque number---numberise :: ByteString -> Integer-numberise _ = 0--decodeServerKeyXchg_DH :: Get ServerDHParams-decodeServerKeyXchg_DH = do-	p <- getWord16 >>= getBytes . fromIntegral-	g <- getWord16 >>= getBytes . fromIntegral-	y <- getWord16 >>= getBytes . fromIntegral-	return $ ServerDHParams { dh_p = numberise p, dh_g = numberise g, dh_Ys = numberise y }--decodeServerKeyXchg_RSA :: Get ServerRSAParams-decodeServerKeyXchg_RSA = do-	modulus <- getWord16 >>= getBytes . fromIntegral-	expo <- getWord16 >>= getBytes . fromIntegral-	return $ ServerRSAParams { rsa_modulus = numberise modulus, rsa_exponent = numberise expo }--decodeServerKeyXchg :: Version -> Get Handshake-decodeServerKeyXchg ver = do-	-- mostly unimplemented-	skxAlg <- case ver of-		TLS12 -> return $ SKX_RSA Nothing-		TLS10 -> do-			rsaparams <- decodeServerKeyXchg_RSA-			return $ SKX_RSA $ Just rsaparams-		_ -> do-			return $ SKX_RSA Nothing-	return (ServerKeyXchg skxAlg)--encodeHandshake :: Handshake -> ByteString-encodeHandshake o =-	let content = runPut $ encodeHandshakeContent o in-	let len = fromIntegral $ B.length content in-	let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in-	B.concat [ header, content ]--encodeHandshakeHeader :: HandshakeType -> Int -> Put-encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len--encodeHandshakeContent :: Handshake -> Put--encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts) = do-	putVersion version-	putClientRandom32 random-	putSession session-	putWords16 cipherIDs-	putWords8 compressionIDs-	putExtensions exts-	return ()--encodeHandshakeContent (ServerHello version random session cipherID compressionID exts) =-	putVersion version >> putServerRandom32 random >> putSession session-	                   >> putWord16 cipherID >> putWord8 compressionID-	                   >> putExtensions exts >> return ()--encodeHandshakeContent (Certificates certs) =-	putWord24 len >> putBytes certbs-	where-		certbs = runPut $ mapM_ putCert certs-		len    = fromIntegral $ B.length certbs--encodeHandshakeContent (ClientKeyXchg version random) = do-	putVersion version-	putClientKeyData46 random--encodeHandshakeContent (ServerKeyXchg _) = do-	-- FIXME-	return ()--encodeHandshakeContent (HelloRequest) = return ()-encodeHandshakeContent (ServerHelloDone) = return ()--encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do-	putWords8 (map valOfType certTypes)-	case sigAlgs of-		Nothing -> return ()-		Just l  -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l-	putBytes $ B.pack certAuthorities--encodeHandshakeContent (CertVerify _) = undefined--encodeHandshakeContent (Finished opaque) = mapM_ putWord8 opaque--{- marshall helpers -}-getVersion :: Get Version-getVersion = do-	major <- getWord8-	minor <- getWord8-	case verOfNum (major, minor) of-		Just v   -> return v-		Nothing  -> throwError (Error_Unknown_Version major minor)--putVersion :: Version -> Put-putVersion ver = putWord8 major >> putWord8 minor-	where (major, minor) = numericalVer ver--{- FIXME make sure it return error if not 32 available -}-getRandom32 :: Get Bytes-getRandom32 = getBytes 32--getServerRandom32 :: Get ServerRandom-getServerRandom32 = ServerRandom <$> getRandom32--getClientRandom32 :: Get ClientRandom-getClientRandom32 = ClientRandom <$> getRandom32--putRandom32 :: Bytes -> Put-putRandom32 = putBytes--putClientRandom32 :: ClientRandom -> Put-putClientRandom32 (ClientRandom r) = putRandom32 r--putServerRandom32 :: ServerRandom -> Put-putServerRandom32 (ServerRandom r) = putRandom32 r--getClientKeyData46 :: Get ClientKeyData-getClientKeyData46 = ClientKeyData <$> getBytes 46--putClientKeyData46 :: ClientKeyData -> Put-putClientKeyData46 (ClientKeyData d) = putBytes d--getSession :: Get Session-getSession = do-	len8 <- getWord8-	case fromIntegral len8 of-		0   -> return $ Session Nothing-		len -> Session . Just <$> getBytes len--putSession :: Session -> Put-putSession (Session session) =-	case session of-		Nothing -> putWord8 0-		Just s  -> putWord8 (fromIntegral $ B.length s) >> putBytes s--getCerts :: Int -> Get [Bytes]-getCerts 0   = return []-getCerts len = do-	certlen <- getWord24-	cert <- getBytes certlen-	certxs <- getCerts (len - certlen - 3)-	return (cert : certxs)--putCert :: Certificate -> Put-putCert cert = putWord24 (fromIntegral $ B.length content) >> putBytes content-	where content = B.concat $ L.toChunks $ encodeCertificate cert--getExtensions :: Int -> Get [Extension]-getExtensions 0   = return []-getExtensions len = do-	extty <- getWord16-	extdatalen <- getWord16-	extdata <- getBytes $ fromIntegral extdatalen-	extxs <- getExtensions (len - fromIntegral extdatalen - 4)-	return $ (extty, B.unpack extdata) : extxs--putExtension :: Extension -> Put-putExtension (ty, l) = do-	putWord16 ty-	putWord16 (fromIntegral $ length l)-	putBytes (B.pack l)--putExtensions :: Maybe [Extension] -> Put-putExtensions Nothing   = return ()-putExtensions (Just es) =-	putWord16 (fromIntegral $ B.length extbs) >> putBytes extbs-	where-		extbs = runPut $ mapM_ putExtension es--{-- - decode and encode ALERT- -}--decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec b = do-	case runGet getWord8 b of-		Left e -> Left e-		Right x ->-			if x == 1-				then Right ()-				else Left $ Error_Misc "unknown change cipher spec content"--encodeChangeCipherSpec :: ByteString-encodeChangeCipherSpec = runPut (putWord8 1)--{-- - generate things for packet content- -}-generateMasterSecret_TLS, generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes-generateMasterSecret_TLS premasterSecret (ClientRandom c) (ServerRandom s) =-	prf_MD5SHA1 premasterSecret seed 48-	where-		seed = B.concat [ BC.pack "master secret", c, s ]--generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) =-	B.concat $ map (computeMD5 . BC.pack) [ "A", "BB", "CCC" ]-	where-		computeMD5  label = hashMD5 $ B.concat [ premasterSecret, computeSHA1 label ]-		computeSHA1 label = hashSHA1 $ B.concat [ label, premasterSecret, c, s ]--generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes-generateMasterSecret ver =-	if ver < TLS10 then generateMasterSecret_SSL else generateMasterSecret_TLS--generateKeyBlock :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes-generateKeyBlock (ClientRandom c) (ServerRandom s) mastersecret kbsize =-	prf_MD5SHA1 mastersecret seed kbsize-	where-		seed = B.concat [ BC.pack "key expansion", s, c ]--generateFinished_TLS :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes-generateFinished_TLS label mastersecret md5ctx sha1ctx =-	prf_MD5SHA1 mastersecret seed 12-	where-		seed = B.concat [ label, finalizeHash md5ctx, finalizeHash sha1ctx ]--generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes-generateFinished_SSL sender mastersecret md5ctx sha1ctx =-	B.concat [md5hash, sha1hash]-	where-		md5hash = hashMD5 $ B.concat [ mastersecret, pad2, md5left ]-		sha1hash = hashSHA1 $ B.concat [ mastersecret, pad2, sha1left ]-		pad2 = B.empty -- FIXME-		md5left = hashMD5 B.empty-		sha1left = hashSHA1 B.empty--generateClientFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes-generateClientFinished ver =-	if ver < TLS10 then generateFinished_SSL "CLNT" else generateFinished_TLS (BC.pack "client finished")--generateServerFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes-generateServerFinished ver =-	if ver < TLS10 then generateFinished_SSL "SRVR" else generateFinished_TLS (BC.pack "server finished")

@@ -1,218 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}---- |--- Module      : Network.TLS.Receiving--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the Receiving module contains calls related to unmarshalling packets according--- to the TLS state----module Network.TLS.Receiving (-	readPacket-	) where--import Control.Applicative ((<$>))-import Control.Monad.State-import Control.Monad.Error-import Data.Maybe--import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as B--import Network.TLS.Util-import Network.TLS.Cap-import Network.TLS.Struct-import Network.TLS.Packet-import Network.TLS.State-import Network.TLS.Cipher-import Network.TLS.Crypto-import Network.TLS.SRandom-import Data.Certificate.X509--newtype TLSRead a = TLSR { runTLSR :: ErrorT TLSError (State TLSState) a }-	deriving (Monad, MonadError TLSError)--instance Functor TLSRead where-	fmap f = TLSR . fmap f . runTLSR--instance MonadTLSState TLSRead where-	putTLSState x = TLSR (lift $ put x)-	getTLSState   = TLSR (lift get)--runTLSRead :: MonadTLSState m => TLSRead a -> m (Either TLSError a)-runTLSRead f = do-	st <- getTLSState-	let (a, newst) = runState (runErrorT (runTLSR f)) st-	putTLSState newst-	return a--returnEither :: Either TLSError a -> TLSRead a-returnEither (Left err) = throwError err-returnEither (Right a)  = return a--readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet)-readPacket hdr@(Header ProtocolType_AppData _ _) content =-	runTLSRead (AppData <$> decryptContent hdr content)--readPacket hdr@(Header ProtocolType_Alert _ _)   content =-	runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert)--readPacket hdr@(Header ProtocolType_ChangeCipherSpec _ _) content = runTLSRead $ do-	dcontent <- decryptContent hdr content-	returnEither $ decodeChangeCipherSpec dcontent-	switchRxEncryption-	isClientContext >>= \cc -> when (not cc) setKeyBlock-	return ChangeCipherSpec--readPacket hdr@(Header ProtocolType_Handshake ver _) content =-	runTLSRead (decryptContent hdr content >>= processHsPacket ver)--decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)-decryptRSA econtent = do-	rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake-	return $ rsaDecrypt rsapriv (B.drop 2 econtent)--setMasterSecretRandom :: ByteString -> TLSRead ()-setMasterSecretRandom content = do-	st <- getTLSState-	let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content)-	putTLSState $ st { stRandomGen = g' }-	setMasterSecret (B.pack bytes)--processClientKeyXchg :: Version -> ByteString -> TLSRead ()-processClientKeyXchg ver content = do-	{- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -}-	expectedVer <- getTLSState >>= return . hstClientVersion . fromJust . stHandshake-	if expectedVer /= ver-		then setMasterSecretRandom content-		else setMasterSecret content--processClientFinished :: FinishedData -> TLSRead ()-processClientFinished fdata = do-	cc <- getTLSState >>= return . stClientContext-	expected <- getHandshakeDigest (not cc)-	when (expected /= B.pack fdata) $ do-		-- FIXME don't fail, but report the error so that the code can send a BadMac Alert.-		fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata))-	return ()--processHsPacket :: Version -> ByteString -> TLSRead Packet-processHsPacket ver dcontent = do-	(ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent-	-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.-	content <- case ty of-		HandshakeType_ClientKeyXchg -> do-			copt <- decryptRSA econtent-			return $ maybe econtent id copt-		_                           ->-			return econtent-	hs <- case (ty, decodeHandshake ver ty content) of-		(_, Right x)                            -> return x-		(HandshakeType_ClientKeyXchg, Left _)   -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff)-		(_, Left err)                           -> throwError err-	clientmode <- isClientContext-	case hs of-		ClientHello cver ran _ _ _ _ -> unless clientmode $ do-			startHandshakeClient cver ran-		ServerHello sver ran _ _ _ _ -> when clientmode $ do-			setServerRandom ran-			setVersion sver-		Certificates certs           -> when clientmode $ do processCertificates certs-		ClientKeyXchg cver _         -> unless clientmode $ do-			processClientKeyXchg cver content-		Finished fdata               -> processClientFinished fdata-		_                            -> return ()-	when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent)-	return $ Handshake hs---decryptContent :: Header -> EncryptedData -> TLSRead ByteString-decryptContent hdr e@(EncryptedData b) = do-	st <- getTLSState-	if stRxEncrypted st-		then decryptData e >>= getCipherData hdr-		else return b--getCipherData :: Header -> CipherData -> TLSRead ByteString-getCipherData hdr cdata = do-	-- check if the MAC is valid.-	macValid <- case cipherDataMAC cdata of-		Nothing     -> return True-		Just digest -> do-			let (Header pt ver _) = hdr-			let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)-			expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata-			if expected_digest == digest-				then return True-				else return False--	-- check if the padding is filled with the correct pattern if it exists-	paddingValid <- case cipherDataPadding cdata of-		Nothing  -> return True-		Just pad -> do-			let b = B.length pad - 1-			return $ maybe True (const False) $ B.find (/= fromIntegral b) pad--	unless (and $! [ macValid, paddingValid ]) $ do-		throwError $ Error_Digest ([], [])--	return $ cipherDataContent cdata--decryptData :: EncryptedData -> TLSRead CipherData-decryptData (EncryptedData econtent) = do-	st <- getTLSState--	assert "decrypt data"-		[ ("cipher", isNothing $ stCipher st)-		, ("crypt state", isNothing $ stRxCryptState st) ]--	let cipher       = fromJust $ stCipher st-	let cst          = fromJust $ stRxCryptState st-	let padding_size = fromIntegral $ cipherPaddingSize cipher-	let digestSize   = fromIntegral $ cipherDigestSize cipher-	let writekey     = cstKey cst--	case cipherF cipher of-		CipherNoneF -> fail "none decrypt"-		CipherBlockF _ decryptF -> do-			{- update IV -}-			let (iv, econtent') =-				if hasExplicitBlockIV $ stVersion st-					then B.splitAt (fromIntegral $ cipherIVSize cipher) econtent-					else (cstIV cst, econtent)-			let newiv = fromJust $ takelast padding_size econtent'-			putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }--			let content' = decryptF writekey iv econtent'-			let paddinglength = fromIntegral (B.last content') + 1-			let contentlen = B.length content' - paddinglength - digestSize-			let (content, mac, padding) = fromJust $ partition3 content' (contentlen, digestSize, paddinglength)-			return $ CipherData-				{ cipherDataContent = content-				, cipherDataMAC     = Just mac-				, cipherDataPadding = Just padding-				}-		CipherStreamF initF _ decryptF -> do-			let iv = cstIV cst-			let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent-			{- update Ctx -}-			let contentlen        = B.length content' - digestSize-			let (content, mac, _) = fromJust $ partition3 content' (contentlen, digestSize, 0)-			putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }-			return $ CipherData-				{ cipherDataContent = content-				, cipherDataMAC     = Just mac-				, cipherDataPadding = Nothing-				}--processCertificates :: [Certificate] -> TLSRead ()-processCertificates certs = do-	case certPubKey $ head certs of-		PubKey _ (PubKeyRSA (lm, m, e)) -> do-			let pk = PublicKey { public_size = fromIntegral lm, public_n = m, public_e = e }-			setPublicKey pk-		_                    -> return ()

@@ -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)

@@ -1,179 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- |--- Module      : Network.TLS.Sending--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the Sending module contains calls related to marshalling packets according--- to the TLS state ----module Network.TLS.Sending (-	writePacket-	) where--import Control.Monad.State-import Data.Maybe--import Data.ByteString (ByteString)-import qualified Data.ByteString as B--import Network.TLS.Util-import Network.TLS.Cap-import Network.TLS.Wire-import Network.TLS.Struct-import Network.TLS.Packet-import Network.TLS.State-import Network.TLS.Cipher-import Network.TLS.Crypto--{-- - 'makePacketData' create a Header and a content bytestring related to a packet- - this doesn't change any state- -}-makePacketData :: MonadTLSState m => Packet -> m (Header, ByteString)-makePacketData pkt = do-	ver <- getTLSState >>= return . stVersion-	content <- writePacketContent pkt-	let hdr = Header (packetType pkt) ver (fromIntegral $ B.length content)-	return (hdr, content)--{-- - Handshake data need to update a digest- -}-processPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)-processPacketData dat@(Header ty _ _, content) = do-	when (ty == ProtocolType_Handshake) (updateHandshakeDigest content)-	return dat--{-- - when Tx Encrypted is set, we pass the data through encryptContent, otherwise- - we just return the packet- -}-encryptPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)-encryptPacketData dat = do-	st <- getTLSState-	if stTxEncrypted st-		then encryptContent dat-		else return dat--{-- - ChangeCipherSpec state change need to be handled after encryption otherwise- - its own packet would be encrypted with the new context, instead of beeing sent- - under the current context- -}-postprocessPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)-postprocessPacketData dat@(Header ProtocolType_ChangeCipherSpec _ _, _) =-	switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return dat--postprocessPacketData dat = return dat--{-- - marshall packet data- -}-encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString-encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]---{-- - writePacket transform a packet into marshalled data related to current state- - and updating state on the go- -}-writePacket :: MonadTLSState m => Packet -> m ByteString-writePacket pkt = makePacketData pkt >>= processPacketData >>=-                  encryptPacketData >>= postprocessPacketData >>= encodePacket--{------------------------------------------------------------------------------}-{- SENDING Helpers                                                            -}-{------------------------------------------------------------------------------}--{- if the RSA encryption fails we just return an empty bytestring, and let the protocol- - fail by itself; however it would be probably better to just report it since it's an internal problem.- -}-encryptRSA :: MonadTLSState m => ByteString -> m ByteString-encryptRSA content = do-	st <- getTLSState-	let g = stRandomGen st-	let rsakey = fromJust $ hstRSAPublicKey $ fromJust $ stHandshake st-	case rsaEncrypt g rsakey content of-		Nothing             -> fail "no RSA key selected"-		Just (econtent, g') -> do-			putTLSState (st { stRandomGen = g' })-			return econtent--encryptContent :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)-encryptContent (hdr@(Header pt ver _), content) = do-	digest <- makeDigest True hdr content-	encrypted_msg <- encryptData $ B.concat [content, digest]-	let hdrnew = Header pt ver (fromIntegral $ B.length encrypted_msg)-	return (hdrnew, encrypted_msg)--encryptData :: MonadTLSState m => ByteString -> m ByteString-encryptData content = do-	st <- getTLSState--	assert "encrypt data"-		[ ("cipher", isNothing $ stCipher st)-		, ("crypt state", isNothing $ stTxCryptState st) ]--	let cipher = fromJust $ stCipher st-	let cst = fromJust $ stTxCryptState st-	let padding_size = fromIntegral $ cipherPaddingSize cipher--	let msg_len = B.length content-	let padding = if padding_size > 0-		then-			let padbyte = padding_size - (msg_len `mod` padding_size) in-			let padbyte' = if padbyte == 0 then padding_size else padbyte in-			B.replicate padbyte' (fromIntegral (padbyte' - 1))-		else-			B.empty-	let writekey = cstKey cst--	econtent <- case cipherF cipher of-		CipherNoneF -> fail "none encrypt"-		CipherBlockF encrypt _ -> do-			let iv = cstIV cst-			let e = encrypt writekey iv (B.concat [ content, padding ])-			let newiv = fromJust $ takelast (fromIntegral $ cipherIVSize cipher) e-			putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }-			return $ if hasExplicitBlockIV $ stVersion st-				then B.concat [iv,e]-				else e-		CipherStreamF initF encryptF _ -> do-			let iv = cstIV cst-			let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content-			putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }-			return e-	return econtent--encodePacketContent :: Packet -> ByteString-encodePacketContent (Handshake h)      = encodeHandshake h-encodePacketContent (Alert a)          = encodeAlert a-encodePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec-encodePacketContent (AppData x)        = x--writePacketContent :: MonadTLSState m => Packet -> m ByteString-writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do-	let premastersecret = runPut $ encodeHandshakeContent ckx-	setMasterSecret premastersecret-	econtent <- encryptRSA premastersecret-	let extralength = runPut $ putWord16 $ fromIntegral $ B.length econtent-	let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) (fromIntegral (B.length econtent + 2))-	return $ B.concat [hdr, extralength, econtent]--writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do-	cc <- isClientContext-	when cc (startHandshakeClient ver crand)-	return $ encodePacketContent pkt--writePacketContent pkt@(Handshake (ServerHello ver srand _ _ _ _)) = do-	cc <- isClientContext-	unless cc $ do-		setVersion ver-		setServerRandom srand-	return $ encodePacketContent pkt--writePacketContent pkt = return $ encodePacketContent pkt

@@ -1,267 +0,0 @@--- |--- Module      : Network.TLS.State--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the State module contains calls related to state initialization/manipulation--- which is use by the Receiving module and the Sending module.----module Network.TLS.State-	( TLSState(..)-	, TLSHandshakeState(..)-	, TLSCryptState(..)-	, TLSMacState(..)-	, MonadTLSState, getTLSState, putTLSState, modifyTLSState-	, newTLSState-	, assert -- FIXME move somewhere else (Internal.hs ?)-	, finishHandshakeTypeMaterial-	, finishHandshakeMaterial-	, makeDigest-	, setMasterSecret-	, setPublicKey-	, setPrivateKey-	, setKeyBlock-	, setVersion-	, setCipher-	, setServerRandom-	, switchTxEncryption-	, switchRxEncryption-	, isClientContext-	, startHandshakeClient-	, updateHandshakeDigest-	, getHandshakeDigest-	, endHandshake-	) where--import Data.Word-import Data.Maybe (fromJust, isNothing)-import Network.TLS.Util-import Network.TLS.Struct-import Network.TLS.SRandom-import Network.TLS.Wire-import Network.TLS.Packet-import Network.TLS.Crypto-import Network.TLS.Cipher-import qualified Data.ByteString as B-import Control.Monad--assert :: Monad m => String -> [(String,Bool)] -> m ()-assert fctname list = forM_ list $ \ (name, assumption) -> do-	when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed")--data TLSCryptState = TLSCryptState-	{ cstKey        :: !Bytes-	, cstIV         :: !Bytes-	, cstMacSecret  :: !Bytes-	} deriving (Show)--data TLSMacState = TLSMacState-	{ msSequence :: Word64-	} deriving (Show)--data TLSHandshakeState = TLSHandshakeState-	{ hstClientVersion   :: !(Version)-	, hstClientRandom    :: !ClientRandom-	, hstServerRandom    :: !(Maybe ServerRandom)-	, hstMasterSecret    :: !(Maybe Bytes)-	, hstRSAPublicKey    :: !(Maybe PublicKey)-	, hstRSAPrivateKey   :: !(Maybe PrivateKey)-	, hstHandshakeDigest :: Maybe (HashCtx, HashCtx) -- FIXME could be only 1 hash in tls12-	} deriving (Show)--data TLSState = TLSState-	{ stClientContext :: Bool-	, stVersion       :: !Version-	, stHandshake     :: !(Maybe TLSHandshakeState)-	, stTxEncrypted   :: Bool-	, stRxEncrypted   :: Bool-	, stTxCryptState  :: !(Maybe TLSCryptState)-	, stRxCryptState  :: !(Maybe TLSCryptState)-	, stTxMacState    :: !(Maybe TLSMacState)-	, stRxMacState    :: !(Maybe TLSMacState)-	, stCipher        :: Maybe Cipher-	, stRandomGen     :: SRandomGen-	} deriving (Show)--class (Monad m) => MonadTLSState m where-	getTLSState :: m TLSState-	putTLSState :: TLSState -> m ()--newTLSState :: SRandomGen -> TLSState-newTLSState rng = TLSState-	{ stClientContext = False-	, stVersion       = TLS10-	, stHandshake     = Nothing-	, stTxEncrypted   = False-	, stRxEncrypted   = False-	, stTxCryptState  = Nothing-	, stRxCryptState  = Nothing-	, stTxMacState    = Nothing-	, stRxMacState    = Nothing-	, stCipher        = Nothing-	, stRandomGen     = rng-	}--modifyTLSState :: (MonadTLSState m) => (TLSState -> TLSState) -> m ()-modifyTLSState f = getTLSState >>= \st -> putTLSState (f st)--makeDigest :: (MonadTLSState m) => Bool -> Header -> Bytes -> m Bytes-makeDigest w hdr content = do-	st <- getTLSState-	assert "make digest"-		[ ("cipher", isNothing $ stCipher st)-		, ("crypt state", isNothing $ if w then stTxCryptState st else stRxCryptState st)-		, ("mac state", isNothing $ if w then stTxMacState st else stRxMacState st) ]-	let cst = fromJust $ if w then stTxCryptState st else stRxCryptState st-	let ms = fromJust $ if w then stTxMacState st else stRxMacState st-	let cipher = fromJust $ stCipher st--	let hmac_msg = B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ]-	let digest = (cipherHMAC cipher) (cstMacSecret cst) hmac_msg--	let newms = ms { msSequence = (msSequence ms) + 1 }--	modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })-	return digest--finishHandshakeTypeMaterial :: HandshakeType -> Bool-finishHandshakeTypeMaterial HandshakeType_ClientHello     = True-finishHandshakeTypeMaterial HandshakeType_ServerHello     = True-finishHandshakeTypeMaterial HandshakeType_Certificate     = True-finishHandshakeTypeMaterial HandshakeType_HelloRequest    = False-finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True-finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg   = True-finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg   = True-finishHandshakeTypeMaterial HandshakeType_CertRequest     = True-finishHandshakeTypeMaterial HandshakeType_CertVerify      = False-finishHandshakeTypeMaterial HandshakeType_Finished        = True--finishHandshakeMaterial :: Handshake -> Bool-finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake--switchTxEncryption :: MonadTLSState m => m ()-switchTxEncryption = getTLSState >>= putTLSState . (\st -> st { stTxEncrypted = True })--switchRxEncryption :: MonadTLSState m => m ()-switchRxEncryption = getTLSState >>= putTLSState . (\st -> st { stRxEncrypted = True })--setServerRandom :: MonadTLSState m => ServerRandom -> m ()-setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran })--setMasterSecret :: MonadTLSState m => Bytes -> m ()-setMasterSecret premastersecret = do-	st <- getTLSState-	hasValidHandshake "master secret"-	assert "set master secret"-		[ ("server random", (isNothing $ hstServerRandom $ fromJust $ stHandshake st)) ]--	updateHandshake "master secret" (\hst ->-		let ms = generateMasterSecret (stVersion st) premastersecret (hstClientRandom hst) (fromJust $ hstServerRandom hst) in-		hst { hstMasterSecret = Just ms } )-	return ()--setPublicKey :: MonadTLSState m => PublicKey -> m ()-setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk })--setPrivateKey :: MonadTLSState m => PrivateKey -> m ()-setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk })--setKeyBlock :: MonadTLSState m => m ()-setKeyBlock = do-	st <- getTLSState--	let hst = fromJust $ stHandshake st-	assert "set key block"-		[ ("cipher", (isNothing $ stCipher st))-		, ("server random", (isNothing $ hstServerRandom hst))-		, ("master secret", (isNothing $ hstMasterSecret hst))-		]--	let cc = stClientContext st-	let cipher = fromJust $ stCipher st-	let keyblockSize = fromIntegral $ cipherKeyBlockSize cipher-	let digestSize = fromIntegral $ cipherDigestSize cipher-	let keySize = fromIntegral $ cipherKeySize cipher-	let ivSize = fromIntegral $ cipherIVSize cipher-	let kb = generateKeyBlock (hstClientRandom hst)-	                          (fromJust $ hstServerRandom hst)-	                          (fromJust $ hstMasterSecret hst) keyblockSize--	let (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =-		fromJust $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize)--	let cstClient = TLSCryptState-		{ cstKey        = cWriteKey-		, cstIV         = cWriteIV-		, cstMacSecret  = cMACSecret }-	let cstServer = TLSCryptState-		{ cstKey        = sWriteKey-		, cstIV         = sWriteIV-		, cstMacSecret  = sMACSecret }-	let msClient = TLSMacState { msSequence = 0 }-	let msServer = TLSMacState { msSequence = 0 }-	putTLSState $ st-		{ stTxCryptState = Just $ if cc then cstClient else cstServer-		, stRxCryptState = Just $ if cc then cstServer else cstClient-		, stTxMacState   = Just $ if cc then msClient else msServer-		, stRxMacState   = Just $ if cc then msServer else msClient-		}--setCipher :: MonadTLSState m => Cipher -> m ()-setCipher cipher = getTLSState >>= putTLSState . (\st -> st { stCipher = Just cipher })--setVersion :: MonadTLSState m => Version -> m ()-setVersion ver = getTLSState >>= putTLSState . (\st -> st { stVersion = ver })--isClientContext :: MonadTLSState m => m Bool-isClientContext = getTLSState >>= return . stClientContext---- create a new empty handshake state-newEmptyHandshake :: Version -> ClientRandom -> TLSHandshakeState-newEmptyHandshake ver crand = TLSHandshakeState-	{ hstClientVersion   = ver-	, hstClientRandom    = crand-	, hstServerRandom    = Nothing-	, hstMasterSecret    = Nothing-	, hstRSAPublicKey    = Nothing-	, hstRSAPrivateKey   = Nothing-	, hstHandshakeDigest = Nothing-	}--startHandshakeClient :: MonadTLSState m => Version -> ClientRandom -> m ()-startHandshakeClient ver crand = do-	-- FIXME check if handshake is already not null-	chs <- getTLSState >>= return . stHandshake-	when (isNothing chs) $-		modifyTLSState (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand })--hasValidHandshake :: MonadTLSState m => String -> m ()-hasValidHandshake name = getTLSState >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ]--updateHandshake :: MonadTLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m ()-updateHandshake n f = do-	hasValidHandshake n-	modifyTLSState (\st -> st { stHandshake = maybe Nothing (Just . f) (stHandshake st) })--updateHandshakeDigest :: MonadTLSState m => Bytes -> m ()-updateHandshakeDigest content = updateHandshake "update digest" (\hs ->-	let (c1, c2) = case hstHandshakeDigest hs of-		Nothing                -> (initHash HashTypeSHA1, initHash HashTypeMD5)-		Just (sha1ctx, md5ctx) -> (sha1ctx, md5ctx) in-	let nc1 = updateHash c1 content in-	let nc2 = updateHash c2 content in-	hs { hstHandshakeDigest = Just (nc1, nc2) }-	)--getHandshakeDigest :: MonadTLSState m => Bool -> m Bytes-getHandshakeDigest client = do-	st <- getTLSState-	let hst = fromJust $ stHandshake st-	let (sha1ctx, md5ctx) = fromJust $ hstHandshakeDigest hst-	let msecret = fromJust $ hstMasterSecret hst-	return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret md5ctx sha1ctx--endHandshake :: MonadTLSState m => m ()-endHandshake = modifyTLSState (\st -> st { stHandshake = Nothing })

@@ -1,417 +0,0 @@--- |--- Module      : Network.TLS.Struct--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the Struct module contains all definitions and values of the TLS protocol----module Network.TLS.Struct-	( Bytes-	, Version(..)-	, ConnectionEnd(..)-	, CipherType(..)-	, CipherData(..)-	, Extension-	, EncryptedData(..)-	, CertificateType(..)-	, HashAlgorithm(..)-	, SignatureAlgorithm(..)-	, ProtocolType(..)-	, TLSError(..)-	, ServerDHParams(..)-	, ServerRSAParams(..)-	, ServerKeyXchgAlgorithmData(..)-	, Packet(..)-	, Header(..)-	, ServerRandom(..)-	, ClientRandom(..)-	, ClientKeyData(..)-	, serverRandom-	, clientRandom-	, FinishedData-	, Session(..)-	, AlertLevel(..)-	, AlertDescription(..)-	, HandshakeType(..)-	, Handshake(..)-	, numericalVer-	, verOfNum-	, TypeValuable, valOfType, valToType-	, packetType-	, typeOfHandshake-	) where--import Data.ByteString (ByteString, pack)-import Data.Word-import Data.Certificate.X509--type Bytes = ByteString--data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord)--data ConnectionEnd = ConnectionServer | ConnectionClient-data CipherType = CipherStream | CipherBlock | CipherAEAD--data CipherData = CipherData-	{ cipherDataContent :: Bytes-	, cipherDataMAC     :: Maybe Bytes-	, cipherDataPadding :: Maybe Bytes-	} deriving (Show,Eq)--data CertificateType =-	  CertificateType_RSA_Sign         -- TLS10-	| CertificateType_DSS_Sign         -- TLS10-	| CertificateType_RSA_Fixed_DH     -- TLS10-	| CertificateType_DSS_Fixed_DH     -- TLS10-	| CertificateType_RSA_Ephemeral_dh -- TLS12-	| CertificateType_DSS_Ephemeral_dh -- TLS12-	| CertificateType_fortezza_dms     -- TLS12-	| CertificateType_Unknown Word8-	deriving (Show,Eq)--data HashAlgorithm =-	  HashNone-	| HashMD5-	| HashSHA1-	| HashSHA224-	| HashSHA256-	| HashSHA384-	| HashSHA512-	| HashOther Word8-	deriving (Show,Eq)--data SignatureAlgorithm =-	  SignatureAnonymous-	| SignatureRSA-	| SignatureDSS-	| SignatureECDSA-	| SignatureOther Word8-	deriving (Show,Eq)--data ProtocolType =-	  ProtocolType_ChangeCipherSpec-	| ProtocolType_Alert-	| ProtocolType_Handshake-	| ProtocolType_AppData-	deriving (Eq, Show)--data TLSError =-	  Error_Misc String-	| Error_Certificate String-	| Error_Digest ([Word8], [Word8])-	| Error_Packet String-	| Error_Packet_Size_Mismatch (Int, Int)-	| Error_Internal_Packet_Remaining Int-	| Error_Internal_Packet_ByteProcessed Int Int Int-	| Error_Unknown_Version Word8 Word8-	| Error_Unknown_Type String-	deriving (Eq, Show)--data Packet =-	  Handshake Handshake-	| Alert (AlertLevel, AlertDescription)-	| ChangeCipherSpec-	| AppData ByteString-	deriving (Show,Eq)--data Header = Header ProtocolType Version Word16 deriving (Show, Eq)--newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq)-newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq)-newtype ClientKeyData = ClientKeyData Bytes deriving (Show, Eq)-newtype Session = Session (Maybe Bytes) deriving (Show, Eq)-type CipherID = Word16-type CompressionID = Word8-type FinishedData = [Word8]-type Extension = (Word16, [Word8])--constrRandom32 :: (Bytes -> a) -> [Word8] -> Maybe a-constrRandom32 constr l = if length l == 32 then Just (constr $ pack l) else Nothing--serverRandom :: [Word8] -> Maybe ServerRandom-serverRandom l = constrRandom32 ServerRandom l--clientRandom :: [Word8] -> Maybe ClientRandom-clientRandom l = constrRandom32 ClientRandom l--newtype EncryptedData = EncryptedData ByteString-	deriving (Show)--data AlertLevel =-	  AlertLevel_Warning-	| AlertLevel_Fatal-	deriving (Show,Eq)--data AlertDescription =-	  CloseNotify-	| UnexpectedMessage-	| BadRecordMac-	| DecryptionFailed-	| RecordOverflow-	| DecompressionFailure-	| HandshakeFailure-	| BadCertificate-	| UnsupportedCertificate-	| CertificateRevoked-	| CertificateExpired-	| CertificateUnknown-	| IllegalParameter-	| UnknownCa-	| AccessDenied-	| DecodeError-	| DecryptError-	| ExportRestriction-	| ProtocolVersion-	| InsufficientSecurity-	| InternalError-	| UserCanceled-	| NoRenegotiation-	deriving (Show,Eq)--data HandshakeType =-	  HandshakeType_HelloRequest-	| HandshakeType_ClientHello-	| HandshakeType_ServerHello-	| HandshakeType_Certificate-	| HandshakeType_ServerKeyXchg-	| HandshakeType_CertRequest-	| HandshakeType_ServerHelloDone-	| HandshakeType_CertVerify-	| HandshakeType_ClientKeyXchg-	| HandshakeType_Finished-	deriving (Show,Eq)--data ServerDHParams = ServerDHParams-	{ dh_p  :: Integer -- ^ prime modulus-	, dh_g  :: Integer -- ^ generator-	, dh_Ys :: Integer -- ^ public value (g^X mod p)-	} deriving (Show,Eq)--data ServerRSAParams = ServerRSAParams-	{ rsa_modulus  :: Integer-	, rsa_exponent :: Integer-	} deriving (Show,Eq)--data ServerKeyXchgAlgorithmData =-	  SKX_DH_Anon ServerDHParams-	| SKX_DHE_DSS ServerDHParams [Word8]-	| SKX_DHE_RSA ServerDHParams [Word8]-	| SKX_RSA (Maybe ServerRSAParams)-	| SKX_DH_DSS (Maybe ServerRSAParams)-	| SKX_DH_RSA (Maybe ServerRSAParams)-	deriving (Show,Eq)--data Handshake =-	  ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] (Maybe [Extension])-	| ServerHello !Version !ServerRandom !Session !CipherID !CompressionID (Maybe [Extension])-	| Certificates [Certificate]-	| HelloRequest-	| ServerHelloDone-	| ClientKeyXchg Version ClientKeyData-	| ServerKeyXchg ServerKeyXchgAlgorithmData-	| CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8]-	| CertVerify [Word8]-	| Finished FinishedData-	deriving (Show,Eq)--packetType :: Packet -> ProtocolType-packetType (Handshake _)    = ProtocolType_Handshake-packetType (Alert _)        = ProtocolType_Alert-packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec-packetType (AppData _)      = ProtocolType_AppData--typeOfHandshake :: Handshake -> HandshakeType-typeOfHandshake (ClientHello _ _ _ _ _ _) = HandshakeType_ClientHello-typeOfHandshake (ServerHello _ _ _ _ _ _) = HandshakeType_ServerHello-typeOfHandshake (Certificates _)          = HandshakeType_Certificate-typeOfHandshake (HelloRequest)            = HandshakeType_HelloRequest-typeOfHandshake (ServerHelloDone)         = HandshakeType_ServerHelloDone-typeOfHandshake (ClientKeyXchg _ _)       = HandshakeType_ClientKeyXchg-typeOfHandshake (ServerKeyXchg _)         = HandshakeType_ServerKeyXchg-typeOfHandshake (CertRequest _ _ _)       = HandshakeType_CertRequest-typeOfHandshake (CertVerify _)            = HandshakeType_CertVerify-typeOfHandshake (Finished _)              = HandshakeType_Finished--numericalVer :: Version -> (Word8, Word8)-numericalVer SSL2  = (2, 0)-numericalVer SSL3  = (3, 0)-numericalVer TLS10 = (3, 1)-numericalVer TLS11 = (3, 2)-numericalVer TLS12 = (3, 3)--verOfNum :: (Word8, Word8) -> Maybe Version-verOfNum (2, 0) = Just SSL2-verOfNum (3, 0) = Just SSL3-verOfNum (3, 1) = Just TLS10-verOfNum (3, 2) = Just TLS11-verOfNum (3, 3) = Just TLS12-verOfNum _      = Nothing--class TypeValuable a where-	valOfType :: a -> Word8-	valToType :: Word8 -> Maybe a--instance TypeValuable ConnectionEnd where-	valOfType ConnectionServer = 0-	valOfType ConnectionClient = 1--	valToType 0 = Just ConnectionServer-	valToType 1 = Just ConnectionClient-	valToType _ = Nothing--instance TypeValuable CipherType where-	valOfType CipherStream = 0-	valOfType CipherBlock  = 1-	valOfType CipherAEAD   = 2--	valToType 0 = Just CipherStream-	valToType 1 = Just CipherBlock-	valToType 2 = Just CipherAEAD-	valToType _ = Nothing--instance TypeValuable ProtocolType where-	valOfType ProtocolType_ChangeCipherSpec = 20-	valOfType ProtocolType_Alert            = 21-	valOfType ProtocolType_Handshake        = 22-	valOfType ProtocolType_AppData          = 23--	valToType 20 = Just ProtocolType_ChangeCipherSpec-	valToType 21 = Just ProtocolType_Alert-	valToType 22 = Just ProtocolType_Handshake-	valToType 23 = Just ProtocolType_AppData-	valToType _  = Nothing--instance TypeValuable HandshakeType where-	valOfType HandshakeType_HelloRequest    = 0-	valOfType HandshakeType_ClientHello     = 1-	valOfType HandshakeType_ServerHello     = 2-	valOfType HandshakeType_Certificate     = 11-	valOfType HandshakeType_ServerKeyXchg   = 12-	valOfType HandshakeType_CertRequest     = 13-	valOfType HandshakeType_ServerHelloDone = 14-	valOfType HandshakeType_CertVerify      = 15-	valOfType HandshakeType_ClientKeyXchg   = 16-	valOfType HandshakeType_Finished        = 20--	valToType 0  = Just HandshakeType_HelloRequest-	valToType 1  = Just HandshakeType_ClientHello-	valToType 2  = Just HandshakeType_ServerHello-	valToType 11 = Just HandshakeType_Certificate-	valToType 12 = Just HandshakeType_ServerKeyXchg-	valToType 13 = Just HandshakeType_CertRequest-	valToType 14 = Just HandshakeType_ServerHelloDone-	valToType 15 = Just HandshakeType_CertVerify-	valToType 16 = Just HandshakeType_ClientKeyXchg-	valToType 20 = Just HandshakeType_Finished-	valToType _  = Nothing--instance TypeValuable AlertLevel where-	valOfType AlertLevel_Warning = 1-	valOfType AlertLevel_Fatal   = 2--	valToType 1 = Just AlertLevel_Warning-	valToType 2 = Just AlertLevel_Fatal-	valToType _ = Nothing--instance TypeValuable AlertDescription where-	valOfType CloseNotify            = 0-	valOfType UnexpectedMessage      = 10-	valOfType BadRecordMac           = 20-	valOfType DecryptionFailed       = 21-	valOfType RecordOverflow         = 22-	valOfType DecompressionFailure   = 30-	valOfType HandshakeFailure       = 40-	valOfType BadCertificate         = 42-	valOfType UnsupportedCertificate = 43-	valOfType CertificateRevoked     = 44-	valOfType CertificateExpired     = 45-	valOfType CertificateUnknown     = 46-	valOfType IllegalParameter       = 47-	valOfType UnknownCa              = 48-	valOfType AccessDenied           = 49-	valOfType DecodeError            = 50-	valOfType DecryptError           = 51-	valOfType ExportRestriction      = 60-	valOfType ProtocolVersion        = 70-	valOfType InsufficientSecurity   = 71-	valOfType InternalError          = 80-	valOfType UserCanceled           = 90-	valOfType NoRenegotiation        = 100--	valToType 0   = Just CloseNotify-	valToType 10  = Just UnexpectedMessage-	valToType 20  = Just BadRecordMac-	valToType 21  = Just DecryptionFailed-	valToType 22  = Just RecordOverflow-	valToType 30  = Just DecompressionFailure-	valToType 40  = Just HandshakeFailure-	valToType 42  = Just BadCertificate-	valToType 43  = Just UnsupportedCertificate-	valToType 44  = Just CertificateRevoked-	valToType 45  = Just CertificateExpired-	valToType 46  = Just CertificateUnknown-	valToType 47  = Just IllegalParameter-	valToType 48  = Just UnknownCa-	valToType 49  = Just AccessDenied-	valToType 50  = Just DecodeError-	valToType 51  = Just DecryptError-	valToType 60  = Just ExportRestriction-	valToType 70  = Just ProtocolVersion-	valToType 71  = Just InsufficientSecurity-	valToType 80  = Just InternalError-	valToType 90  = Just UserCanceled-	valToType 100 = Just NoRenegotiation-	valToType _   = Nothing--instance TypeValuable CertificateType where-	valOfType CertificateType_RSA_Sign         = 1-	valOfType CertificateType_DSS_Sign         = 2-	valOfType CertificateType_RSA_Fixed_DH     = 3-	valOfType CertificateType_DSS_Fixed_DH     = 4-	valOfType CertificateType_RSA_Ephemeral_dh = 5-	valOfType CertificateType_DSS_Ephemeral_dh = 6-	valOfType CertificateType_fortezza_dms     = 20-	valOfType (CertificateType_Unknown i)      = i--	valToType 1  = Just CertificateType_RSA_Sign-	valToType 2  = Just CertificateType_DSS_Sign-	valToType 3  = Just CertificateType_RSA_Fixed_DH-	valToType 4  = Just CertificateType_DSS_Fixed_DH-	valToType 5  = Just CertificateType_RSA_Ephemeral_dh-	valToType 6  = Just CertificateType_DSS_Ephemeral_dh-	valToType 20 = Just CertificateType_fortezza_dms-	valToType i  = Just (CertificateType_Unknown i)--instance TypeValuable HashAlgorithm where-	valOfType HashNone      = 0-	valOfType HashMD5       = 1-	valOfType HashSHA1      = 2-	valOfType HashSHA224    = 3-	valOfType HashSHA256    = 4-	valOfType HashSHA384    = 5-	valOfType HashSHA512    = 6-	valOfType (HashOther i) = i--	valToType 0 = Just HashNone-	valToType 1 = Just HashMD5-	valToType 2 = Just HashSHA1-	valToType 3 = Just HashSHA224-	valToType 4 = Just HashSHA256-	valToType 5 = Just HashSHA384-	valToType 6 = Just HashSHA512-	valToType i = Just (HashOther i)--instance TypeValuable SignatureAlgorithm where-	valOfType SignatureAnonymous = 0-	valOfType SignatureRSA       = 1-	valOfType SignatureDSS       = 2-	valOfType SignatureECDSA     = 3-	valOfType (SignatureOther i) = i--	valToType 0 = Just SignatureAnonymous-	valToType 1 = Just SignatureRSA-	valToType 2 = Just SignatureDSS-	valToType 3 = Just SignatureECDSA-	valToType i = Just (SignatureOther i)

@@ -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)

@@ -1,138 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving,FlexibleInstances #-}---- |--- Module      : Network.TLS.Wire--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unknown------ the Wire module is a specialized Binary package related to the TLS protocol.--- all multibytes values are written as big endian.----module Network.TLS.Wire-	( Get-	, runGet-	, remaining-	, bytesRead-	, getWord8-	, getWords8-	, getWord16-	, getWords16-	, getWord24-	, getBytes-	, processBytes-	, isEmpty-	, Put-	, runPut-	, putWord8-	, putWords8-	, putWord16-	, putWords16-	, putWord24-	, putBytes-	, encodeWord64-	) where--import qualified Data.Binary.Get as G-import qualified Data.Binary.Put as P-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Control.Applicative ((<$>))-import Control.Monad.Error-import Data.Word-import Data.Bits-import Network.TLS.Struct--instance Error TLSError where-	noMsg = Error_Misc ""-	strMsg = Error_Misc--newtype Get a = GE { runGE :: ErrorT TLSError G.Get a }-	deriving (Monad, MonadError TLSError)--instance Functor Get where-	fmap f = GE . fmap f . runGE--liftGet :: G.Get a -> Get a-liftGet = GE . lift--runGet :: Get a -> Bytes -> Either TLSError a-runGet f b = G.runGet (runErrorT (runGE f)) (L.fromChunks [b])--remaining :: Get Int-remaining = fromIntegral <$> liftGet G.remaining--bytesRead :: Get Int-bytesRead = fromIntegral <$> liftGet G.bytesRead--getWord8 :: Get Word8-getWord8 = liftGet G.getWord8--getWords8 :: Get [Word8]-getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8--getWord16 :: Get Word16-getWord16 = liftGet G.getWord16be--getWords16 :: Get [Word16]-getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16--getWord24 :: Get Int-getWord24 = do-	a <- fromIntegral <$> getWord8-	b <- fromIntegral <$> getWord8-	c <- fromIntegral <$> getWord8-	return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c--getBytes :: Int -> Get Bytes-getBytes i = liftGet $ G.getBytes i--processBytes :: Int -> Get a -> Get a-processBytes i f = do-	r1 <- bytesRead-	ret <- f-	r2 <- bytesRead-	if r2 == (r1 + i)-		then return ret-		else throwError (Error_Internal_Packet_ByteProcessed r1 r2 i)-	-isEmpty :: Get Bool-isEmpty = liftGet G.isEmpty--type Put = P.Put--putWord8 :: Word8 -> Put-putWord8 = P.putWord8--putWords8 :: [Word8] -> Put-putWords8 l = do-	P.putWord8 $ fromIntegral (length l)-	mapM_ P.putWord8 l--putWord16 :: Word16 -> Put-putWord16 = P.putWord16be--putWords16 :: [Word16] -> Put-putWords16 l = do-	putWord16 $ 2 * (fromIntegral $ length l)-	mapM_ putWord16 l--putWord24 :: Int -> Put-putWord24 i = do-	let a = fromIntegral ((i `shiftR` 16) .&. 0xff)-	let b = fromIntegral ((i `shiftR` 8) .&. 0xff)-	let c = fromIntegral (i .&. 0xff)-	mapM_ P.putWord8 [a,b,c]--putBytes :: Bytes -> Put-putBytes = P.putByteString--lazyToBytes :: L.ByteString -> Bytes-lazyToBytes = B.concat . L.toChunks--runPut :: Put -> Bytes-runPut = lazyToBytes . P.runPut--encodeWord64 :: Word64 -> Bytes-encodeWord64 = runPut . P.putWord64be

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMain

@@ -1,5 +1,5 @@ name:            http-enumerator-version:         0.1.1+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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