Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base: 154ee08b69
...
compare: b5280cdde8
  • 13 commits
  • 9 files changed
  • 4 commit comments
  • 2 contributors
View
169 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 = defaultParamsClient { pCiphers = map fakeCipher ciphers }
- ctx <- contextNewOnHandle handle params rng
- 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
View
91 Examples/RetrieveCertificate.hs
@@ -1,91 +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.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 = defaultParamsClient
- { 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)
View
78 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 <- contextNewOnHandle dsth params rng
- f ctx
- hClose dsth
-
-getDefaultParams sStorage session = defaultParamsClient
- { 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 ()
--}
View
286 Examples/Stunnel.hs
@@ -1,286 +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.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.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
-
-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 -> Context -> 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")
- contextFlush 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 = defaultParamsServer
- { 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 <- contextNewOnHandle handle serverState' rng
- 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)
- (\(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 = defaultParamsClient
- { 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 <- contextNewOnHandle dsth clientstate rng
- _ <- 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
View
3  Network/TLS/Extra.hs
@@ -13,8 +13,11 @@ module Network.TLS.Extra
, 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
View
6 Network/TLS/Extra/Certificate.hs
@@ -16,6 +16,7 @@ module Network.TLS.Extra.Certificate
, certificateFingerprint
) where
+import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Certificate.X509
@@ -44,9 +45,8 @@ import System.IO (hPutStrLn, stderr)
-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first
-- failure.
certificateChecks :: [ [X509] -> IO CertificateUsage ] -> [X509] -> IO CertificateUsage
-certificateChecks checks x509s = do
- r <- mapM (\c -> c x509s) checks
- return $ fromMaybe CertificateUsageAccept $ find (CertificateUsageAccept /=) r
+certificateChecks checks x509s =
+ fromMaybe CertificateUsageAccept . find (CertificateUsageAccept /=) <$> mapM ($ x509s) checks
#if defined(NOCERTVERIFY)
View
57 Network/TLS/Extra/File.hs
@@ -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)
View
33 Tests/Connection.hs
@@ -18,7 +18,8 @@ import Test.QuickCheck.Monadic as QM
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import Data.Certificate.PEM
+import Data.Either
+import Data.PEM
import Data.Certificate.X509
import qualified Data.Certificate.KeyRSA as KeyRSA
import qualified Crypto.Random.AESCtr as RNG
@@ -50,24 +51,24 @@ instance Arbitrary Word8 where
{- helpers to prepare the tests -}
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
+ 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
- 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 x -> return $ PrivRSA $ snd x
+ 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"
arbitraryVersions :: Gen [Version]
arbitraryVersions = resize (length supportedVersions + 1) $ listOf1 (elements supportedVersions)
View
61 tls-extra.cabal
@@ -18,14 +18,6 @@ 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 >= 1.0.0 && < 1.1.0
@@ -35,8 +27,9 @@ Library
, bytestring
, vector
, crypto-api >= 0.5
- , cryptocipher >= 0.3.0
- , certificate >= 1.1.0 && < 1.2.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,11 @@ Library
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,6 +51,7 @@ executable Tests
, HUnit
, QuickCheck >= 2
, bytestring
+ , cprng-aes >= 0.2.3
else
Buildable: False

Showing you all comments on commits in this comparison.

@snoyberg

I have to have the exact same readCertificate and readPrivateKey functions in warp-tls. Do you think it would make sense to expose them from the API somewhere?

@vincenthz
Owner

Most definitely. I was wondering the same thing when doing the change, but couldn't think of where to expose it, hence why i left it as is. something like Network.TLS.Extra.Server(Helper) ? or a new package ?

@snoyberg

I definitely think it could be thrown in with tls-extra. If you're asking for bikeshedding, I might call it Network.TLS.Extra.File, but I really don't have a strong preference.

@vincenthz
Owner

That's a good suggestion thanks.

Something went wrong with that request. Please try again.