diff --git a/Network/TLS/Client.hs b/Network/TLS/Client.hs --- a/Network/TLS/Client.hs +++ b/Network/TLS/Client.hs @@ -12,7 +12,9 @@ -- module Network.TLS.Client ( TLSClientParams(..) + , TLSClientCallbacks(..) , TLSStateClient + , TLSClient (..) , runTLSClient -- * low level packet sending receiving. , recvPacket @@ -26,6 +28,7 @@ import Data.Maybe import Data.Word +import Control.Applicative ((<$>)) import Control.Monad.Trans import Control.Monad.State import Data.Certificate.X509 @@ -40,12 +43,20 @@ import System.IO (Handle, hFlush) import Data.List (find) +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 + { 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 @@ -92,8 +103,9 @@ recvServerHello :: Handle -> TLSClient IO () recvServerHello handle = do - ciphers <- fmap (cpCiphers . scParams) get - allowedvers <- fmap (cpAllowedVersions . scParams) get + ciphers <- cpCiphers . scParams <$> get + allowedvers <- cpAllowedVersions . scParams <$> get + callbacks <- cpCallbacks . scParams <$> get pkt <- recvPacket handle let hs = case pkt of Right (Handshake h) -> h @@ -109,27 +121,30 @@ Nothing -> error "no cipher in common with the server" Just c -> setCipher c recvServerHello handle - CertRequest _ _ _ -> modify (\sc -> sc { scCertRequested = True }) >> recvServerHello handle - Certificates _ -> recvServerHello handle - ServerHelloDone -> return () - _ -> error "unexpected handshake message received in server hello messages" + CertRequest _ _ _ -> modify (\sc -> sc { scCertRequested = True }) >> recvServerHello handle + Certificates certs -> do + valid <- lift $ maybe (return True) (\cb -> cb certs) (cbCertificates callbacks) + unless valid $ error "certificates received deemed invalid by user" + recvServerHello handle + ServerHelloDone -> return () + _ -> error "unexpected handshake message received in server hello messages" connectSendClientHello :: Handle -> ClientRandom -> TLSClient IO () connectSendClientHello handle crand = do - ver <- fmap (cpConnectVersion . scParams) get - ciphers <- fmap (cpCiphers . scParams) get + ver <- cpConnectVersion . scParams <$> get + ciphers <- cpCiphers . scParams <$> get sendPacket handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing) connectSendClientCertificate :: Handle -> TLSClient IO () connectSendClientCertificate handle = do - certRequested <- fmap scCertRequested get + certRequested <- scCertRequested <$> get when certRequested $ do - clientCert <- fmap (cpCertificate . scParams) get + clientCert <- cpCertificate . scParams <$> get sendPacket handle $ Handshake (Certificates $ maybe [] (:[]) clientCert) -connectSendClientKeyXchg :: Handle -> [Word8] -> TLSClient IO () +connectSendClientKeyXchg :: Handle -> ClientKeyData -> TLSClient IO () connectSendClientKeyXchg handle prerand = do - ver <- fmap (cpConnectVersion . scParams) get + ver <- cpConnectVersion . scParams <$> get sendPacket handle $ Handshake (ClientKeyXchg ver prerand) connectSendFinish :: Handle -> TLSClient IO () @@ -138,7 +153,7 @@ sendPacket handle (Handshake $ Finished $ L.unpack cf) {- | connect through a handle as a new TLS connection. -} -connect :: Handle -> ClientRandom -> [Word8] -> TLSClient IO () +connect :: Handle -> ClientRandom -> ClientKeyData -> TLSClient IO () connect handle crand premasterRandom = do connectSendClientHello handle crand recvServerHello handle @@ -194,7 +209,7 @@ let (premaster, rng'') = getRandomBytes rng' 46 putTLSState $ st { stRandomGen = rng'' } let crand = fromJust $ clientRandom bytes - connect handle crand premaster + connect handle crand (ClientKeyData premaster) recvData handle Left err -> error ("error received: " ++ show err) _ -> error "unexpected item" diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -40,6 +40,7 @@ import Network.TLS.Wire import Data.Either (partitionEithers) import Data.Maybe (fromJust, isNothing) +import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.Error import Network.TLS.Struct @@ -167,19 +168,19 @@ getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ] getSignatureHashAlgorithm 0 = return [] getSignatureHashAlgorithm len = do - h <- fmap (fromJust . valToType) getWord8 - s <- fmap (fromJust . valToType) getWord8 + h <- fromJust . valToType <$> getWord8 + s <- fromJust . valToType <$> getWord8 xs <- getSignatureHashAlgorithm (len - 2) return ((h, s) : xs) decodeCertRequest :: Version -> Get Handshake decodeCertRequest ver = do - certTypes <- fmap (map (fromJust . valToType . fromIntegral)) getWords8 + certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 sigHashAlgs <- if ver >= TLS12 then do sighashlen <- getWord16 - fmap Just $ getSignatureHashAlgorithm $ fromIntegral sighashlen + Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen) else return Nothing dNameLen <- getWord16 when (ver < TLS12 && dNameLen < 3) $ throwError (Error_Misc "certrequest distinguishname not of the correct size") @@ -194,7 +195,7 @@ decodeClientKeyXchg :: Get Handshake decodeClientKeyXchg = do ver <- getVersion - ran <- getRandom46 + ran <- getClientKeyData46 return $ ClientKeyXchg ver ran -- FIXME need to work out how we marshall an opaque number @@ -260,7 +261,7 @@ encodeHandshakeContent (ClientKeyXchg version random) = do putVersion version - putRandom46 random + putClientKeyData46 random encodeHandshakeContent (ServerKeyXchg _) = do -- FIXME @@ -295,13 +296,13 @@ {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get [Word8] -getRandom32 = fmap B.unpack $ getBytes 32 +getRandom32 = B.unpack <$> getBytes 32 getServerRandom32 :: Get ServerRandom -getServerRandom32 = fmap ServerRandom getRandom32 +getServerRandom32 = ServerRandom <$> getRandom32 getClientRandom32 :: Get ClientRandom -getClientRandom32 = fmap ClientRandom getRandom32 +getClientRandom32 = ClientRandom <$> getRandom32 putRandom32 :: [Word8] -> Put putRandom32 = mapM_ putWord8 @@ -312,18 +313,18 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r -getRandom46 :: Get [Word8] -getRandom46 = fmap B.unpack $ getBytes 46 +getClientKeyData46 :: Get ClientKeyData +getClientKeyData46 = ClientKeyData . B.unpack <$> getBytes 46 -putRandom46 :: [Word8] -> Put -putRandom46 = mapM_ putWord8 +putClientKeyData46 :: ClientKeyData -> Put +putClientKeyData46 (ClientKeyData d) = mapM_ putWord8 d getSession :: Get Session getSession = do len8 <- getWord8 case fromIntegral len8 of 0 -> return $ Session Nothing - len -> fmap (Session . Just . B.unpack) $ getBytes len + len -> Session . Just . B.unpack <$> getBytes len putSession :: Session -> Put putSession (Session session) = diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -14,6 +14,7 @@ readPacket ) where +import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.Maybe @@ -53,7 +54,7 @@ readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet) readPacket hdr@(Header ProtocolType_AppData _ _) content = - runTLSRead (fmap AppData $ decryptContent hdr content) + runTLSRead (AppData <$> decryptContent hdr content) readPacket hdr@(Header ProtocolType_Alert _ _) content = runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert) @@ -109,7 +110,7 @@ return econtent hs <- case (ty, decodeHandshake ver ty content) of (_, Right x) -> return x - (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 [] + (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ replicate 0xff 46) (_, Left err) -> throwError err clientmode <- isClientContext case hs of @@ -118,7 +119,7 @@ ServerHello sver ran _ _ _ _ -> when clientmode $ do setServerRandom ran setVersion sver - Certificates [cert] -> when clientmode $ do processCertificate cert + Certificates certs -> when clientmode $ do processCertificates certs ClientKeyXchg cver _ -> unless clientmode $ do processClientKeyXchg cver content Finished fdata -> processClientFinished fdata @@ -185,9 +186,9 @@ else contentpadded return content -processCertificate :: Certificate -> TLSRead () -processCertificate cert = do - case certPubKey cert of +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 diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -97,7 +97,7 @@ let g = stRandomGen st let rsakey = fromJust $ hstRSAPublicKey $ fromJust $ stHandshake st case rsaEncrypt g rsakey content of - Nothing -> return L.empty + Nothing -> fail "no RSA key selected" Just (econtent, g') -> do putTLSState (st { stRandomGen = g' }) return econtent diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs --- a/Network/TLS/Server.hs +++ b/Network/TLS/Server.hs @@ -12,6 +12,7 @@ module Network.TLS.Server ( TLSServerParams(..) + , TLSServerCallbacks(..) , TLSStateServer , runTLSServer -- * low level packet sending receiving. @@ -44,12 +45,20 @@ type TLSServerCert = (L.ByteString, Certificate, CertificateKey.PrivateKey) +data TLSServerCallbacks = TLSServerCallbacks + { cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates + } + +instance Show TLSServerCallbacks where + show _ = "[callbacks]" + data TLSServerParams = TLSServerParams { spAllowedVersions :: [Version] -- ^ allowed versions that we can use , spSessions :: [[Word8]] -- ^ placeholder for futur known sessions , spCiphers :: [Cipher] -- ^ all ciphers that the server side support , 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 } data TLSStateServer = TLSStateServer diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -25,6 +25,7 @@ , Header(..) , ServerRandom(..) , ClientRandom(..) + , ClientKeyData(..) , serverRandom , clientRandom , FinishedData @@ -108,6 +109,7 @@ newtype ServerRandom = ServerRandom [Word8] deriving (Show, Eq) newtype ClientRandom = ClientRandom [Word8] deriving (Show, Eq) +newtype ClientKeyData = ClientKeyData [Word8] deriving (Show, Eq) newtype Session = Session (Maybe [Word8]) deriving (Show, Eq) type CipherID = Word16 type CompressionID = Word8 @@ -196,7 +198,7 @@ | Certificates [Certificate] | HelloRequest | ServerHelloDone - | ClientKeyXchg Version [Word8] + | ClientKeyXchg Version ClientKeyData | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] | CertVerify [Word8] diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -39,6 +39,7 @@ import Data.Binary.Put import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L +import Control.Applicative ((<$>)) import Control.Monad.Error import Data.Word import Data.Bits @@ -61,10 +62,10 @@ runGet f b = Bin.runGet (runErrorT (runGE f)) b remaining :: Get Int -remaining = fmap fromIntegral $ liftGet Bin.remaining +remaining = fromIntegral <$> liftGet Bin.remaining bytesRead :: Get Int -bytesRead = fmap fromIntegral $ liftGet Bin.bytesRead +bytesRead = fromIntegral <$> liftGet Bin.bytesRead getWord8 :: Get Word8 getWord8 = liftGet Bin.getWord8 @@ -80,9 +81,9 @@ getWord24 :: Get Int getWord24 = do - a <- fmap fromIntegral getWord8 - b <- fmap fromIntegral getWord8 - c <- fmap fromIntegral getWord8 + a <- fromIntegral <$> getWord8 + b <- fromIntegral <$> getWord8 + c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c getBytes :: Int -> Get ByteString diff --git a/Stunnel.hs b/Stunnel.hs --- a/Stunnel.hs +++ b/Stunnel.hs @@ -1,29 +1,36 @@ import Network import System.IO import System + 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 Network.TLS.Cipher -import qualified Network.TLS.Client as C -import qualified Network.TLS.Server as S -import Network.TLS.SRandom -import Network.TLS.Struct -import Network.TLS.MAC +import Control.Monad (forM_, when, replicateM) +import Control.Monad.Trans (lift) + import Data.Word import Data.Bits import Data.Maybe -import Control.Monad (forM_, when, replicateM) -import Control.Monad.Trans (lift) -import Random -import qualified Codec.Crypto.AES.Random as AESRand -import Control.Concurrent (forkIO) + import Data.Certificate.PEM import Data.Certificate.X509 import Data.Certificate.Key +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 + +import Random +import qualified Codec.Crypto.AES.Random as AESRand + ciphers :: [Cipher] ciphers = [ cipher_AES128_SHA1 @@ -52,13 +59,13 @@ mainClient :: String -> Int -> IO () mainClient host port = do {- generate some random stuff ready to be used after skipping some byte for no particular reason -} - ranByte <- fmap B.head $ AESRand.randBytes 1 + ranByte <- B.head <$> AESRand.randBytes 1 _ <- AESRand.randBytes (fromIntegral ranByte) - clientRandom <- fmap (fromJust . clientRandom . B.unpack) $ AESRand.randBytes 32 - premasterRandom <- fmap B.unpack $ AESRand.randBytes 46 - seqInit <- fmap (conv . B.unpack) $ AESRand.randBytes 4 + clientRandom <- fromJust . clientRandom . B.unpack <$> AESRand.randBytes 32 + premasterRandom <- (ClientKeyData . B.unpack) <$> AESRand.randBytes 46 + seqInit <- conv . B.unpack <$> AESRand.randBytes 4 - handle <- connectTo host (PortNumber 6061) + handle <- connectTo host (PortNumber $ fromIntegral port) hSetBuffering handle NoBuffering let clientstate = C.TLSClientParams @@ -67,6 +74,9 @@ , C.cpSession = Nothing , C.cpCiphers = ciphers , C.cpCertificate = Nothing + , C.cpCallbacks = C.TLSClientCallbacks + { C.cbCertificates = Nothing + } } C.runTLSClient (tlsclient handle clientRandom premasterRandom) clientstate (makeSRandomGen seqInit) @@ -80,8 +90,8 @@ lift $ putStrLn "end" clientProcess ((certdata, cert), pk) (handle, src) = do - serverRandom <- fmap (fromJust . serverRandom . B.unpack) $ AESRand.randBytes 32 - seqInit <- fmap (conv . B.unpack) $ AESRand.randBytes 4 + serverRandom <- fromJust . serverRandom . B.unpack <$> AESRand.randBytes 32 + seqInit <- conv . B.unpack <$> AESRand.randBytes 4 let serverstate = S.TLSServerParams { S.spAllowedVersions = [TLS10] @@ -89,6 +99,8 @@ , S.spCiphers = ciphers , S.spCertificate = Just (certdata, cert, pk) , S.spWantClientCert = False + , S.spCallbacks = S.TLSServerCallbacks + { S.cbCertificates = Nothing } } S.runTLSServer (tlsserver handle serverRandom) serverstate (makeSRandomGen seqInit) diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -4,7 +4,6 @@ - implement Certificate Verify / Certificate Request - add Client Certificates - add check for non-self signed certificate -- don't fail straight away if clientkeyxchg failed. required for security - alert correctly on errors - process session as they should - put 4 bytes of time in client/server random diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -45,6 +45,9 @@ instance Arbitrary ServerRandom where arbitrary = ServerRandom `fmap` someWords8 32 +instance Arbitrary ClientKeyData where + arbitrary = ClientKeyData `fmap` someWords8 46 + instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int @@ -58,12 +61,25 @@ 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 -} diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 0.1.1 +Version: 0.1.2 Description: Implementation of the TLS protocol, focusing on purity and more type-checking. . @@ -39,15 +39,15 @@ Exposed-modules: Network.TLS.Client Network.TLS.Server Network.TLS.Struct - other-modules: Network.TLS.Cipher - Network.TLS.Compression - Network.TLS.Crypto + Network.TLS.Cipher + Network.TLS.SRandom Network.TLS.MAC + other-modules: Network.TLS.Compression + Network.TLS.Crypto Network.TLS.Packet Network.TLS.State Network.TLS.Sending Network.TLS.Receiving - Network.TLS.SRandom Network.TLS.Wire ghc-options: -Wall