diff --git a/Examples/CheckCiphers.hs b/Examples/CheckCiphers.hs deleted file mode 100644 --- a/Examples/CheckCiphers.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} - -import Network.TLS.Internal -import Network.TLS.Cipher -import Network.TLS - -import qualified Crypto.Random.AESCtr as RNG - -import qualified Data.ByteString as B -import Data.Word -import Data.Char - -import Network.Socket -import Network.BSD -import System.IO -import Control.Monad -import Control.Applicative ((<$>)) -import Control.Concurrent -import Control.Exception (catch, SomeException(..)) -import Prelude hiding (catch) - -import Text.Printf - -import System.Console.CmdArgs - -tableCiphers = - [ (0x0000, "NULL_WITH_NULL_NULL") - , (0x0001, "RSA_WITH_NULL_MD5") - , (0x0002, "RSA_WITH_NULL_SHA") - , (0x003B, "RSA_WITH_NULL_SHA256") - , (0x0004, "RSA_WITH_RC4_128_MD5") - , (0x0005, "RSA_WITH_RC4_128_SHA") - , (0x000A, "RSA_WITH_3DES_EDE_CBC_SHA") - , (0x002F, "RSA_WITH_AES_128_CBC_SHA") - , (0x0035, "RSA_WITH_AES_256_CBC_SHA") - , (0x003C, "RSA_WITH_AES_128_CBC_SHA256") - , (0x003D, "RSA_WITH_AES_256_CBC_SHA256") - , (0x000D, "DH_DSS_WITH_3DES_EDE_CBC_SHA") - , (0x0010, "DH_RSA_WITH_3DES_EDE_CBC_SHA") - , (0x0013, "DHE_DSS_WITH_3DES_EDE_CBC_SHA") - , (0x0016, "DHE_RSA_WITH_3DES_EDE_CBC_SHA") - , (0x0030, "DH_DSS_WITH_AES_128_CBC_SHA") - , (0x0031, "DH_RSA_WITH_AES_128_CBC_SHA") - , (0x0032, "DHE_DSS_WITH_AES_128_CBC_SHA") - , (0x0033, "DHE_RSA_WITH_AES_128_CBC_SHA") - , (0x0036, "DH_DSS_WITH_AES_256_CBC_SHA") - , (0x0037, "DH_RSA_WITH_AES_256_CBC_SHA") - , (0x0038, "DHE_DSS_WITH_AES_256_CBC_SHA") - , (0x0039, "DHE_RSA_WITH_AES_256_CBC_SHA") - , (0x003E, "DH_DSS_WITH_AES_128_CBC_SHA256") - , (0x003F, "DH_RSA_WITH_AES_128_CBC_SHA256") - , (0x0040, "DHE_DSS_WITH_AES_128_CBC_SHA256") - , (0x0067, "DHE_RSA_WITH_AES_128_CBC_SHA256") - , (0x0068, "DH_DSS_WITH_AES_256_CBC_SHA256") - , (0x0069, "DH_RSA_WITH_AES_256_CBC_SHA256") - , (0x006A, "DHE_DSS_WITH_AES_256_CBC_SHA256") - , (0x006B, "DHE_RSA_WITH_AES_256_CBC_SHA256") - , (0x0018, "DH_anon_WITH_RC4_128_MD5") - , (0x001B, "DH_anon_WITH_3DES_EDE_CBC_SHA") - , (0x0034, "DH_anon_WITH_AES_128_CBC_SHA") - , (0x003A, "DH_anon_WITH_AES_256_CBC_SHA") - , (0x006C, "DH_anon_WITH_AES_128_CBC_SHA256") - , (0x006D, "DH_anon_WITH_AES_256_CBC_SHA256") - ] - -fakeCipher cid = Cipher - { cipherID = cid - , cipherName = "cipher-" ++ show cid - , cipherBulk = Bulk - { bulkName = "fake" - , bulkKeySize = 0 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = undefined - } - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherHash = Hash - { hashName = "fake" - , hashSize = 0 - , hashF = undefined - } - , cipherMinVer = Nothing - } - -clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] [] - -openConnection :: String -> String -> [Word16] -> IO (Maybe Word16) -openConnection s p ciphers = do - pn <- if and $ map isDigit $ p - then return $ fromIntegral $ (read p :: Int) - else do - service <- getServiceByName p "tcp" - return $ servicePort service - he <- getHostByName s - sock <- socket AF_INET Stream defaultProtocol - connect sock (SockAddrInet pn (head $ hostAddresses he)) - handle <- socketToHandle sock ReadWriteMode - - rng <- RNG.makeSystem - let params = defaultParams { pCiphers = map fakeCipher ciphers } - ctx <- client params rng handle - sendPacket ctx $ Handshake [clienthello ciphers] - catch (do - rpkt <- recvPacket ctx - ccid <- case rpkt of - Right (Handshake ((ServerHello _ _ _ i _ _):_)) -> return i - _ -> error ("expecting server hello, packet received: " ++ show rpkt) - bye ctx - hClose handle - return $ Just ccid - ) (\(_ :: SomeException) -> return Nothing) - -connectRange :: String -> String -> Int -> [Word16] -> IO (Int, [Word16]) -connectRange d p v r = do - ccidopt <- openConnection d p r - threadDelay v - case ccidopt of - Nothing -> return (1, []) - Just ccid -> do - {-divide and conquer TLS-} - let newr = filter ((/=) ccid) r - let (lr, rr) = if length newr > 2 - then splitAt (length newr `div` 2) newr - else (newr, []) - (lc, ls) <- if length lr > 0 - then connectRange d p v lr - else return (0,[]) - (rc, rs) <- if length rr > 0 - then connectRange d p v rr - else return (0,[]) - return (1 + lc + rc, [ccid] ++ ls ++ rs) - -connectBetween d p v chunkSize ep sp = concat <$> loop sp where - loop a = liftM2 (:) (snd <$> connectRange d p v range) - (if a + chunkSize > ep then return [] else loop (a+64)) - where - range = if a + chunkSize > ep - then [a..ep] - else [a..sp+chunkSize] - -data PArgs = PArgs - { destination :: String - , port :: String - , speed :: Int - , start :: Int - , end :: Int - , nb :: Int - } deriving (Show, Data, Typeable) - -progArgs = PArgs - { destination = "localhost" &= help "destination address to connect to" &= typ "address" - , port = "443" &= help "destination port to connect to" &= typ "port" - , speed = 100 &= help "speed between queries, in milliseconds" &= typ "speed" - , start = 0 &= help "starting cipher number (between 0 and 65535)" &= typ "cipher" - , end = 0xff &= help "end cipher number (between 0 and 65535)" &= typ "cipher" - , nb = 64 &= help "number of cipher to include per query " &= typ "range" - } &= summary "CheckCiphers -- SSL/TLS remotely check supported cipher" - &= details - [ "check the supported cipher of a remote destination." - , "Beware: this program make multiple connections to the destination" - , "which might be taken by the remote side as aggressive behavior" - ] - -main = do - a <- cmdArgs progArgs - _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a) - supported <- connectBetween (destination a) (port a) (speed a) (fromIntegral $ nb a) (fromIntegral $ end a) (fromIntegral $ start a) - forM_ supported $ \i -> do - putStrLn $ maybe ("cipher " ++ show i) id $ lookup i tableCiphers diff --git a/Examples/RetrieveCertificate.hs b/Examples/RetrieveCertificate.hs deleted file mode 100644 --- a/Examples/RetrieveCertificate.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} - -import Network.TLS -import Network.TLS.Extra - -import Data.Char -import Data.IORef -import Data.Time.Clock - -import System.IO -import Control.Monad -import Prelude hiding (catch) - -import qualified Crypto.Random.AESCtr as RNG - -import Text.Printf - -import System.Console.CmdArgs - -openConnection s p = do - ref <- newIORef Nothing - rng <- RNG.makeSystem - let params = defaultParams - { pCiphers = ciphersuite_all - , onCertificatesRecv = \l -> do - modifyIORef ref (const $ Just l) - return CertificateUsageAccept - } - ctx <- connectionClient s p params rng - _ <- handshake ctx - bye ctx - r <- readIORef ref - case r of - Nothing -> error "cannot retrieve any certificate" - Just certs -> return certs - -data PArgs = PArgs - { destination :: String - , port :: String - , chain :: Bool - , output :: String - , verify :: Bool - , verifyFQDN :: String - } deriving (Show, Data, Typeable) - -progArgs = PArgs - { destination = "localhost" &= help "destination address to connect to" &= typ "address" - , port = "443" &= help "destination port to connect to" &= typ "port" - , chain = False &= help "also output the chain of certificate used" - , output = "pem" &= help "define the format of output (PEM by default)" &= typ "format" - , verify = False &= help "verify the chain received with the trusted system certificates" - , verifyFQDN = "" &= help "verify the chain against a specific fully qualified domain name (e.g. web.example.com)" &= explicit &= name "verify-domain-name" - } &= summary "RetrieveCertificate remotely for SSL/TLS protocol" - &= details - [ "Retrieve the remote certificate and optionally its chain from a remote destination" - ] - -showCert _ cert = - putStrLn $ show cert - -main = do - a <- cmdArgs progArgs - _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a) - - certs <- openConnection (destination a) (port a) - case (chain a) of - True -> - forM_ (zip [0..] certs) $ \(n, cert) -> do - putStrLn ("###### Certificate " ++ show (n + 1 :: Int) ++ " ######") - showCert (output a) cert - False -> - showCert (output a) $ head certs - - when (verify a) $ do - putStrLn "### certificate chain trust" - ctime <- utctDay `fmap` getCurrentTime - certificateVerifyChain certs >>= showUsage "chain validity" - showUsage "time validity" (certificateVerifyValidity ctime certs) - when (verifyFQDN a /= "") $ - showUsage "fqdn match" (certificateVerifyDomain (verifyFQDN a) certs) - where - showUsage :: String -> TLSCertificateUsage -> IO () - showUsage s CertificateUsageAccept = printf "%s : accepted\n" s - showUsage s (CertificateUsageReject r) = printf "%s : rejected: %s\n" s (show r) diff --git a/Examples/SimpleClient.hs b/Examples/SimpleClient.hs deleted file mode 100644 --- a/Examples/SimpleClient.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -import Network.BSD -import Network.Socket -import Network.TLS -import Network.TLS.Extra -import System.IO -import qualified Crypto.Random.AESCtr as RNG -import qualified Data.ByteString.Lazy.Char8 as LC - -import Data.IORef - -validateCert = False -debug = False - -ciphers :: [Cipher] -ciphers = - [ cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - ] - -runTLS params hostname portNumber f = do - rng <- RNG.makeSystem - he <- getHostByName hostname - sock <- socket AF_INET Stream defaultProtocol - let sockaddr = SockAddrInet portNumber (head $ hostAddresses he) - catch (connect sock sockaddr) - (\_ -> error ("cannot open socket " ++ show sockaddr) >> sClose sock) - dsth <- socketToHandle sock ReadWriteMode - ctx <- client params rng dsth - f ctx - hClose dsth - -getDefaultParams sStorage session = defaultParams - { pConnectVersion = TLS10 - , pAllowedVersions = [TLS10,TLS11,TLS12] - , pCiphers = ciphers - , pCertificates = [] - , pLogging = logging - , onCertificatesRecv = crecv - , onSessionEstablished = \s d -> writeIORef sStorage (s,d) - , sessionResumeWith = session - } - where - logging = if not debug then defaultLogging else defaultLogging - { loggingPacketSent = putStrLn . ("debug: >> " ++) - , loggingPacketRecv = putStrLn . ("debug: << " ++) - } - crecv = if validateCert then certificateVerifyChain else (\_ -> return CertificateUsageAccept) - - -main = do - sStorage <- newIORef undefined - let hostname = "localhost" - let port = 2001 - runTLS (getDefaultParams sStorage Nothing) hostname port $ \ctx -> do - handshake ctx - sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n" - d <- recvData ctx - bye ctx - LC.putStrLn d - return () - session <- readIORef sStorage - runTLS (getDefaultParams sStorage $ Just session) hostname port $ \ctx -> do - handshake ctx - sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n" - d <- recvData ctx - bye ctx - LC.putStrLn d - return () diff --git a/Examples/Stunnel.hs b/Examples/Stunnel.hs deleted file mode 100644 --- a/Examples/Stunnel.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -import Network.BSD -import Network.Socket -import System.IO -import System.IO.Error hiding (try) -import System.Console.CmdArgs - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Exception (finally, try, throw) -import Control.Monad (when, forever, unless) - -import Data.Char (isDigit) - -import Data.Certificate.PEM -import Data.Certificate.X509 -import qualified Data.Certificate.KeyRSA as KeyRSA - -import qualified Crypto.Random.AESCtr as RNG -import Network.TLS -import Network.TLS.Extra - -ciphers :: [Cipher] -ciphers = - [ cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - ] - -loopUntil :: Monad m => m Bool -> m () -loopUntil f = f >>= \v -> if v then return () else loopUntil f - -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 - -tlsclient :: Handle -> TLSCtx Handle -> IO () -tlsclient srchandle dsthandle = do - hSetBuffering srchandle NoBuffering - - success <- handshake dsthandle - unless success $ do - error "client: handshake failed" - - _ <- forkIO $ forever $ do - dat <- recvData dsthandle - putStrLn ("received " ++ show dat) - L.hPut srchandle dat - loopUntil $ do - b <- readOne srchandle - putStrLn ("sending " ++ show b) - if B.null b - then do - bye dsthandle - return True - else do - sendData dsthandle (L.fromChunks [b]) - return False - return () - -tlsserver srchandle dsthandle = do - hSetBuffering dsthandle NoBuffering - - success <- handshake srchandle - unless success $ do - error "server: handshake failed" - - loopUntil $ do - d <- recvData srchandle - putStrLn ("received: " ++ show d) - sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data") - hFlush (ctxConnection srchandle) - return False - putStrLn "end" - -clientProcess certs handle dsthandle dbg sessionStorage _ = do - rng <- RNG.makeSystem - let logging = if not dbg then defaultLogging else defaultLogging - { loggingPacketSent = putStrLn . ("debug: send: " ++) - , loggingPacketRecv = putStrLn . ("debug: recv: " ++) - } - - let serverstate = defaultParams - { pAllowedVersions = [SSL3,TLS10,TLS11,TLS12] - , pCiphers = ciphers - , pCertificates = certs - , pWantClientCert = False - , pLogging = logging - } - let serverState' = case sessionStorage of - Nothing -> serverstate - Just storage -> serverstate - { onSessionResumption = \s -> withMVar storage (return . lookup s) - , onSessionEstablished = \s d -> modifyMVar_ storage (\l -> return $ (s,d) : l) - } - - ctx <- server serverState' rng handle - tlsserver ctx dsthandle - -readCertificate :: FilePath -> IO X509 -readCertificate filepath = do - content <- B.readFile filepath - let certdata = case parsePEMCert content of - Nothing -> error ("no valid certificate section") - Just x -> x - let cert = case decodeCertificate $ L.fromChunks [certdata] of - Left err -> error ("cannot decode certificate: " ++ err) - Right x -> x - return cert - -readPrivateKey :: FilePath -> IO PrivateKey -readPrivateKey filepath = do - content <- B.readFile filepath - let pkdata = case parsePEMKeyRSA content of - Nothing -> error ("no valid RSA key section") - Just x -> L.fromChunks [x] - case KeyRSA.decodePrivate pkdata of - Left err -> error ("cannot decode key: " ++ err) - Right (_,pk) -> return $ PrivRSA pk - -data Stunnel = - Client - { destinationType :: String - , destination :: String - , sourceType :: String - , source :: String - , debug :: Bool - , validCert :: Bool } - | Server - { destinationType :: String - , destination :: String - , sourceType :: String - , source :: String - , debug :: Bool - , disableSession :: Bool - , 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" - , debug = False &= help "debug the TLS protocol printing debugging to stdout" &= typ "Bool" - , validCert = False &= help "check if the certificate receive is valid" &= typ "Bool" - } - &= 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" - , disableSession = False &= help "disable support for session" &= typ "Bool" - , debug = False &= help "debug the TLS protocol printing debugging to stdout" &= typ "Bool" - , 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 logging = if not $ debug pargs then defaultLogging else defaultLogging - { loggingPacketSent = putStrLn . ("debug: send: " ++) - , loggingPacketRecv = putStrLn . ("debug: recv: " ++) - } - - let crecv = if validCert pargs then certificateVerifyChain else (\_ -> return CertificateUsageAccept) - let clientstate = defaultParams - { pConnectVersion = TLS10 - , pAllowedVersions = [TLS10,TLS11,TLS12] - , pCiphers = ciphers - , pCertificates = [] - , pLogging = logging - , onCertificatesRecv = crecv - } - - case srcaddr of - AddrSocket _ _ -> do - (StunnelSocket srcsocket) <- listenAddressDescription srcaddr - forever $ do - (s, _) <- accept srcsocket - rng <- RNG.makeSystem - srch <- socketToHandle s ReadWriteMode - - (StunnelSocket dst) <- connectAddressDescription dstaddr - - dsth <- socketToHandle dst ReadWriteMode - dstctx <- client clientstate rng dsth - _ <- forkIO $ finally - (tlsclient srch dstctx) - (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) - - sessionStorage <- if disableSession pargs then return Nothing else (Just `fmap` newMVar []) - - case srcaddr of - AddrSocket _ _ -> do - (StunnelSocket srcsocket) <- listenAddressDescription srcaddr - forever $ do - (s, addr) <- accept srcsocket - srch <- socketToHandle s ReadWriteMode - r <- connectAddressDescription dstaddr - dsth <- case r of - StunnelFd _ _ -> return stdout - StunnelSocket dst -> socketToHandle dst ReadWriteMode - - _ <- forkIO $ finally - (clientProcess [(cert, Just pk)] srch dsth (debug pargs) sessionStorage addr >> return ()) - (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) - return () - AddrFD _ _ -> error "bad error fd. not implemented" - -main :: IO () -main = do - x <- cmdArgsRun mode - case x of - Client _ _ _ _ _ _ -> doClient x - Server _ _ _ _ _ _ _ _ -> doServer x diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2011 Vincent Hanquez +Copyright (c) 2010-2012 Vincent Hanquez All rights reserved. diff --git a/Network/TLS/Extra.hs b/Network/TLS/Extra.hs --- a/Network/TLS/Extra.hs +++ b/Network/TLS/Extra.hs @@ -13,8 +13,11 @@ , module Network.TLS.Extra.Certificate -- * Connection helpers , module Network.TLS.Extra.Connection + -- * File helpers + , module Network.TLS.Extra.File ) where import Network.TLS.Extra.Cipher import Network.TLS.Extra.Certificate import Network.TLS.Extra.Connection +import Network.TLS.Extra.File diff --git a/Network/TLS/Extra/Certificate.hs b/Network/TLS/Extra/Certificate.hs --- a/Network/TLS/Extra/Certificate.hs +++ b/Network/TLS/Extra/Certificate.hs @@ -7,74 +7,96 @@ -- Portability : unknown -- module Network.TLS.Extra.Certificate - ( certificateChecks - , certificateVerifyChain - , certificateVerifyAgainst - , certificateSelfSigned - , certificateVerifyDomain - , certificateVerifyValidity - , certificateFingerprint - ) where + ( certificateChecks + , certificateVerifyChain + , certificateVerifyAgainst + , certificateSelfSigned + , certificateVerifyDomain + , certificateVerifyValidity + , certificateFingerprint + ) where +import Control.Applicative ((<$>)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Certificate.X509 -import System.Certificate.X509 as SysCert -- for signing/verifying certificate import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.MD2 as MD2 -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Cipher.RSA as RSA -import qualified Crypto.Cipher.DSA as DSA +import qualified Crypto.PubKey.HashDescr as HD +import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified Crypto.PubKey.DSA as DSA +import Data.CertificateStore import Data.Certificate.X509.Cert (oidCommonName) -import Network.TLS (TLSCertificateUsage(..), TLSCertificateRejectReason(..)) +import Network.TLS (CertificateUsage(..), CertificateRejectReason(..)) import Data.Time.Calendar import Data.List (find) +import Data.Maybe (fromMaybe) --- | combine many certificates checking function together. --- if one check fail, the whole sequence of checking is cuted short and return the --- reject reason. -certificateChecks :: [ [X509] -> IO TLSCertificateUsage ] -> [X509] -> IO TLSCertificateUsage -certificateChecks checks x509s = do - r <- sequence $ map (\c -> c x509s) checks - return $ maybe CertificateUsageAccept id $ find ((/=) CertificateUsageAccept) r +#if defined(NOCERTVERIFY) +import System.IO (hPutStrLn, stderr, hIsTerminalDevice) +import Control.Monad (when) +#endif +-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first +-- failure. +certificateChecks :: [ [X509] -> IO CertificateUsage ] -> [X509] -> IO CertificateUsage +certificateChecks checks x509s = + fromMaybe CertificateUsageAccept . find (CertificateUsageAccept /=) <$> mapM ($ x509s) checks + #if defined(NOCERTVERIFY) # warning "********certificate verify chain doesn't yet work on your platform *************" # warning "********please consider contributing to the certificate to fix this issue *************" # warning "********getting trusted system certificate is platform dependant *************" -{- on windows and OSX, the trusted certificates are not yet accessible, +{- on windows, the trusted certificates are not yet accessible, - for now, print a big fat warning (better than nothing) and returns true -} -certificateVerifyChain_ :: [X509] -> IO TLSCertificateUsage -certificateVerifyChain_ _ = do - putStrLn "****************** certificate verify chain doesn't yet work on your platform **********************" - putStrLn "please consider contributing to the certificate package to fix this issue" - return CertificateUsageAccept +certificateVerifyChain_ :: CertificateStore -> [X509] -> IO CertificateUsage +certificateVerifyChain_ _ _ = do + wvisible <- hIsTerminalDevice stderr + when wvisible $ do + hPutStrLn stderr "tls-extra:Network.TLS.Extra.Certificate" + hPutStrLn stderr "****************** certificate verify chain doesn't yet work on your platform **********************" + hPutStrLn stderr "please consider contributing to the certificate package to fix this issue" + return CertificateUsageAccept #else -certificateVerifyChain_ :: [X509] -> IO TLSCertificateUsage -certificateVerifyChain_ [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates") -certificateVerifyChain_ (x:xs) = do - -- find a matching certificate that we trust (== installed on the system) - foundCert <- SysCert.findCertificate (certMatchDN x) - case foundCert of - Just sysx509 -> do - validChain <- certificateVerifyAgainst x sysx509 - if validChain - then return CertificateUsageAccept - else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") - Nothing -> case xs of - [] -> return $ CertificateUsageReject CertificateRejectUnknownCA - _ -> do - validChain <- certificateVerifyAgainst x (head xs) - if validChain - then certificateVerifyChain_ xs - else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") +certificateVerifyChain_ :: CertificateStore -> [X509] -> IO CertificateUsage +certificateVerifyChain_ _ [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates") +certificateVerifyChain_ store (x:xs) = loop 0 x xs >>= return . maybe CertificateUsageAccept CertificateUsageReject + where checkTrusted _ cert notFound = + case findCertificate (certIssuerDN $ x509Cert cert) store of + Just tCer -> verifyAgainstTrusted tCer cert + Nothing -> notFound + + loop :: Int -> X509 -> [X509] -> IO (Maybe CertificateRejectReason) + loop depth cert [] = checkTrusted depth cert (return $ Just (CertificateRejectUnknownCA)) + loop depth cert (n:ns) = checkTrusted depth cert $ do + case checkCA $ certExtensions $ x509Cert n of + Just r -> return (Just r) + Nothing | certificateVerifyAgainst cert n -> loop (depth+1) n ns + | otherwise -> return certificateChainDoesntMatch + + verifyAgainstTrusted trustedCer cert + | validChain = return Nothing + | otherwise = return certificateChainDoesntMatch + where validChain = certificateVerifyAgainst cert trustedCer + + checkCA Nothing = certificateNotAllowedToSign + checkCA (Just es) = + let kuCanCertSign = case extensionGet es of + Just (ExtKeyUsage l) -> elem KeyUsage_keyCertSign l + Nothing -> True + in case extensionGet es of + Just (ExtBasicConstraints True _) + | kuCanCertSign -> Nothing + | otherwise -> certificateNotAllowedToSign + _ -> certificateNotAllowedToSign + certificateNotAllowedToSign = Just $ CertificateRejectOther "certificate is not allowed to sign another certificate" + certificateChainDoesntMatch = Just $ CertificateRejectOther "chain doesn't match" #endif -- | verify a certificates chain using the system certificates available. @@ -91,37 +113,34 @@ -- -- TODO: verify validity, check revocation list if any, add optional user output to know -- the rejection reason. -certificateVerifyChain :: [X509] -> IO TLSCertificateUsage -certificateVerifyChain = certificateVerifyChain_ . reorderList - where - reorderList [] = [] - reorderList (x:xs) = - case find (certMatchDN x) xs of - Nothing -> x : reorderList xs - Just found -> x : found : reorderList (filter (/= found) xs) +certificateVerifyChain :: CertificateStore -> [X509] -> IO CertificateUsage +certificateVerifyChain store = certificateVerifyChain_ store . reorderList + where + reorderList [] = [] + reorderList (x:xs) = + case find (certMatchDN x) xs of + Nothing -> x : reorderList xs + Just found -> x : found : reorderList (filter (/= found) xs) -- | verify a certificate against another one. -- the first certificate need to be signed by the second one for this function to succeed. -certificateVerifyAgainst :: X509 -> X509 -> IO Bool -certificateVerifyAgainst ux509@(X509 _ _ _ sigalg sig) (X509 scert _ _ _ _) = do - let f = verifyF sigalg pk - case f udata esig of - Right True -> return True - _ -> return False - where - udata = B.concat $ L.toChunks $ getSigningData ux509 - esig = B.pack sig - pk = certPubKey scert +certificateVerifyAgainst :: X509 -> X509 -> Bool +certificateVerifyAgainst ux509@(X509 _ _ _ sigalg sig) (X509 scert _ _ _ _) = verified + where + verified = (verifyF sigalg pk) udata esig + udata = B.concat $ L.toChunks $ getSigningData ux509 + esig = B.pack sig + pk = certPubKey scert --- | returns if this certificate is self signed. +-- | Is this certificate self signed? certificateSelfSigned :: X509 -> Bool certificateSelfSigned x509 = certMatchDN x509 x509 certMatchDN :: X509 -> X509 -> Bool certMatchDN (X509 testedCert _ _ _ _) (X509 issuerCert _ _ _ _) = - certSubjectDN issuerCert == certIssuerDN testedCert + certSubjectDN issuerCert == certIssuerDN testedCert -verifyF :: SignatureALG -> PubKey -> B.ByteString -> B.ByteString -> Either String Bool +verifyF :: SignatureALG -> PubKey -> B.ByteString -> B.ByteString -> Bool -- md[245]WithRSAEncryption: -- @@ -130,69 +149,68 @@ -- md2WithRSAEncryption OBJECT IDENTIFIER ::= { pkcs-1 2 } -- md4WithRSAEncryption OBJECT IDENTIFIER ::= { pkcs-1 3 } -- md5WithRSAEncryption OBJECT IDENTIFIER ::= { pkcs-1 4 } -verifyF (SignatureALG HashMD2 PubKeyALG_RSA) (PubKeyRSA rsak) = rsaVerify MD2.hash asn1 rsak - where asn1 = "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x02\x10" - -verifyF (SignatureALG HashMD5 PubKeyALG_RSA) (PubKeyRSA rsak) = rsaVerify MD5.hash asn1 rsak - where asn1 = "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x04\x10" - -verifyF (SignatureALG HashSHA1 PubKeyALG_RSA) (PubKeyRSA rsak) = rsaVerify SHA1.hash asn1 rsak - where asn1 = "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14" - +verifyF (SignatureALG HashMD2 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrMD2 rsak +verifyF (SignatureALG HashMD5 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrMD5 rsak +verifyF (SignatureALG HashSHA1 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrSHA1 rsak verifyF (SignatureALG HashSHA1 PubKeyALG_DSA) (PubKeyDSA dsak) = dsaSHA1Verify dsak - -verifyF _ _ = (\_ _ -> Left "unexpected/wrong signature") +verifyF (SignatureALG HashSHA256 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrSHA256 rsak -dsaSHA1Verify pk _ b = either (Left . show) (Right) $ DSA.verify asig SHA1.hash pk b - where asig = (0,0) {- FIXME : need to work out how to get R/S from the bytestring a -} +verifyF _ _ = \_ _ -> False -rsaVerify h hdesc pk a b = either (Left . show) (Right) $ RSA.verify h hdesc pk a b +dsaSHA1Verify pk _ b = False + --where asig = DSA.Signature 0 0 {- FIXME : need to work out how to get R/S from the bytestring a -} -- | Verify that the given certificate chain is application to the given fully qualified host name. -certificateVerifyDomain :: String -> [X509] -> TLSCertificateUsage +certificateVerifyDomain :: String -> [X509] -> CertificateUsage certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list") certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) = - case lookup oidCommonName $ certSubjectDN cert of - Nothing -> rejectMisc "no commonname OID in certificate cannot match to FQDN" - Just (_, val) -> matchDomain (splitDot val) - where - matchDomain l - | length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain" - | head l == "*" = wildcardMatch (reverse $ drop 1 l) - | otherwise = if l == splitDot fqhn - then CertificateUsageAccept - else rejectMisc "FQDN and common name OID do not match" + let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ getDistinguishedElements $ certSubjectDN cert) + ++ maybe [] (maybe [] toAltName . extensionGet) (certExtensions cert) in + orUsage $ map (matchDomain . splitDot) names + where + orUsage [] = rejectMisc "FQDN do not match this certificate" + orUsage (x:xs) + | x == CertificateUsageAccept = CertificateUsageAccept + | otherwise = orUsage xs - -- only 1 wildcard is valid, and if multiples are present - -- they won't have a wildcard meaning but will be match as normal star - -- character to the fqhn and inevitably will fail. - wildcardMatch l - -- .com or is always invalid - | length l < 2 = rejectMisc "commonname OID wildcard match too widely" - -- .com. is always invalid - | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = rejectMisc "commonname OID wildcard match too widely" - | otherwise = - if l == take (length l) (reverse $ splitDot fqhn) - then CertificateUsageAccept - else rejectMisc "FQDN and common name OID do not match" + toAltName (ExtSubjectAltName l) = l + matchDomain l + | length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain" + | head l == "*" = wildcardMatch (reverse $ drop 1 l) + | otherwise = if l == splitDot fqhn + then CertificateUsageAccept + else rejectMisc "FQDN and common name OID do not match" - splitDot :: String -> [String] - splitDot [] = [""] - splitDot x = - let (y, z) = break (== '.') x in - y : (if z == "" then [] else splitDot $ drop 1 z) + -- only 1 wildcard is valid, and if multiples are present + -- they won't have a wildcard meaning but will be match as normal star + -- character to the fqhn and inevitably will fail. + wildcardMatch l + -- .com or is always invalid + | length l < 2 = rejectMisc "commonname OID wildcard match too widely" + -- .com. is always invalid + | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = rejectMisc "commonname OID wildcard match too widely" + | otherwise = + if l == take (length l) (reverse $ splitDot fqhn) + then CertificateUsageAccept + else rejectMisc "FQDN and common name OID do not match" - rejectMisc s = CertificateUsageReject (CertificateRejectOther s) + splitDot :: String -> [String] + splitDot [] = [""] + splitDot x = + let (y, z) = break (== '.') x in + y : (if z == "" then [] else splitDot $ drop 1 z) + rejectMisc s = CertificateUsageReject (CertificateRejectOther s) + -- | Verify certificate validity period that need to between the bounds of the certificate. -- TODO: maybe should verify whole chain. -certificateVerifyValidity :: Day -> [X509] -> TLSCertificateUsage +certificateVerifyValidity :: Day -> [X509] -> CertificateUsage certificateVerifyValidity _ [] = CertificateUsageReject $ CertificateRejectOther "empty list" certificateVerifyValidity ctime (X509 cert _ _ _ _ :_) = - let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in - if beforeDay < ctime && ctime <= afterDay - then CertificateUsageAccept - else CertificateUsageReject CertificateRejectExpired + let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in + if beforeDay < ctime && ctime <= afterDay + then CertificateUsageAccept + else CertificateUsageReject CertificateRejectExpired -- | hash the certificate signing data using the supplied hash function. certificateFingerprint :: (L.ByteString -> B.ByteString) -> X509 -> B.ByteString diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -5,80 +5,73 @@ -- Stability : experimental -- Portability : unknown -- +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} module Network.TLS.Extra.Cipher - ( - -- * cipher suite - ciphersuite_all - , ciphersuite_medium - , ciphersuite_strong - , ciphersuite_unencrypted - -- * individual ciphers - , cipher_null_null - , cipher_null_SHA1 - , cipher_null_MD5 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - , cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_AES128_SHA256 - , cipher_AES256_SHA256 - ) where + ( + -- * cipher suite + ciphersuite_all + , ciphersuite_medium + , ciphersuite_strong + , ciphersuite_unencrypted + -- * individual ciphers + , cipher_null_SHA1 + , cipher_null_MD5 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + , cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_AES128_SHA256 + , cipher_AES256_SHA256 + ) where -import qualified Data.Vector.Unboxed as Vector (fromList, toList) import qualified Data.ByteString as B import Network.TLS (Version(..)) import Network.TLS.Cipher -import qualified Crypto.Cipher.AES as AES -import qualified Crypto.Cipher.RC4 as RC4 +import qualified "cipher-rc4" Crypto.Cipher.RC4 as RC4 import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 -aes128_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString -aes128_cbc_encrypt key iv d = AES.encryptCBC pkey iv d - where (Right pkey) = AES.initKey128 key +import qualified "cipher-aes" Crypto.Cipher.AES as AES -aes128_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString -aes128_cbc_decrypt key iv d = AES.decryptCBC pkey iv d - where (Right pkey) = AES.initKey128 key +aes_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes_cbc_encrypt key iv d = AES.encryptCBC (AES.initAES key) iv d -aes256_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString -aes256_cbc_encrypt key iv d = AES.encryptCBC pkey iv d - where (Right pkey) = AES.initKey256 key +aes_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes_cbc_decrypt key iv d = AES.decryptCBC (AES.initAES key) iv d -aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString -aes256_cbc_decrypt key iv d = AES.decryptCBC pkey iv d - where (Right pkey) = AES.initKey256 key +aes128_cbc_encrypt = aes_cbc_encrypt +aes128_cbc_decrypt = aes_cbc_decrypt +aes256_cbc_encrypt = aes_cbc_encrypt +aes256_cbc_decrypt = aes_cbc_decrypt toIV :: RC4.Ctx -> IV -toIV (v, x, y) = B.pack (x : y : Vector.toList v) +toIV (RC4.Ctx ctx) = ctx toCtx :: IV -> RC4.Ctx -toCtx iv = - case B.unpack iv of - x:y:l -> (Vector.fromList l, x, y) - _ -> (Vector.fromList [], 0, 0) +toCtx iv = RC4.Ctx iv initF_rc4 :: Key -> IV -initF_rc4 key = toIV $ RC4.initCtx (B.unpack key) +initF_rc4 key = toIV $ RC4.initCtx key encryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV) -encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encrypt (toCtx iv) d +encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.combine (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 +decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.combine (toCtx iv) e -- | all encrypted ciphers supported ordered from strong to weak. -- this choice of ciphersuite should satisfy most normal need ciphersuite_all :: [Cipher] ciphersuite_all = - [ cipher_AES128_SHA256, cipher_AES256_SHA256 - , cipher_AES128_SHA1, cipher_AES256_SHA1 - , cipher_RC4_128_SHA1, cipher_RC4_128_MD5 - ] + [ cipher_AES128_SHA256, cipher_AES256_SHA256 + , cipher_AES128_SHA1, cipher_AES256_SHA1 + , cipher_RC4_128_SHA1, cipher_RC4_128_MD5 + ] -- | list of medium ciphers. ciphersuite_medium :: [Cipher] @@ -93,159 +86,143 @@ ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] bulk_null = Bulk - { bulkName = "null" - , bulkKeySize = 0 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = BulkNoneF - } + { bulkName = "null" + , bulkKeySize = 0 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF (const B.empty) streamId streamId + } + where streamId = \iv b -> (b,iv) bulk_rc4 = Bulk - { bulkName = "RC4-128" - , bulkKeySize = 16 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = BulkStreamF initF_rc4 encryptF_rc4 decryptF_rc4 - } + { bulkName = "RC4-128" + , bulkKeySize = 16 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF initF_rc4 encryptF_rc4 decryptF_rc4 + } bulk_aes128 = Bulk - { bulkName = "AES128" - , bulkKeySize = 16 - , bulkIVSize = 16 - , bulkBlockSize = 16 - , bulkF = BulkBlockF aes128_cbc_encrypt aes128_cbc_decrypt - } + { bulkName = "AES128" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes128_cbc_encrypt aes128_cbc_decrypt + } bulk_aes256 = Bulk - { bulkName = "AES256" - , bulkKeySize = 32 - , bulkIVSize = 16 - , bulkBlockSize = 16 - , bulkF = BulkBlockF aes256_cbc_encrypt aes256_cbc_decrypt - } + { bulkName = "AES256" + , bulkKeySize = 32 + , bulkIVSize = 16 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes256_cbc_encrypt aes256_cbc_decrypt + } hash_md5 = Hash - { hashName = "MD5" - , hashSize = 16 - , hashF = MD5.hash - } + { hashName = "MD5" + , hashSize = 16 + , hashF = MD5.hash + } hash_sha1 = Hash - { hashName = "SHA1" - , hashSize = 20 - , hashF = SHA1.hash - } + { hashName = "SHA1" + , hashSize = 20 + , hashF = SHA1.hash + } hash_sha256 = Hash - { hashName = "SHA256" - , hashSize = 32 - , hashF = SHA256.hash - } - -hash_null = Hash - { hashName = "null" - , hashSize = 0 - , hashF = const B.empty - } - --- | this is not stricly a usable cipher; it's the initial cipher of a TLS connection -cipher_null_null :: Cipher -cipher_null_null = Cipher - { cipherID = 0x0 - , cipherName = "null-null" - , cipherBulk = bulk_null - , cipherHash = hash_null - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { hashName = "SHA256" + , hashSize = 32 + , hashF = SHA256.hash + } -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher - { cipherID = 0x1 - , cipherName = "RSA-null-MD5" - , cipherBulk = bulk_null - , cipherHash = hash_md5 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x1 + , cipherName = "RSA-null-MD5" + , cipherBulk = bulk_null + , cipherHash = hash_md5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | unencrypted cipher using RSA for key exchange and SHA1 for digest cipher_null_SHA1 :: Cipher cipher_null_SHA1 = Cipher - { cipherID = 0x2 - , cipherName = "RSA-null-SHA1" - , cipherBulk = bulk_null - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x2 + , cipherName = "RSA-null-SHA1" + , cipherBulk = bulk_null + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | RC4 cipher, RSA key exchange and MD5 for digest cipher_RC4_128_MD5 :: Cipher cipher_RC4_128_MD5 = Cipher - { cipherID = 0x04 - , cipherName = "RSA-rc4-128-md5" - , cipherBulk = bulk_rc4 - , cipherHash = hash_md5 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x04 + , cipherName = "RSA-rc4-128-md5" + , cipherBulk = bulk_rc4 + , cipherHash = hash_md5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | RC4 cipher, RSA key exchange and SHA1 for digest cipher_RC4_128_SHA1 :: Cipher cipher_RC4_128_SHA1 = Cipher - { cipherID = 0x05 - , cipherName = "RSA-rc4-128-sha1" - , cipherBulk = bulk_rc4 - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } + { cipherID = 0x05 + , cipherName = "RSA-rc4-128-sha1" + , cipherBulk = bulk_rc4 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } -- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest cipher_AES128_SHA1 :: Cipher cipher_AES128_SHA1 = Cipher - { cipherID = 0x2f - , cipherName = "RSA-aes128-sha1" - , cipherBulk = bulk_aes128 - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just SSL3 - } + { cipherID = 0x2f + , cipherName = "RSA-aes128-sha1" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } -- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest cipher_AES256_SHA1 :: Cipher cipher_AES256_SHA1 = Cipher - { cipherID = 0x35 - , cipherName = "RSA-aes256-sha1" - , cipherBulk = bulk_aes256 - , cipherHash = hash_sha1 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just SSL3 - } + { cipherID = 0x35 + , cipherName = "RSA-aes256-sha1" + , cipherBulk = bulk_aes256 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } -- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest cipher_AES128_SHA256 :: Cipher cipher_AES128_SHA256 = Cipher - { cipherID = 0x3c - , cipherName = "RSA-aes128-sha256" - , cipherBulk = bulk_aes128 - , cipherHash = hash_sha256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } + { cipherID = 0x3c + , cipherName = "RSA-aes128-sha256" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha256 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } -- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest cipher_AES256_SHA256 :: Cipher cipher_AES256_SHA256 = Cipher - { cipherID = 0x3d - , cipherName = "RSA-aes256-sha256" - , cipherBulk = bulk_aes256 - , cipherHash = hash_sha256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } + { cipherID = 0x3d + , cipherName = "RSA-aes256-sha256" + , cipherBulk = bulk_aes256 + , cipherHash = hash_sha256 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } {- TLS 1.0 ciphers definition diff --git a/Network/TLS/Extra/Compression.hs b/Network/TLS/Extra/Compression.hs --- a/Network/TLS/Extra/Compression.hs +++ b/Network/TLS/Extra/Compression.hs @@ -1,5 +1,12 @@ +-- | +-- Module : Network.TLS.Extra.Compression +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.TLS.Extra.Compression - ( - ) where + ( + ) where -import Network.TLS.Compression +--import Network.TLS.Compression diff --git a/Network/TLS/Extra/Connection.hs b/Network/TLS/Extra/Connection.hs --- a/Network/TLS/Extra/Connection.hs +++ b/Network/TLS/Extra/Connection.hs @@ -6,10 +6,10 @@ -- Portability : unknown -- module Network.TLS.Extra.Connection - ( connectionClient - ) where + ( connectionClient + ) where -import Crypto.Random +import Crypto.Random.API import Control.Applicative ((<$>)) import Control.Exception import Data.Char @@ -20,16 +20,27 @@ import Network.Socket import Network.TLS --- | open a TCP client connection to a destination and port description (number or name) +-- | @connectionClient host port param rng@ opens a TCP client connection +-- to a destination host and port description (number or name). For +-- example: -- -connectionClient :: CryptoRandomGen g => String -> String -> TLSParams -> g -> IO (TLSCtx Handle) +-- @ +-- import Network.TLS.Extra +-- import Crypto.Random.AESCtr +-- ... +-- conn <- makeSystem >>= connectionClient 192.168.2.2 7777 defaultParams +-- @ +-- +-- will make a new RNG (using cprng-aes) and connect to IP 192.168.2.2 +-- on port 7777. +connectionClient :: CPRG g => String -> String -> TLSParams -> g -> IO Context connectionClient s p params rng = do - pn <- if and $ map isDigit $ p - then return $ fromIntegral $ (read p :: Int) - else servicePort <$> getServiceByName p "tcp" - he <- getHostByName s + pn <- if and $ map isDigit $ p + then return $ fromIntegral $ (read p :: Int) + else servicePort <$> getServiceByName p "tcp" + he <- getHostByName s - h <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do - connect sock (SockAddrInet pn (head $ hostAddresses he)) - socketToHandle sock ReadWriteMode - client params rng h + h <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do + connect sock (SockAddrInet pn (head $ hostAddresses he)) + socketToHandle sock ReadWriteMode + contextNewOnHandle h params rng diff --git a/Network/TLS/Extra/File.hs b/Network/TLS/Extra/File.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extra/File.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Network.TLS.Extra.File +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Simple helpers to load private key and certificate files +-- to be handled by the TLS stack +module Network.TLS.Extra.File + ( fileReadCertificate + , fileReadPrivateKey + ) where + +import Control.Applicative ((<$>)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Either +import Data.PEM (PEM(..), pemParseBS) +import Data.Certificate.X509 +import qualified Data.Certificate.KeyRSA as KeyRSA +import Network.TLS + +-- | read one X509 certificate from a file. +-- +-- the certificate must be in the usual PEM format with the +-- TRUSTED CERTIFICATE or CERTIFICATE pem name. +-- +-- If no valid PEM encoded certificate is found in the file +-- this function will raise an error. +fileReadCertificate :: FilePath -> IO X509 +fileReadCertificate filepath = do + certs <- rights . parseCerts . pemParseBS <$> B.readFile filepath + case certs of + [] -> error "no valid certificate found" + (x:_) -> return x + where parseCerts (Right pems) = map (decodeCertificate . L.fromChunks . (:[]) . pemContent) + $ filter (flip elem ["CERTIFICATE", "TRUSTED CERTIFICATE"] . pemName) pems + parseCerts (Left err) = error ("cannot parse PEM file " ++ show err) + +-- | read one private key from a file. +-- +-- the private key must be in the usual PEM format and at the moment only +-- RSA PRIVATE KEY are supported. +-- +-- If no valid PEM encoded private key is found in the file +-- this function will raise an error. +fileReadPrivateKey :: FilePath -> IO PrivateKey +fileReadPrivateKey filepath = do + pk <- rights . parseKey . pemParseBS <$> B.readFile filepath + case pk of + [] -> error "no valid RSA key found" + (x:_) -> return x + + where parseKey (Right pems) = map (fmap (PrivRSA . snd) . KeyRSA.decodePrivate . L.fromChunks . (:[]) . pemContent) + $ filter ((== "RSA PRIVATE KEY") . pemName) pems + parseKey (Left err) = error ("Cannot parse PEM file " ++ show err) diff --git a/Network/TLS/Extra/Thread.hs b/Network/TLS/Extra/Thread.hs deleted file mode 100644 --- a/Network/TLS/Extra/Thread.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Network.TLS.Extra.Thread - ( - ) where diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - import qualified Tests.Connection as Connection import qualified Tests.Ciphers as Ciphers diff --git a/tls-extra.cabal b/tls-extra.cabal --- a/tls-extra.cabal +++ b/tls-extra.cabal @@ -1,5 +1,5 @@ Name: tls-extra -Version: 0.4.2.1 +Version: 0.6.6 Description: a set of extra definitions, default values and helpers for tls. License: BSD3 @@ -12,87 +12,37 @@ Category: Network stability: experimental Cabal-Version: >=1.6 -Homepage: http://github.com/vincenthz/hs-tls-extra +Homepage: http://github.com/vincenthz/hs-tls Flag test Description: Build unit test Default: False -Flag bench - Description: Build benchmarks - Default: False - -Flag executable - Description: Build the executable - Default: False - Library Build-Depends: base > 3 && < 5 - , tls >= 0.8.4 && < 0.9 + , tls >= 1.1.0 && < 1.2.0 , mtl , network >= 2.3 , cryptohash >= 0.6 , bytestring , vector - , crypto-api >= 0.5 - , cryptocipher >= 0.3.0 - , certificate >= 1.0.0 && < 1.1.0 - , text >= 0.5 && < 1.0 + , cipher-rc4 + , cipher-aes >= 0.2 && < 0.3 + , certificate >= 1.3.5 && < 1.4.0 + , crypto-pubkey >= 0.2.0 + , crypto-random + , pem >= 0.1 && < 0.3 , time Exposed-modules: Network.TLS.Extra other-modules: Network.TLS.Extra.Certificate Network.TLS.Extra.Cipher Network.TLS.Extra.Compression Network.TLS.Extra.Connection - Network.TLS.Extra.Thread + Network.TLS.Extra.File ghc-options: -Wall -fno-warn-missing-signatures - if os(windows) || os(osx) + if os(windows) cpp-options: -DNOCERTVERIFY -Executable stunnel - Main-is: Examples/Stunnel.hs - if flag(executable) - Build-Depends: network - , cmdargs - , cprng-aes >= 0.2.3 - Buildable: True - else - Buildable: False - ghc-options: -Wall -fno-warn-missing-signatures - -Executable checkciphers - Main-is: Examples/CheckCiphers.hs - if flag(executable) - Build-Depends: network - , cmdargs - , cprng-aes - Buildable: True - else - Buildable: False - ghc-options: -Wall -fno-warn-missing-signatures - -Executable retrievecertificate - Main-is: Examples/RetrieveCertificate.hs - if flag(executable) - Build-Depends: network - , cmdargs - , cprng-aes >= 0.2.3 - Buildable: True - else - Buildable: False - ghc-options: -Wall -fno-warn-missing-signatures - -Executable simpleclient - Main-is: Examples/SimpleClient.hs - if flag(executable) - Build-Depends: network - , cmdargs - , cprng-aes >= 0.2.3 - Buildable: True - else - Buildable: False - ghc-options: -Wall -fno-warn-missing-signatures - executable Tests Main-is: Tests.hs if flag(test) @@ -101,9 +51,13 @@ , HUnit , QuickCheck >= 2 , bytestring + , cprng-aes >= 0.5.0 + , cipher-aes >= 0.2 && < 0.3 else Buildable: False + if os(windows) + cpp-options: -DNOCERTVERIFY source-repository head type: git - location: git://github.com/vincenthz/hs-tls-extra + location: git://github.com/vincenthz/hs-tls