tls-extra 0.4.5 → 0.4.6
raw patch · 7 files changed
+65/−681 lines, 7 filesdep −cmdargsdep ~cprng-aesdep ~cryptocipherdep ~network
Dependencies removed: cmdargs
Dependency ranges changed: cprng-aes, cryptocipher, network, pem, tls
Files
- Examples/CheckCiphers.hs +0/−169
- Examples/RetrieveCertificate.hs +0/−90
- Examples/SimpleClient.hs +0/−78
- Examples/Stunnel.hs +0/−288
- Network/TLS/Extra.hs +3/−0
- Network/TLS/Extra/File.hs +57/−0
- tls-extra.cabal +5/−56
− 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,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)
− Examples/SimpleClient.hs
@@ -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 ()--}
− Examples/Stunnel.hs
@@ -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
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/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)
tls-extra.cabal view
@@ -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