tls-extra 0.4.2.1 → 0.4.3
raw patch · 4 files changed
+36/−24 lines, 4 filesdep ~certificatedep ~tls
Dependency ranges changed: certificate, tls
Files
- Examples/SimpleClient.hs +13/−6
- Examples/Stunnel.hs +11/−12
- Network/TLS/Extra/Certificate.hs +9/−3
- tls-extra.cabal +3/−3
Examples/SimpleClient.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} import Network.BSD import Network.Socket import Network.TLS@@ -6,10 +7,13 @@ 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 = False+validateCert = True debug = False ciphers :: [Cipher]@@ -26,7 +30,7 @@ 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)+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) dsth <- socketToHandle sock ReadWriteMode ctx <- client params rng dsth f ctx@@ -52,15 +56,17 @@ main = do sStorage <- newIORef undefined- let hostname = "localhost"- let port = 2001- runTLS (getDefaultParams sStorage Nothing) hostname port $ \ctx -> do+ 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+ d <- recvData' ctx bye ctx LC.putStrLn d return ()+{- session <- readIORef sStorage runTLS (getDefaultParams sStorage $ Just session) hostname port $ \ctx -> do handshake ctx@@ -69,3 +75,4 @@ bye ctx LC.putStrLn d return ()+-}
Examples/Stunnel.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} import Network.BSD import Network.Socket import System.IO-import System.IO.Error hiding (try)+import System.IO.Error hiding (try, catch) import System.Console.CmdArgs import qualified Data.ByteString as B@@ -10,8 +11,8 @@ import Control.Concurrent (forkIO) import Control.Concurrent.MVar-import Control.Exception (finally, try, throw)-import Control.Monad (when, forever, unless)+import Control.Exception (finally, try, throw, catch, SomeException)+import Control.Monad (when, forever) import Data.Char (isDigit) @@ -23,6 +24,8 @@ import Network.TLS import Network.TLS.Extra +import Prelude hiding (catch)+ ciphers :: [Cipher] ciphers = [ cipher_AES128_SHA1@@ -45,14 +48,12 @@ tlsclient srchandle dsthandle = do hSetBuffering srchandle NoBuffering - success <- handshake dsthandle- unless success $ do- error "client: handshake failed"+ handshake dsthandle _ <- forkIO $ forever $ do dat <- recvData dsthandle putStrLn ("received " ++ show dat)- L.hPut srchandle dat+ B.hPut srchandle dat loopUntil $ do b <- readOne srchandle putStrLn ("sending " ++ show b)@@ -68,9 +69,7 @@ tlsserver srchandle dsthandle = do hSetBuffering dsthandle NoBuffering - success <- handshake srchandle- unless success $ do- error "server: handshake failed"+ handshake srchandle loopUntil $ do d <- recvData srchandle@@ -200,7 +199,7 @@ connectAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol catch (connect sock sockaddr)- (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) return $ StunnelSocket sock connectAddressDescription (AddrFD h1 h2) = do@@ -209,7 +208,7 @@ listenAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol catch (bindSocket sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1)- (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))+ (\(e :: SomeException) -> sClose sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) return $ StunnelSocket sock listenAddressDescription (AddrFD _ _) = do
Network/TLS/Extra/Certificate.hs view
@@ -152,10 +152,16 @@ certificateVerifyDomain :: String -> [X509] -> TLSCertificateUsage certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list") certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) =- case lookup oidCommonName $ certSubjectDN cert of- Nothing -> rejectMisc "no commonname OID in certificate cannot match to FQDN"- Just (_, val) -> matchDomain (splitDot val)+ let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ certSubjectDN cert)+ ++ maybe [] (maybe [] toAltName . extensionGet) (certExtensions cert) in+ orUsage $ map (matchDomain . splitDot) names where+ orUsage [] = rejectMisc "FQDN do not match this certificate"+ orUsage (x:xs)+ | x == CertificateUsageAccept = CertificateUsageAccept+ | otherwise = orUsage xs++ toAltName (ExtSubjectAltName l) = l matchDomain l | length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain" | head l == "*" = wildcardMatch (reverse $ drop 1 l)
tls-extra.cabal view
@@ -1,5 +1,5 @@ Name: tls-extra-Version: 0.4.2.1+Version: 0.4.3 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.4 && < 0.9+ , tls >= 0.9.0 && < 1.0.0 , mtl , network >= 2.3 , cryptohash >= 0.6@@ -36,7 +36,7 @@ , vector , crypto-api >= 0.5 , cryptocipher >= 0.3.0- , certificate >= 1.0.0 && < 1.1.0+ , certificate >= 1.1.0 && < 1.2.0 , text >= 0.5 && < 1.0 , time Exposed-modules: Network.TLS.Extra