tls-extra 0.4.2.1 → 0.6.6
raw patch · 14 files changed
Files
- Examples/CheckCiphers.hs +0/−169
- Examples/RetrieveCertificate.hs +0/−84
- Examples/SimpleClient.hs +0/−71
- Examples/Stunnel.hs +0/−287
- LICENSE +1/−1
- Network/TLS/Extra.hs +3/−0
- Network/TLS/Extra/Certificate.hs +132/−114
- Network/TLS/Extra/Cipher.hs +130/−153
- Network/TLS/Extra/Compression.hs +10/−3
- Network/TLS/Extra/Connection.hs +24/−13
- Network/TLS/Extra/File.hs +57/−0
- Network/TLS/Extra/Thread.hs +0/−3
- Tests.hs +0/−2
- tls-extra.cabal +16/−62
− Examples/CheckCiphers.hs
@@ -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
− Examples/RetrieveCertificate.hs
@@ -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)
− Examples/SimpleClient.hs
@@ -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 ()
− Examples/Stunnel.hs
@@ -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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2010-2012 Vincent Hanquez <vincent@snarc.org> All rights reserved.
Network/TLS/Extra.hs view
@@ -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
Network/TLS/Extra/Certificate.hs view
@@ -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- -- <star>.com or <star> is always invalid- | length l < 2 = rejectMisc "commonname OID wildcard match too widely"- -- <star>.com.<country> 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+ -- <star>.com or <star> is always invalid+ | length l < 2 = rejectMisc "commonname OID wildcard match too widely"+ -- <star>.com.<country> 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
Network/TLS/Extra/Cipher.hs view
@@ -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
Network/TLS/Extra/Compression.hs view
@@ -1,5 +1,12 @@+-- |+-- Module : Network.TLS.Extra.Compression+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+-- module Network.TLS.Extra.Compression- (- ) where+ (+ ) where -import Network.TLS.Compression+--import Network.TLS.Compression
Network/TLS/Extra/Connection.hs view
@@ -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
+ Network/TLS/Extra/File.hs view
@@ -0,0 +1,57 @@+-- |+-- Module : Network.TLS.Extra.File+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
− Network/TLS/Extra/Thread.hs
@@ -1,3 +0,0 @@-module Network.TLS.Extra.Thread- (- ) where
Tests.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- import qualified Tests.Connection as Connection import qualified Tests.Ciphers as Ciphers
tls-extra.cabal view
@@ -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