warp-tls 1.2.1 → 1.3.0
raw patch · 2 files changed
+59/−27 lines, 2 filesdep ~conduitdep ~network-conduitdep ~tls
Dependency ranges changed: conduit, network-conduit, tls, wai, warp
Files
- Network/Wai/Handler/WarpTLS.hs +53/−21
- warp-tls.cabal +6/−6
Network/Wai/Handler/WarpTLS.hs view
@@ -8,7 +8,6 @@ import Network.Wai.Handler.Warp import Network.Wai import Network.Socket-import System.IO import Crypto.Random import qualified Data.ByteString.Lazy as L import Data.Conduit.Binary (sourceFileRange)@@ -23,6 +22,10 @@ import Data.Either (rights) import Control.Applicative ((<$>)) import qualified Data.PEM as PEM+import Data.Conduit.Network (sourceSocket, sinkSocket)+import Data.Maybe (fromMaybe)+import qualified Data.IORef as I+import Control.Monad (unless) data TLSSettings = TLSSettings { certFile :: FilePath@@ -44,29 +47,48 @@ sClose (\sock -> runSettingsConnection set (getter params sock) app) where- retry :: TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr)- retry a b _ = getter a b+ retry :: Socket -> TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr)+ retry s a b _ = sClose s >> getter a b getter params sock = do (s, sa) <- accept sock- handle (retry params sock) $ do- h <- socketToHandle s ReadWriteMode- hSetBuffering h NoBuffering- gen <- newGenIO- ctx <- TLS.server params (gen :: SystemRandom) h- TLS.handshake ctx- let conn = Connection- { connSendMany = TLS.sendData ctx . L.fromChunks- , connSendAll = TLS.sendData ctx . L.fromChunks . return- , connSendFile = \fp offset len _th headers -> do- TLS.sendData ctx $ L.fromChunks headers- C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)- , connClose = do- TLS.bye ctx- hClose h- , connRecv = TLS.recvData ctx- }- return (conn, sa)+ handle (retry s params sock) $ do+ (fromClient, firstBS) <- sourceSocket s C.$$+ CL.peek+ let toClient = sinkSocket s+ ifromClient <- I.newIORef fromClient+ let getNext sink = do+ fromClient' <- I.readIORef ifromClient+ (fromClient'', bs) <- fromClient' C.$$++ sink+ I.writeIORef ifromClient fromClient''+ return bs+ if maybe False ((== 0x16) . fst) (firstBS >>= B.uncons)+ then do+ gen <- newGenIO+ ctx <- TLS.serverWith+ params+ (gen :: SystemRandom)+ s+ (return ()) -- flush+ (\bs -> C.yield bs C.$$ toClient)+ (getNext . takeMost)+ TLS.handshake ctx+ let conn = Connection+ { connSendMany = TLS.sendData ctx . L.fromChunks+ , connSendAll = TLS.sendData ctx . L.fromChunks . return+ , connSendFile = \fp offset len _th headers -> do+ TLS.sendData ctx $ L.fromChunks headers+ C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)+ , connClose = do+ TLS.bye ctx+ sClose s+ , connRecv = TLS.recvData ctx+ }+ return (conn, sa)+ else do+ let conn = (socketConnection s)+ { connRecv = getNext $ fmap (fromMaybe B.empty) C.await+ }+ return (conn, sa) -- taken from stunnel example in tls-extra ciphers :: [TLS.Cipher]@@ -97,3 +119,13 @@ where parseKey (Right pems) = map (fmap (TLS.PrivRSA . snd) . KeyRSA.decodePrivate . L.fromChunks . (:[]) . PEM.pemContent) $ filter ((== "RSA PRIVATE KEY") . PEM.pemName) pems parseKey (Left err) = error $ "Cannot parse PEM file: " ++ err++takeMost :: Monad m => Int -> C.GLSink B.ByteString m B.ByteString+takeMost i =+ C.await >>= maybe (return B.empty) go+ where+ go bs = do+ unless (B.null y) $ C.leftover y+ return x+ where+ (x, y) = B.splitAt i bs
warp-tls.cabal view
@@ -1,5 +1,5 @@ Name: warp-tls-Version: 1.2.1+Version: 1.3.0 Synopsis: SSL support for Warp via the TLS package License: MIT License-file: LICENSE@@ -15,16 +15,16 @@ Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.9- , wai >= 1.2 && < 1.3- , warp >= 1.2.2 && < 1.3+ , wai >= 1.3 && < 1.4+ , warp >= 1.3 && < 1.4 , transformers >= 0.2 && < 0.4- , conduit >= 0.4 && < 0.5- , network-conduit >= 0.4 && < 0.5+ , conduit >= 0.5 && < 0.6+ , network-conduit >= 0.5 && < 0.6 , certificate >= 1.2 && < 1.3 , pem >= 0.1 && < 0.2 , cryptocipher >= 0.3 && < 0.4 , tls-extra >= 0.4.5 && < 0.5- , tls >= 0.9.3 && < 0.10+ , tls >= 0.9.6 && < 0.10 , crypto-api >= 0.8 && < 0.11 , network >= 2.2.1 && < 2.4 Exposed-modules: Network.Wai.Handler.WarpTLS