@@ -8,7 +8,6 @@ import qualified Network.TLS as TLS
88import Network.Wai.Handler.Warp
99import Network.Wai
1010import Network.Socket
11−import System.IO
1211import Crypto.Random
1312import qualified Data.ByteString.Lazy as L
1413import Data.Conduit.Binary (sourceFileRange)
@@ -23,6 +22,10 @@ import Data.Conduit.Network (bindPort)
2322import Data.Either (rights)
2423import Control.Applicative ((<$>))
2524import qualified Data.PEM as PEM
25+import Data.Conduit.Network (sourceSocket, sinkSocket)
26+import Data.Maybe (fromMaybe)
27+import qualified Data.IORef as I
28+import Control.Monad (unless)
2629
2730data TLSSettings = TLSSettings
2831 { certFile :: FilePath
@@ -44,29 +47,48 @@ runTLS tset set app = do
4447 sClose
4548 (\sock -> runSettingsConnection set (getter params sock) app)
4649 where
47− retry :: TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr)
48− retry a b _ = getter a b
50+ retry :: Socket -> TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr)
51+ retry s a b _ = sClose s >> getter a b
4952
5053 getter params sock = do
5154 (s, sa) <- accept sock
52− handle (retry params sock) $ do
53− h <- socketToHandle s ReadWriteMode
54− hSetBuffering h NoBuffering
55− gen <- newGenIO
56− ctx <- TLS.server params (gen :: SystemRandom) h
57− TLS.handshake ctx
58− let conn = Connection
59− { connSendMany = TLS.sendData ctx . L.fromChunks
60− , connSendAll = TLS.sendData ctx . L.fromChunks . return
61− , connSendFile = \fp offset len _th headers -> do
62− TLS.sendData ctx $ L.fromChunks headers
63− C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)
64− , connClose = do
65− TLS.bye ctx
66− hClose h
67− , connRecv = TLS.recvData ctx
68− }
69− return (conn, sa)
55+ handle (retry s params sock) $ do
56+ (fromClient, firstBS) <- sourceSocket s C.$$+ CL.peek
57+ let toClient = sinkSocket s
58+ ifromClient <- I.newIORef fromClient
59+ let getNext sink = do
60+ fromClient' <- I.readIORef ifromClient
61+ (fromClient'', bs) <- fromClient' C.$$++ sink
62+ I.writeIORef ifromClient fromClient''
63+ return bs
64+ if maybe False (B.all (\w -> w < 127 && w > 8) . B.take 5) firstBS
65+ then do
66+ let conn = (socketConnection s)
67+ { connRecv = getNext $ fmap (fromMaybe B.empty) C.await
68+ }
69+ return (conn, sa)
70+ else do
71+ gen <- newGenIO
72+ ctx <- TLS.serverWith
73+ params
74+ (gen :: SystemRandom)
75+ s
76+ (return ()) -- flush
77+ (\bs -> C.yield bs C.$$ toClient)
78+ (getNext . takeMost)
79+ TLS.handshake ctx
80+ let conn = Connection
81+ { connSendMany = TLS.sendData ctx . L.fromChunks
82+ , connSendAll = TLS.sendData ctx . L.fromChunks . return
83+ , connSendFile = \fp offset len _th headers -> do
84+ TLS.sendData ctx $ L.fromChunks headers
85+ C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)
86+ , connClose = do
87+ TLS.bye ctx
88+ sClose s
89+ , connRecv = TLS.recvData ctx
90+ }
91+ return (conn, sa)
7092
7193-- taken from stunnel example in tls-extra
7294ciphers :: [TLS.Cipher]
@@ -97,3 +119,13 @@ readPrivateKey filepath = do
97119 where parseKey (Right pems) = map (fmap (TLS.PrivRSA . snd) . KeyRSA.decodePrivate . L.fromChunks . (:[]) . PEM.pemContent)
98120 $ filter ((== "RSA PRIVATE KEY") . PEM.pemName) pems
99121 parseKey (Left err) = error $ "Cannot parse PEM file: " ++ err
122+
123+takeMost :: Monad m => Int -> C.GLSink B.ByteString m B.ByteString
124+takeMost i =
125+ C.await >>= maybe (return B.empty) go
126+ where
127+ go bs = do
128+ unless (B.null y) $ C.leftover y
129+ return x
130+ where
131+ (x, y) = B.splitAt i bs