Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

We’re showing branches in this repository, but you can also compare across forks.

base: 154ee08b69
...
compare: b5280cdde8
  • 13 commits
  • 9 files changed
  • 4 commit comments
  • 2 contributors
169 Examples/CheckCiphers.hs
View
@@ -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
91 Examples/RetrieveCertificate.hs
View
@@ -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)
78 Examples/SimpleClient.hs
View
@@ -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 ()
--}
286 Examples/Stunnel.hs
View
@@ -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
3  Network/TLS/Extra.hs
View
@@ -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
6 Network/TLS/Extra/Certificate.hs
View
@@ -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)
57 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)
33 Tests/Connection.hs
View
@@ -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)
61 tls-extra.cabal
View
@@ -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.

Michael Snoyman

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?

Vincent Hanquez
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 ?

Michael Snoyman

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.

Vincent Hanquez
Owner

That's a good suggestion thanks.

Something went wrong with that request. Please try again.