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,90 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} - -import Network.TLS -import Network.TLS.Extra - -import Data.Char -import Data.IORef -import Data.Time.Clock -import Data.Certificate.X509 - -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 = "simple" &= help "define the format of output (full, pem, default: simple)" &= 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 "full" cert = putStrLn $ show cert - -showCert _ (x509Cert -> cert) = do - putStrLn ("serial: " ++ (show $ certSerial cert)) - putStrLn ("issuer: " ++ (show $ certIssuerDN cert)) - putStrLn ("subject: " ++ (show $ certSubjectDN cert)) - putStrLn ("validity: " ++ (show $ fst $ certValidity cert) ++ " to " ++ (show $ snd $ certValidity 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,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -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 Control.Exception -import System.Environment -import Prelude hiding (catch) - -import Data.IORef - -validateCert = True -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) - (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) - 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 - args <- getArgs - let hostname = args !! 0 - let port = read (args !! 1) :: Int - runTLS (getDefaultParams sStorage Nothing) hostname (fromIntegral 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,288 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -import Network.BSD -import Network.Socket -import System.IO -import System.IO.Error hiding (try, catch) -import System.Console.CmdArgs - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Exception (finally, try, throw, catch, SomeException) -import Control.Monad (when, forever) - -import Data.Char (isDigit) -import Data.Either - -import Data.PEM (pemParseBS, 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 - -import Prelude hiding (catch) - -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 - - handshake dsthandle - - _ <- forkIO $ forever $ do - dat <- recvData dsthandle - putStrLn ("received " ++ show dat) - B.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 - - handshake srchandle - - 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 - 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" - -readPrivateKey :: FilePath -> IO PrivateKey -readPrivateKey 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" - -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) - (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) - 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) - (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) - 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/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/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/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.5 +Version: 0.4.6 Description: a set of extra definitions, default values and helpers for tls. License: BSD3 @@ -18,25 +18,18 @@ 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.9.0 && < 1.0.0 + , tls >= 0.9.4 && < 1.0.0 , mtl , network >= 2.3 , cryptohash >= 0.6 , bytestring , vector , crypto-api >= 0.5 - , cryptocipher >= 0.3.0 + , cryptocipher >= 0.3.0 && < 0.4.0 , certificate >= 1.2.0 && < 1.3.0 + , pem >= 0.1.0 && < 0.2.0 , text >= 0.5 && < 1.0 , time Exposed-modules: Network.TLS.Extra @@ -45,54 +38,10 @@ 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) cpp-options: -DNOCERTVERIFY - -Executable stunnel - Main-is: Examples/Stunnel.hs - if flag(executable) - Build-Depends: network - , cmdargs - , cprng-aes >= 0.2.3 - , pem >= 0.1.0 - 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