tls-extra 0.4.1 → 0.4.2
raw patch · 4 files changed
+119/−8 lines, 4 filesdep ~networkdep ~tlsnew-component:exe:simpleclient
Dependency ranges changed: network, tls
Files
- Examples/RetrieveCertificate.hs +19/−2
- Examples/SimpleClient.hs +71/−0
- Examples/Stunnel.hs +16/−4
- tls-extra.cabal +13/−2
Examples/RetrieveCertificate.hs view
@@ -5,6 +5,7 @@ import Data.Char import Data.IORef+import Data.Time.Clock import System.IO import Control.Monad@@ -26,7 +27,7 @@ return CertificateUsageAccept } ctx <- connectionClient s p params rng- handshake ctx+ _ <- handshake ctx bye ctx r <- readIORef ref case r of@@ -38,6 +39,8 @@ , port :: String , chain :: Bool , output :: String+ , verify :: Bool+ , verifyFQDN :: String } deriving (Show, Data, Typeable) progArgs = PArgs@@ -45,6 +48,8 @@ , port = "443" &= help "destination port to connect to" &= typ "port" , chain = False &= help "also output the chain of certificate used" , output = "pem" &= help "define the format of output (PEM by default)" &= typ "format"+ , verify = False &= help "verify the chain received with the trusted system certificates"+ , verifyFQDN = "" &= help "verify the chain against a specific fully qualified domain name (e.g. web.example.com)" &= explicit &= name "verify-domain-name" } &= summary "RetrieveCertificate remotely for SSL/TLS protocol" &= details [ "Retrieve the remote certificate and optionally its chain from a remote destination"@@ -61,7 +66,19 @@ case (chain a) of True -> forM_ (zip [0..] certs) $ \(n, cert) -> do- putStrLn ("###### Certificate " ++ show (n + 1) ++ " ######")+ 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 view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+import Network.BSD+import Network.Socket+import Network.TLS+import Network.TLS.Extra+import System.IO+import qualified Crypto.Random.AESCtr as RNG+import qualified Data.ByteString.Lazy.Char8 as LC++import Data.IORef++validateCert = False+debug = False++ciphers :: [Cipher]+ciphers =+ [ cipher_AES128_SHA1+ , cipher_AES256_SHA1+ , cipher_RC4_128_MD5+ , cipher_RC4_128_SHA1+ ]++runTLS params hostname portNumber f = do+ rng <- RNG.makeSystem+ he <- getHostByName hostname+ sock <- socket AF_INET Stream defaultProtocol+ let sockaddr = SockAddrInet portNumber (head $ hostAddresses he)+ catch (connect sock sockaddr)+ (\_ -> error ("cannot open socket " ++ show sockaddr) >> sClose sock)+ dsth <- socketToHandle sock ReadWriteMode+ ctx <- client params rng dsth+ f ctx+ hClose dsth++getDefaultParams sStorage session = defaultParams+ { pConnectVersion = TLS10+ , pAllowedVersions = [TLS10,TLS11,TLS12]+ , pCiphers = ciphers+ , pCertificates = []+ , pLogging = logging+ , onCertificatesRecv = crecv+ , onSessionEstablished = \s d -> writeIORef sStorage (s,d)+ , sessionResumeWith = session+ }+ where+ logging = if not debug then defaultLogging else defaultLogging+ { loggingPacketSent = putStrLn . ("debug: >> " ++)+ , loggingPacketRecv = putStrLn . ("debug: << " ++)+ }+ crecv = if validateCert then certificateVerifyChain else (\_ -> return CertificateUsageAccept)+++main = do+ sStorage <- newIORef undefined+ let hostname = "localhost"+ let port = 2001+ runTLS (getDefaultParams sStorage Nothing) hostname port $ \ctx -> do+ handshake ctx+ sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n"+ d <- recvData ctx+ bye ctx+ LC.putStrLn d+ return ()+ session <- readIORef sStorage+ runTLS (getDefaultParams sStorage $ Just session) hostname port $ \ctx -> do+ handshake ctx+ sendData ctx $ LC.pack "GET / HTTP/1.0\r\n\r\n"+ d <- recvData ctx+ bye ctx+ LC.putStrLn d+ return ()
Examples/Stunnel.hs view
@@ -9,6 +9,7 @@ import qualified Data.ByteString.Lazy as L import Control.Concurrent (forkIO)+import Control.Concurrent.MVar import Control.Exception (finally, try, throw) import Control.Monad (when, forever, unless) @@ -79,7 +80,7 @@ return False putStrLn "end" -clientProcess certs handle dsthandle dbg _ = do+clientProcess certs handle dsthandle dbg sessionStorage _ = do rng <- RNG.makeSystem let logging = if not dbg then defaultLogging else defaultLogging { loggingPacketSent = putStrLn . ("debug: send: " ++)@@ -93,7 +94,14 @@ , pWantClientCert = False , pLogging = logging }- ctx <- server serverstate rng handle+ 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@@ -131,6 +139,7 @@ , sourceType :: String , source :: String , debug :: Bool+ , disableSession :: Bool , certificate :: FilePath , key :: FilePath } deriving (Show, Data, Typeable)@@ -150,6 +159,7 @@ , 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"@@ -250,6 +260,8 @@ 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@@ -262,7 +274,7 @@ StunnelSocket dst -> socketToHandle dst ReadWriteMode _ <- forkIO $ finally- (clientProcess [(cert, Just pk)] srch dsth (debug pargs) addr >> return ())+ (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"@@ -272,4 +284,4 @@ x <- cmdArgsRun mode case x of Client _ _ _ _ _ _ -> doClient x- Server _ _ _ _ _ _ _ -> doServer x+ Server _ _ _ _ _ _ _ _ -> doServer x
tls-extra.cabal view
@@ -1,5 +1,5 @@ Name: tls-extra-Version: 0.4.1+Version: 0.4.2 Description: a set of extra definitions, default values and helpers for tls. License: BSD3@@ -28,7 +28,7 @@ Library Build-Depends: base > 3 && < 5- , tls >= 0.8.2 && < 0.9+ , tls >= 0.8.4 && < 0.9 , mtl , network >= 2.3 , cryptohash >= 0.6@@ -73,6 +73,17 @@ 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