diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -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 diff --git a/Network/TLS/Client.hs b/Network/TLS/Client.hs --- a/Network/TLS/Client.hs +++ b/Network/TLS/Client.hs @@ -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 = diff --git a/Network/TLS/SRandom.hs b/Network/TLS/SRandom.hs --- a/Network/TLS/SRandom.hs +++ b/Network/TLS/SRandom.hs @@ -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 diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs --- a/Network/TLS/Server.hs +++ b/Network/TLS/Server.hs @@ -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 diff --git a/Stunnel.hs b/Stunnel.hs --- a/Stunnel.hs +++ b/Stunnel.hs @@ -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] " - 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 diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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 diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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