tls 0.3.1 → 0.3.2
raw patch · 8 files changed
+213/−206 lines, 8 filesdep +cmdargsdep −haskell98dep ~certificate
Dependencies added: cmdargs
Dependencies removed: haskell98
Dependency ranges changed: certificate
Files
- Network/TLS/Cipher.hs +5/−0
- Network/TLS/Client.hs +8/−3
- Network/TLS/SRandom.hs +0/−2
- Network/TLS/Server.hs +4/−1
- Stunnel.hs +185/−79
- TODO +1/−9
- Tests.hs +6/−109
- tls.cabal +4/−3
Network/TLS/Cipher.hs view
@@ -9,6 +9,8 @@ ( CipherTypeFunctions(..) , CipherKeyExchangeType(..) , Cipher(..)+ , Key+ , IV , cipherExchangeNeedMoreData -- * builtin ciphers for ease of use, might move later to a tls-ciphers library@@ -74,6 +76,9 @@ instance Show Cipher where show c = cipherName c++instance Eq Cipher where+ (==) c1 c2 = cipherID c1 == cipherID c2 cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool cipherExchangeNeedMoreData CipherKeyExchangeRSA = False
Network/TLS/Client.hs view
@@ -20,6 +20,7 @@ , recvPacket , sendPacket -- * API, warning probably subject to change+ , initiate , connect , sendData , recvData@@ -156,9 +157,9 @@ cf <- getHandshakeDigest True sendPacket handle (Handshake $ Finished $ B.unpack cf) -{- | connect through a handle as a new TLS connection. -}-connect :: Handle -> TLSClient IO ()-connect handle = do+{- | initiate a new TLS connection through a handshake on a handle. -}+initiate :: Handle -> TLSClient IO ()+initiate handle = do connectSendClientHello handle recvServerInfo handle connectSendClientCertificate handle@@ -181,6 +182,10 @@ _ <- recvPacket handle return ()++{-# DEPRECATED connect "use initiate" #-}+connect :: Handle -> TLSClient IO ()+connect = initiate sendDataChunk :: Handle -> B.ByteString -> TLSClient IO () sendDataChunk handle d =
Network/TLS/SRandom.hs view
@@ -1,5 +1,3 @@--- 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
Network/TLS/Server.hs view
@@ -55,6 +55,9 @@ instance Show TLSServerCallbacks where show _ = "[callbacks]" +instance Show CertificateKey.PrivateKey where+ show _ = "[privatekey]"+ data TLSServerParams = TLSServerParams { spAllowedVersions :: [Version] -- ^ allowed versions that we can use , spSessions :: [[Word8]] -- ^ placeholder for futur known sessions@@ -62,7 +65,7 @@ , spCertificate :: Maybe TLSServerCert -- ^ the certificate we serve to the client , spWantClientCert :: Bool -- ^ configure if we do a cert request to the client , spCallbacks :: TLSServerCallbacks -- ^ user callbacks- }+ } deriving (Show) data TLSStateServer = TLSStateServer { scParams :: TLSServerParams -- ^ server params and config for this connection
Stunnel.hs view
@@ -1,20 +1,19 @@-import Network+{-# LANGUAGE DeriveDataTypeable #-}+import Network.BSD+import Network.Socket import System.IO-import System+import System.IO.Error hiding (try)+import System.Console.CmdArgs import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as LC -import Control.Applicative ((<$>)) import Control.Concurrent (forkIO)-import Control.Exception (bracket)-import Control.Monad (forM_, when, replicateM)+import Control.Exception (finally, try, throw)+import Control.Monad (when, forever) import Control.Monad.Trans (lift) -import Data.Word-import Data.Bits-import Data.Maybe+import Data.Char (isDigit) import Data.Certificate.PEM import Data.Certificate.X509@@ -23,7 +22,6 @@ import Network.TLS.Cipher import Network.TLS.SRandom import Network.TLS.Struct-import Network.TLS.MAC import qualified Network.TLS.Client as C import qualified Network.TLS.Server as S@@ -36,59 +34,57 @@ , cipher_RC4_128_SHA1 ] -conv :: [Word8] -> Int-conv l = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d- where- [a,b,c,d] = map fromIntegral l+loopUntil :: Monad m => m Bool -> m ()+loopUntil f = f >>= \v -> if v then return () else loopUntil f -tlsclient handle = do- C.connect handle- C.sendData handle (L.pack $ map (toEnum.fromEnum) "GET / HTTP/1.0\r\n\r\n")+readOne h = do+ r <- try $ hWaitForInput h (-1)+ case r of+ Left err -> if isEOFError err then return B.empty else throw err+ Right True -> B.hGetNonBlocking h 4096+ Right False -> return B.empty - d <- C.recvData handle- lift $ L.putStrLn d+tlsclient :: Handle -> Handle -> C.TLSClient IO ()+tlsclient srchandle dsthandle = do+ lift $ hSetBuffering dsthandle NoBuffering+ lift $ hSetBuffering srchandle NoBuffering - d <- C.recvData handle- lift $ L.putStrLn d+ C.initiate dsthandle + loopUntil $ do+ b <- lift $ readOne srchandle+ lift $ putStrLn ("sending " ++ show b)+ if B.null b+ then do+ C.close dsthandle+ return True+ else do+ C.sendData dsthandle (L.fromChunks [b])+ return False return () getRandomGen :: IO SRandomGen getRandomGen = makeSRandomGen >>= either (fail . show) (return . id) -mainClient :: String -> Int -> IO ()-mainClient host port = do- rng <- getRandomGen-- handle <- connectTo host (PortNumber $ fromIntegral port)- hSetBuffering handle NoBuffering-- let clientstate = C.TLSClientParams- { C.cpConnectVersion = TLS10- , C.cpAllowedVersions = [ TLS10, TLS11 ]- , C.cpSession = Nothing- , C.cpCiphers = ciphers- , C.cpCertificate = Nothing- , C.cpCallbacks = C.TLSClientCallbacks- { C.cbCertificates = Nothing- }- }- C.runTLSClient (tlsclient handle) clientstate rng+tlsserver srchandle dsthandle = do+ lift $ hSetBuffering dsthandle NoBuffering+ lift $ hSetBuffering srchandle NoBuffering - putStrLn "end"+ S.listen srchandle -tlsserver handle = do- S.listen handle- _ <- S.recvData handle- S.sendData handle (LC.pack "this is some data")- lift $ hFlush handle+ loopUntil $ do+ d <- S.recvData srchandle+ lift $ putStrLn ("received: " ++ show d)+ S.sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data")+ lift $ hFlush srchandle+ return False lift $ putStrLn "end" -clientProcess ((certdata, cert), pk) (handle, src) = do+clientProcess ((certdata, cert), pk) handle dsthandle _ = do rng <- getRandomGen let serverstate = S.TLSServerParams- { S.spAllowedVersions = [TLS10,TLS11]+ { S.spAllowedVersions = [SSL3,TLS10,TLS11] , S.spSessions = [] , S.spCiphers = ciphers , S.spCertificate = Just (certdata, cert, pk)@@ -97,20 +93,7 @@ { S.cbCertificates = Nothing } } - S.runTLSServer (tlsserver handle) serverstate rng- putStrLn "end"--mainServerAccept cert port socket = do- (h, d, _) <- accept socket- forkIO $ clientProcess cert (h, d)- mainServerAccept cert port socket--mainServer cert port = bracket (listenOn (PortNumber port)) (sClose) (mainServerAccept cert port)--usage :: IO ()-usage = do- putStrLn "usage: stunnel [client|server] <params...>"- exitFailure+ S.runTLSServer (tlsserver handle dsthandle) serverstate rng readCertificate :: FilePath -> IO (B.ByteString, Certificate) readCertificate filepath = do@@ -134,22 +117,145 @@ Right x -> x return (pkdata, pk) +data Stunnel =+ Client+ { destinationType :: String+ , destination :: String+ , sourceType :: String+ , source :: String }+ | Server+ { destinationType :: String+ , destination :: String+ , sourceType :: String+ , source :: String+ , certificate :: FilePath+ , key :: FilePath }+ deriving (Show, Data, Typeable)++clientOpts = Client+ { destinationType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "DESTTYPE"+ , destination = "localhost:6061" &= help "destination address influenced by destination type" &= typ "ADDRESS"+ , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE"+ , source = "localhost:6060" &= help "source address influenced by source type" &= typ "ADDRESS"+ }+ &= help "connect to a remote destination that use SSL/TLS"++serverOpts = Server+ { destinationType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "DESTTYPE"+ , destination = "localhost:6060" &= help "destination address influenced by destination type" &= typ "ADDRESS"+ , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE"+ , source = "localhost:6061" &= help "source address influenced by source type" &= typ "ADDRESS"+ , certificate = "certificate.pem" &= help "X509 public certificate to use" &= typ "FILE"+ , key = "certificate.key" &= help "private key linked to the certificate" &= typ "FILE"+ }+ &= help "listen for connection that use SSL/TLS and relay it to a different connection"++mode = cmdArgsMode $ modes [clientOpts,serverOpts]+ &= help "create SSL/TLS tunnel in client or server mode" &= program "stunnel" &= summary "Stunnel v0.1 (Haskell TLS)"++data StunnelAddr =+ AddrSocket Family SockAddr+ | AddrFD Handle Handle++data StunnelHandle =+ StunnelSocket Socket+ | StunnelFd Handle Handle++getAddressDescription :: String -> String -> IO StunnelAddr+getAddressDescription "tcp" desc = do+ let (s, p) = break ((==) ':') desc+ when (p == "") (error "missing port: expecting [source]:port")+ pn <- if and $ map isDigit $ drop 1 p+ then return $ fromIntegral $ (read (drop 1 p) :: Int)+ else do+ service <- getServiceByName (drop 1 p) "tcp"+ return $ servicePort service+ he <- getHostByName s+ return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he))++getAddressDescription "unix" desc = do+ return $ AddrSocket AF_UNIX (SockAddrUnix desc)++getAddressDescription "fd" _ =+ return $ AddrFD stdin stdout++getAddressDescription _ _ = error "unrecognized source type (expecting tcp/unix/fd)"++connectAddressDescription (AddrSocket family sockaddr) = do+ sock <- socket family Stream defaultProtocol+ catch (connect sock sockaddr)+ (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))+ return $ StunnelSocket sock++connectAddressDescription (AddrFD h1 h2) = do+ return $ StunnelFd h1 h2++listenAddressDescription (AddrSocket family sockaddr) = do+ sock <- socket family Stream defaultProtocol+ catch (bindSocket sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1)+ (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))+ return $ StunnelSocket sock++listenAddressDescription (AddrFD _ _) = do+ error "cannot listen on fd"++doClient :: Stunnel -> IO ()+doClient pargs = do+ srcaddr <- getAddressDescription (sourceType pargs) (source pargs)+ dstaddr <- getAddressDescription (destinationType pargs) (destination pargs)++ let clientstate = C.TLSClientParams+ { C.cpConnectVersion = TLS10+ , C.cpAllowedVersions = [ TLS10, TLS11 ]+ , C.cpSession = Nothing+ , C.cpCiphers = ciphers+ , C.cpCertificate = Nothing+ , C.cpCallbacks = C.TLSClientCallbacks+ { C.cbCertificates = Nothing+ }+ }++ case srcaddr of+ AddrSocket _ _ -> do+ (StunnelSocket srcsocket) <- listenAddressDescription srcaddr+ forever $ do+ (s, _) <- accept srcsocket+ rng <- getRandomGen+ srch <- socketToHandle s ReadWriteMode++ (StunnelSocket dst) <- connectAddressDescription dstaddr++ dsth <- socketToHandle dst ReadWriteMode+ _ <- forkIO $ finally+ (C.runTLSClient (tlsclient srch dsth) clientstate rng >> return ())+ (hClose srch >> hClose dsth)+ return ()+ AddrFD _ _ -> error "bad error fd. not implemented"++doServer :: Stunnel -> IO ()+doServer pargs = do+ cert <- readCertificate $ certificate pargs+ pk <- readPrivateKey $ key pargs+ srcaddr <- getAddressDescription (sourceType pargs) (source pargs)+ dstaddr <- getAddressDescription (destinationType pargs) (destination pargs)++ case srcaddr of+ AddrSocket _ _ -> do+ (StunnelSocket srcsocket) <- listenAddressDescription srcaddr+ forever $ do+ (s, addr) <- accept srcsocket+ srch <- socketToHandle s ReadWriteMode+ (StunnelSocket dst) <- connectAddressDescription dstaddr+ dsth <- socketToHandle dst ReadWriteMode+ _ <- forkIO $ finally+ (clientProcess (cert, snd pk) srch dsth addr >> return ())+ (hClose srch >> hClose dsth)+ return ()+ AddrFD _ _ -> error "bad error fd. not implemented"++main :: IO () main = do- args <- getArgs- when (length args == 0) usage- case (args !! 0) of- "server" -> do- cert <- readCertificate (args !! 1)- pk <- readPrivateKey (args !! 2)- mainServer (cert, snd pk) 6061- "client" -> do- let port =- if length args > 1- then read $ args !! 1- else 6061- let dest =- if length args > 2- then args !! 2- else "localhost"- mainClient dest port- _ -> usage+ x <- cmdArgsRun mode+ case x of+ Client _ _ _ _ -> doClient x+ Server _ _ _ _ _ _ -> doServer x
TODO view
@@ -20,11 +20,6 @@ - properly separate different version of the protocol - implement AEAD -ssl3:--- finish generation of stuff-- test with popular server- code cleanup: - remove show derivation on internal crypto state@@ -33,15 +28,12 @@ security audit: - add more unit tests for pure parts-- fix SRandomGen and random usage with proper CPRNG - match security recommendation from the RFC-- audit the RSA implementation and the usage in TLS (remove spoon). misc: -- stunnel: use crypto secure random generator - stunnel: actually make it works like stunnel instead of hardcoding the data received/sent-- investigate an iteratee interface+- investigate an iteratee/enumerator interface - portability - implement more ciphers - check & optimize memory footprint
Tests.hs view
@@ -1,113 +1,10 @@ {-# LANGUAGE CPP #-}-import Text.Printf-import Data.Word-import Test.QuickCheck-import Test.QuickCheck.Test -import qualified Data.ByteString as B-import Network.TLS.Struct-import Network.TLS.Packet-import Control.Monad-import Control.Applicative ((<$>))-import System.IO--liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) }--someWords8 :: Int -> Gen [Word8] -someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))--someWords16 :: Int -> Gen [Word16] -someWords16 i = replicateM i (fromIntegral <$> (choose (0,65535) :: Gen Int))--instance Arbitrary Version where- arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ]--instance Arbitrary ProtocolType where- arbitrary = elements- [ ProtocolType_ChangeCipherSpec- , ProtocolType_Alert- , ProtocolType_Handshake- , ProtocolType_AppData ]--#if MIN_VERSION_QuickCheck(2,3,0)-#else-instance Arbitrary Word8 where- arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int)--instance Arbitrary Word16 where- arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int)-#endif--instance Arbitrary Header where- arbitrary = do- pt <- arbitrary- ver <- arbitrary- len <- arbitrary- return $ Header pt ver len--instance Arbitrary ClientRandom where- arbitrary = ClientRandom . B.pack <$> someWords8 32--instance Arbitrary ServerRandom where- arbitrary = ServerRandom . B.pack <$> someWords8 32--instance Arbitrary ClientKeyData where- arbitrary = ClientKeyData . B.pack <$> someWords8 46--instance Arbitrary Session where- arbitrary = do- i <- choose (1,2) :: Gen Int- case i of- 1 -> return $ Session Nothing- 2 -> Session . Just . B.pack <$> someWords8 32--arbitraryCiphersIDs :: Gen [Word16]-arbitraryCiphersIDs = choose (0,200) >>= someWords16--arbitraryCompressionIDs :: Gen [Word8]-arbitraryCompressionIDs = choose (0,200) >>= someWords8--instance Arbitrary CertificateType where- arbitrary = elements- [ CertificateType_RSA_Sign, CertificateType_DSS_Sign- , CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH- , CertificateType_RSA_Ephemeral_dh, CertificateType_DSS_Ephemeral_dh- , CertificateType_fortezza_dms ]--instance Arbitrary Handshake where- arbitrary = oneof- [ liftM6 ClientHello arbitrary arbitrary arbitrary arbitraryCiphersIDs arbitraryCompressionIDs (return Nothing)- , liftM6 ServerHello arbitrary arbitrary arbitrary arbitrary arbitrary (return Nothing)- , return (Certificates [])- , return HelloRequest- , return ServerHelloDone- , liftM2 ClientKeyXchg arbitrary arbitrary- --, liftM ServerKeyXchg- --, liftM3 CertRequest arbitrary (return Nothing) (return [])- --, liftM CertVerify (return [])- , liftM Finished (someWords8 12)- ]--{- quickcheck property -}--prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x-prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x- where- decodeHs b = either (Left . id) (uncurry (decodeHandshake TLS10) . head) $ decodeHandshakes b--{- main -}-args = Args- { replay = Nothing- , maxSuccess = 500- , maxDiscard = 2000- , maxSize = 500-#if MIN_VERSION_QuickCheck(2,3,0)- , chatty = True-#endif- }--run_test n t = putStr (" " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith args t+import qualified Tests.Marshal as Marshal+import qualified Tests.Connection as Connection+import qualified Tests.Ciphers as Ciphers main = do- run_test "marshalling header = id" prop_header_marshalling_id- run_test "marshalling handshake = id" prop_handshake_marshalling_id+ Marshal.runTests+ Ciphers.runTests+ Connection.runTests
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.3.1+Version: 0.3.2 Description: native TLS protocol implementation, focusing on purity and more type-checking. .@@ -40,7 +40,7 @@ AES, crypto-api >= 0.2, cryptocipher >= 0.2,- certificate >= 0.3.2+ certificate >= 0.4 && < 0.5 Exposed-modules: Network.TLS.Client Network.TLS.Server Network.TLS.Struct@@ -61,10 +61,11 @@ Executable stunnel Main-is: Stunnel.hs if flag(executable)- Build-Depends: network, haskell98+ Build-Depends: network, cmdargs Buildable: True else Buildable: False+ ghc-options: -Wall -fno-warn-missing-signatures executable Tests Main-is: Tests.hs