snap-server 0.5.2 → 0.5.3
raw patch · 14 files changed
+245/−523 lines, 14 filesdep +HsOpenSSLdep ~case-insensitivedep ~snap-coredep ~time
Dependencies added: HsOpenSSL
Dependency ranges changed: case-insensitive, snap-core, time
Files
- README.md +6/−5
- snap-server.cabal +11/−12
- src/Snap/Internal/Http/Server.hs +2/−2
- src/Snap/Internal/Http/Server/Backend.hs +14/−5
- src/Snap/Internal/Http/Server/Date.hs +10/−54
- src/Snap/Internal/Http/Server/GnuTLS.hs +0/−392
- src/Snap/Internal/Http/Server/HttpPort.hs +2/−1
- src/Snap/Internal/Http/Server/ListenHelpers.hs +11/−13
- src/Snap/Internal/Http/Server/TLS.hs +171/−0
- src/Snap/Internal/Http/Server/gnutls_helpers.c +0/−17
- test/snap-server-testsuite.cabal +15/−21
- test/suite/Snap/Internal/Http/Server/Tests.hs +1/−0
- test/suite/Test/Blackbox.hs +1/−0
- test/suite/TestSuite.hs +1/−1
README.md view
@@ -36,7 +36,7 @@ scalable socket event processing. If you would like SSL support, `snap-server` requires the-[gnutls](http://www.gnu.org/software/gnutls/) library.+[openssl](http://www.openssl.org/) library. ## Building snap-server@@ -51,11 +51,11 @@ cabal install -flibev -And if you would like SSL support, pass the `gnutls` flag to `cabal install`:+And if you would like SSL support, pass the `openssl` flag to `cabal install`: - cabal install -fgnutls+ cabal install -fopenssl -Note that the "`-flibev`" and "`-fgnutls`" flags are not mutually-exclusive,+Note that the "`-flibev`" and "`-fopenssl`" flags are not mutually-exclusive, and if you would like you can use them together. @@ -76,7 +76,8 @@ $ cabal configure # for the stock backend, or.. $ cabal configure -flibev # for the libev backend, and/or..- $ cabal configure -fgnutls # for the SSL backend+ $ cabal configure -fopenssl # for the SSL backend+ $ cabal build From here you can invoke the testsuite by running:
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.5.2+version: 0.5.3 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in@@ -70,8 +70,8 @@ optimizations such as C routines will be used. Default: False -Flag gnutls- Description: Enable https support using the libgnutls library.+Flag openssl+ Description: Enable https support using the HsOpenSSL library. Default: False @@ -92,10 +92,10 @@ Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Backend, Snap.Internal.Http.Server.ListenHelpers,- Snap.Internal.Http.Server.GnuTLS, Snap.Internal.Http.Server.HttpPort,- Snap.Internal.Http.Server.TimeoutManager, Snap.Internal.Http.Server.SimpleBackend,+ Snap.Internal.Http.Server.TimeoutManager,+ Snap.Internal.Http.Server.TLS, Snap.Internal.Http.Server.LibevBackend build-depends:@@ -108,7 +108,7 @@ blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums,- case-insensitive >= 0.2 && < 0.3,+ case-insensitive >= 0.2 && < 0.4, containers, directory-tree, enumerator >= 0.4.13.1 && <0.5,@@ -118,10 +118,10 @@ murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale,- snap-core >= 0.5.2 && <0.6,+ snap-core >= 0.5.3 && <0.6, template-haskell, text >= 0.11 && <0.12,- time,+ time >= 1.0 && < 1.4, transformers, unix-compat == 0.2.*, vector >= 0.7 && <0.8,@@ -137,10 +137,9 @@ build-depends: hlibev >= 0.2.8 && < 0.3 cpp-options: -DLIBEV - if flag(gnutls)- extra-libraries: gnutls gcrypt- cpp-options: -DGNUTLS- c-sources: src/Snap/Internal/Http/Server/gnutls_helpers.c+ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL >= 0.10 && <0.11 if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE
src/Snap/Internal/Http/Server.hs view
@@ -47,7 +47,7 @@ import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.HttpPort-import qualified Snap.Internal.Http.Server.GnuTLS as TLS+import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Http.Server.SimpleBackend import Snap.Internal.Http.Server.LibevBackend @@ -270,7 +270,7 @@ tickle = go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do return ()- , Handler $ \(e :: HttpParseException) -> do+ , Handler $ \(_ :: HttpParseException) -> do return () , Handler $ \(e :: AsyncException) -> do throwIO e
src/Snap/Internal/Http/Server/Backend.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Backend where {-@@ -13,6 +14,11 @@ -} +#ifdef OPENSSL+import OpenSSL.Session+#endif++import GHC.Exts (Any) import Data.ByteString (ByteString) import Foreign import Foreign.C@@ -82,16 +88,19 @@ ------------------------------------------------------------------------------ data ListenSocket = ListenHttp Socket- | ListenHttps Socket (Ptr Word) (Ptr Word)-+#ifdef OPENSSL+ | ListenHttps Socket SSLContext+#else+ | ListenHttps Socket ()+#endif instance Show ListenSocket where- show (ListenHttp s) = "ListenHttp (" ++ show s ++ ")"- show (ListenHttps s _ _) = "ListenHttps (" ++ show s ++ ")"+ show (ListenHttp s) = "ListenHttp (" ++ show s ++ ")"+ show (ListenHttps s _) = "ListenHttps (" ++ show s ++ ")" ------------------------------------------------------------------------------ data NetworkSession = NetworkSession { _socket :: CInt- , _session :: Ptr Word+ , _session :: Any -- ^ brutal hack. , _recvLen :: Int }
src/Snap/Internal/Http/Server/Date.hs view
@@ -6,35 +6,21 @@ , getLogDateString , getCurrentDateTime) where -import Control.Concurrent import Control.Exception import Control.Monad import Data.ByteString (ByteString) import Data.IORef-import Data.Maybe import Foreign.C.Types import System.IO.Unsafe import System.PosixCompat.Time import Snap.Internal.Http.Types (formatHttpTime, formatLogTime) --- Here comes a dirty hack. We don't want to be wasting context switches--- building date strings, so we're only going to compute one every two--- seconds. (Approximate timestamps to within a couple of seconds are OK here,--- and we'll reduce overhead.)------ Note that we also don't want to wake up a potentially sleeping CPU by just--- running the computation on a timer. We'll allow client traffic to trigger--- the process.- ------------------------------------------------------------------------------ data DateState = DateState { _cachedDateString :: !(IORef ByteString) , _cachedLogString :: !(IORef ByteString)- , _cachedDate :: !(IORef CTime)- , _valueIsOld :: !(IORef Bool)- , _morePlease :: !(MVar ())- , _dateThread :: !(MVar ThreadId)+ , _lastFetchTime :: !(IORef CTime) } @@ -45,16 +31,8 @@ bs1 <- newIORef s1 bs2 <- newIORef s2 dt <- newIORef date- ov <- newIORef False- th <- newEmptyMVar- mp <- newMVar () - let d = DateState bs1 bs2 dt ov mp th-- t <- forkIO $ dateThread d- putMVar th t-- return d+ return $! DateState bs1 bs2 dt ------------------------------------------------------------------------------@@ -68,12 +46,11 @@ ------------------------------------------------------------------------------ updateState :: DateState -> IO ()-updateState (DateState dateString logString time valueIsOld _ _) = do+updateState (DateState dateString logString time) = do (s1,s2,now) <- fetchTime atomicModifyIORef dateString $ const (s1,()) atomicModifyIORef logString $ const (s2,()) atomicModifyIORef time $ const (now,())- writeIORef valueIsOld False -- force values in the iorefs to prevent thunk buildup !_ <- readIORef dateString@@ -84,48 +61,27 @@ -------------------------------------------------------------------------------dateThread :: DateState -> IO ()-dateThread ds@(DateState _ _ _ valueIsOld morePlease _) = loop- where- loop = do- b <- tryTakeMVar morePlease- when (isNothing b) $ do- writeIORef valueIsOld True- takeMVar morePlease-- updateState ds- threadDelay 2000000- loop--------------------------------------------------------------------------------- ensureFreshDate :: IO ()-ensureFreshDate = block $ do- old <- readIORef $ _valueIsOld dateState- _ <- tryPutMVar (_morePlease dateState) ()-- -- if the value is not fresh we will tickle the date thread but also fetch- -- the new value immediately; we used to block but we'll do a little extra- -- work to avoid a delay- when old $ updateState dateState+ensureFreshDate = mask_ $ do+ now <- epochTime+ old <- readIORef $ _lastFetchTime dateState+ when (now > old) $ updateState dateState ------------------------------------------------------------------------------ getDateString :: IO ByteString-getDateString = block $ do+getDateString = mask_ $ do ensureFreshDate readIORef $ _cachedDateString dateState ------------------------------------------------------------------------------ getLogDateString :: IO ByteString-getLogDateString = block $ do+getLogDateString = mask_ $ do ensureFreshDate readIORef $ _cachedLogString dateState ------------------------------------------------------------------------------ getCurrentDateTime :: IO CTime-getCurrentDateTime = block $ do- ensureFreshDate- readIORef $ _cachedDate dateState+getCurrentDateTime = epochTime
− src/Snap/Internal/Http/Server/GnuTLS.hs
@@ -1,392 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Snap.Internal.Http.Server.GnuTLS- ( GnuTLSException(..)- , initTLS- , stopTLS- , bindHttps- , freePort- , createSession- , endSession- , recv- , send- ) where----------------------------------------------------------------------------------import Control.Exception-import Data.ByteString (ByteString)-import Data.Dynamic-import Foreign.C--import Snap.Internal.Debug-import Snap.Internal.Http.Server.Backend--#ifdef GNUTLS-import qualified Data.ByteString as B-import Data.ByteString.Internal (w2c)-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BI-import Foreign-import qualified Network.Socket as Socket-#endif----------------------------------------------------------------------------------data GnuTLSException = GnuTLSException String- deriving (Show, Typeable)-instance Exception GnuTLSException--#ifndef GNUTLS--initTLS :: IO ()-initTLS = throwIO $ GnuTLSException "TLS is not supported"--stopTLS :: IO ()-stopTLS = return ()--bindHttps :: ByteString -> Int -> FilePath -> FilePath -> IO ListenSocket-bindHttps _ _ _ _ = throwIO $ GnuTLSException "TLS is not supported"--freePort :: ListenSocket -> IO ()-freePort _ = return ()--createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession _ _ _ _ = throwIO $ GnuTLSException "TLS is not supported"--endSession :: NetworkSession -> IO ()-endSession _ = return ()--send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send _ _ _ _ = return ()--recv :: IO b -> NetworkSession -> IO (Maybe ByteString)-recv _ _ = throwIO $ GnuTLSException "TLS is not supported"--#else------------------------------------------------------------------------------------ | Init-initTLS :: IO ()-initTLS = gnutls_set_threading_helper >>- throwErrorIf "TLS init" gnutls_global_init----------------------------------------------------------------------------------stopTLS :: IO ()-stopTLS = gnutls_global_deinit------------------------------------------------------------------------------------ | Binds ssl port-bindHttps :: ByteString- -> Int- -> FilePath- -> FilePath- -> IO ListenSocket-bindHttps bindAddress bindPort cert key = do- sock <- Socket.socket Socket.AF_INET Socket.Stream 0- addr <- getHostAddr bindPort bindAddress- Socket.setSocketOption sock Socket.ReuseAddr 1- Socket.bindSocket sock addr- Socket.listen sock 150-- creds <- loadCredentials cert key- dh <- regenerateDHParam creds-- return $ ListenHttps sock (castPtr creds) (castPtr dh)----------------------------------------------------------------------------------loadCredentials :: FilePath --- ^ Path to certificate- -> FilePath --- ^ Path to key- -> IO (Ptr GnuTLSCredentials)-loadCredentials cert key = alloca $ \cPtr -> do- throwErrorIf "TLS allocate" $ gnutls_certificate_allocate_credentials cPtr- creds <- peek cPtr-- withCString cert $ \certstr -> withCString key $ \keystr ->- throwErrorIf "TLS set Certificate" $- gnutls_certificate_set_x509_key_file- creds certstr keystr gnutls_x509_fmt_pem-- return creds----------------------------------------------------------------------------------regenerateDHParam :: Ptr GnuTLSCredentials -> IO (Ptr GnuTLSDHParam)-regenerateDHParam creds = alloca $ \dhptr -> do- throwErrorIf "TLS allocate" $ gnutls_dh_params_init dhptr- dh <- peek dhptr- throwErrorIf "TLS DHParm" $ gnutls_dh_params_generate2 dh 1024- gnutls_certificate_set_dh_params creds dh- return dh----------------------------------------------------------------------------------freePort :: ListenSocket -> IO ()-freePort (ListenHttps _ creds dh) = do- gnutls_certificate_free_credentials $ castPtr creds- gnutls_dh_params_deinit $ castPtr dh-freePort _ = return ()----------------------------------------------------------------------------------createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession-createSession (ListenHttps _ creds _) recvSize socket on_block =- alloca $ \sPtr -> do- throwErrorIf "TLS allocate" $ gnutls_init sPtr 1- session <- peek sPtr- finishInit session `onException` gnutls_deinit session- where- finishInit session = do- throwErrorIf "TLS session" $- gnutls_credentials_set session 1 $ castPtr creds- throwErrorIf "TLS session" $ gnutls_set_default_priority session- gnutls_certificate_send_x509_rdn_sequence session 1- gnutls_session_enable_compatibility_mode session- let s = NetworkSession socket (castPtr session) $- fromIntegral recvSize- gnutls_transport_set_ptr session $ intPtrToPtr $ fromIntegral $ socket- handshake s on_block- return s--createSession _ _ _ _ = error "Invalid socket"----------------------------------------------------------------------------------endSession :: NetworkSession -> IO ()-endSession (NetworkSession _ session _) = do- throwErrorIf "TLS bye" $ gnutls_bye (castPtr session) 1 `finally` do- gnutls_deinit $ castPtr session----------------------------------------------------------------------------------handshake :: NetworkSession -> IO () -> IO ()-handshake s@(NetworkSession { _session = session}) on_block = do- rc <- gnutls_handshake $ castPtr session- case rc of- x | x >= 0 -> return ()- | isIntrCode x -> handshake s on_block- | isAgainCode x -> on_block >> handshake s on_block- | otherwise -> throwError "TLS handshake" rc----------------------------------------------------------------------------------send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()-send tickleTimeout onBlock (NetworkSession { _session = session}) bs =- BI.unsafeUseAsCStringLen bs $ uncurry loop- where- loop ptr len = do- sent <- gnutls_record_send (castPtr session) ptr $ fromIntegral len- let sent' = fromIntegral sent- case sent' of- x | x == 0 || x == len -> return ()- | x > 0 && x < len -> tickleTimeout >>- loop (plusPtr ptr sent') (len - sent')- | isIntrCode x -> loop ptr len- | isAgainCode x -> onBlock >> loop ptr len- | otherwise -> throwError "TLS send" $- fromIntegral sent'----------------------------------------------------------------------------------recv :: IO b -> NetworkSession -> IO (Maybe ByteString)-recv onBlock (NetworkSession _ session recvLen) = do- fp <- BI.mallocByteString recvLen- sz <- withForeignPtr fp loop- if (sz :: Int) <= 0- then return Nothing- else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz-- where- loop recvBuf = do- debug $ "TLS: calling record_recv with recvLen=" ++ show recvLen- size <- gnutls_record_recv (castPtr session) recvBuf $ toEnum recvLen- debug $ "TLS: record_recv returned with size=" ++ show size- let size' = fromIntegral size- case size' of- x | x >= 0 -> return x- | isIntrCode x -> loop recvBuf- | isAgainCode x -> onBlock >> loop recvBuf- | otherwise -> (throwError "TLS recv" $ fromIntegral size')----------------------------------------------------------------------------------throwError :: String -> ReturnCode -> IO a-throwError prefix rc = gnutls_strerror rc >>=- peekCString >>=- throwIO . GnuTLSException . (prefix'++)- where- prefix' = prefix ++ "<" ++ show rc ++ ">: "----------------------------------------------------------------------------------throwErrorIf :: String -> IO ReturnCode -> IO ()-throwErrorIf prefix action = do- rc <- action- if (rc < 0)- then throwError prefix rc- else return ()----------------------------------------------------------------------------------isAgainCode :: (Integral a) => a -> Bool-isAgainCode x = (fromIntegral x) == (-28 :: Int)----------------------------------------------------------------------------------isIntrCode :: (Integral a) => a -> Bool-isIntrCode x = (fromIntegral x) == (-52 :: Int)----------------------------------------------------------------------------------getHostAddr :: Int- -> ByteString- -> IO Socket.SockAddr-getHostAddr p s = do- h <- if s == "*"- then return Socket.iNADDR_ANY- else Socket.inet_addr (map w2c . B.unpack $ s)-- return $ Socket.SockAddrInet (fromIntegral p) h---- Types--newtype ReturnCode = ReturnCode CInt- deriving (Show, Eq, Ord, Num, Real, Enum, Integral)--data GnuTLSCredentials-data GnuTLSSession-data GnuTLSDHParam----------------------------------------------------------------------------------- Global init/errors--foreign import ccall safe- "gnutls_set_threading_helper"- gnutls_set_threading_helper :: IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_global_init"- gnutls_global_init :: IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_global_deinit"- gnutls_global_deinit :: IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_strerror"- gnutls_strerror :: ReturnCode -> IO CString----------------------------------------------------------------------------------- Sessions. All functions here except handshake and bye just--- allocate memory or update members of structures, so they are ok with--- unsafe ccall.--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_init"- gnutls_init :: Ptr (Ptr GnuTLSSession) -> CInt -> IO ReturnCode--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_deinit"- gnutls_deinit :: Ptr GnuTLSSession -> IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_handshake"- gnutls_handshake :: Ptr GnuTLSSession -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_bye"- gnutls_bye :: Ptr GnuTLSSession -> CInt -> IO ReturnCode--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_set_default_priority"- gnutls_set_default_priority :: Ptr GnuTLSSession -> IO ReturnCode--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_session_enable_compatibility_mode"- gnutls_session_enable_compatibility_mode :: Ptr GnuTLSSession -> IO ()--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_certificate_send_x509_rdn_sequence"- gnutls_certificate_send_x509_rdn_sequence- :: Ptr GnuTLSSession -> CInt -> IO ()----------------------------------------------------------------------------------- Certificates. Perhaps these could be unsafe but they are not performance--- critical, since they are called only once during server startup.--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_allocate_credentials"- gnutls_certificate_allocate_credentials- :: Ptr (Ptr GnuTLSCredentials) -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_free_credentials"- gnutls_certificate_free_credentials- :: Ptr GnuTLSCredentials -> IO ()--gnutls_x509_fmt_pem :: CInt-gnutls_x509_fmt_pem = 1--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_set_x509_key_file"- gnutls_certificate_set_x509_key_file- :: Ptr GnuTLSCredentials -> CString -> CString -> CInt -> IO ReturnCode------------------------------------------------------------------------------------ Credentials. This is ok as unsafe because it just sets members in the--- session structure.--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_credentials_set"- gnutls_credentials_set- :: Ptr GnuTLSSession -> CInt -> Ptr a -> IO ReturnCode----------------------------------------------------------------------------------- Records. These are marked unsafe because they are very performance--- critical. Since we are using non-blocking sockets send and recv will not--- block.--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_transport_set_ptr"- gnutls_transport_set_ptr :: Ptr GnuTLSSession -> Ptr a -> IO ()--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_record_recv"- gnutls_record_recv :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize--foreign import ccall unsafe- "gnutls/gnutls.h gnutls_record_send"- gnutls_record_send :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize----------------------------------------------------------------------------------- DHParam. Perhaps these could be unsafe but they are not performance--- critical.--foreign import ccall safe- "gnutls/gnutls.h gnutls_dh_params_init"- gnutls_dh_params_init :: Ptr (Ptr GnuTLSDHParam) -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_dh_params_deinit"- gnutls_dh_params_deinit :: Ptr GnuTLSDHParam -> IO ()--foreign import ccall safe- "gnutls/gnutls.h gnutls_dh_params_generate2"- gnutls_dh_params_generate2 :: Ptr GnuTLSDHParam -> CUInt -> IO ReturnCode--foreign import ccall safe- "gnutls/gnutls.h gnutls_certificate_set_dh_params"- gnutls_certificate_set_dh_params- :: Ptr GnuTLSCredentials -> Ptr GnuTLSDHParam -> IO ()--#endif
src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -18,6 +18,7 @@ import Foreign import Foreign.C import Network.Socket hiding (recv, send)+import Unsafe.Coerce #ifdef PORTABLE import qualified Network.Socket.ByteString as SB@@ -57,7 +58,7 @@ ------------------------------------------------------------------------------ createSession :: Int -> CInt -> IO () -> IO NetworkSession createSession buffSize s _ =- return $ NetworkSession s nullPtr $ fromIntegral buffSize+ return $ NetworkSession s (unsafeCoerce ()) $ fromIntegral buffSize ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/ListenHelpers.hs view
@@ -9,38 +9,36 @@ import Network.Socket (Socket, sClose) import Snap.Internal.Http.Server.Backend import qualified Snap.Internal.Http.Server.HttpPort as Http-import qualified Snap.Internal.Http.Server.GnuTLS as TLS+import qualified Snap.Internal.Http.Server.TLS as TLS ------------------------------------------------------------------------------ listenSocket :: ListenSocket -> Socket listenSocket (ListenHttp s) = s-listenSocket (ListenHttps s _ _) = s+listenSocket (ListenHttps s _) = s ------------------------------------------------------------------------------ isSecure :: ListenSocket -> Bool isSecure (ListenHttp _) = False-isSecure (ListenHttps _ _ _) = True+isSecure (ListenHttps _ _) = True ------------------------------------------------------------------------------ closeSocket :: ListenSocket -> IO ()-closeSocket (ListenHttp s) = sClose s-closeSocket p@(ListenHttps s _ _) = do TLS.freePort p- sClose s-+closeSocket (ListenHttp s) = sClose s+closeSocket p = TLS.freePort p ------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession createSession (ListenHttp _) = Http.createSession-createSession p@(ListenHttps _ _ _) = TLS.createSession p+createSession p@(ListenHttps _ _) = TLS.createSession p ------------------------------------------------------------------------------ endSession :: ListenSocket -> NetworkSession -> IO () endSession (ListenHttp _) = Http.endSession-endSession (ListenHttps _ _ _) = TLS.endSession+endSession (ListenHttps _ _) = TLS.endSession #ifdef PORTABLE@@ -56,14 +54,14 @@ recv :: ListenSocket -> Socket -> IO () -> NetworkSession -> IO (Maybe ByteString) recv (ListenHttp _) s = Http.recv s-recv (ListenHttps _ _ _) _ = TLS.recv+recv (ListenHttps _ _) _ = TLS.recv ------------------------------------------------------------------------------ send :: ListenSocket -> Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () send (ListenHttp _) s = Http.send s-send (ListenHttps _ _ _) _ = TLS.send+send (ListenHttps _ _) _ = TLS.send #else@@ -72,13 +70,13 @@ ------------------------------------------------------------------------------ recv :: ListenSocket -> IO () -> NetworkSession -> IO (Maybe ByteString) recv (ListenHttp _) = Http.recv-recv (ListenHttps _ _ _) = TLS.recv+recv (ListenHttps _ _) = TLS.recv ------------------------------------------------------------------------------ send :: ListenSocket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () send (ListenHttp _) = Http.send-send (ListenHttps _ _ _) = TLS.send+send (ListenHttps _ _) = TLS.send #endif
+ src/Snap/Internal/Http/Server/TLS.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Snap.Internal.Http.Server.TLS+ ( TLSException+ , initTLS+ , stopTLS+ , bindHttps+ , freePort+ , createSession+ , endSession+ , recv+ , send+ ) where+++------------------------------------------------------------------------------+import Control.Exception+import Data.ByteString.Char8 (ByteString)+import Data.Dynamic+import Foreign.C++import Snap.Internal.Debug+import Snap.Internal.Http.Server.Backend++#ifdef OPENSSL+import Control.Monad+import qualified Data.ByteString.Char8 as S+import qualified Network.Socket as Socket+import Network.Socket hiding ( accept+ , shutdown+ , recv+ , recvLen+ , send+ , socket+ )+import OpenSSL+import OpenSSL.Session+import qualified OpenSSL.Session as SSL+import Unsafe.Coerce+#endif+++data TLSException = TLSException String+ deriving (Show, Typeable)+instance Exception TLSException++#ifndef OPENSSL++initTLS :: IO ()+initTLS = throwIO $ TLSException "TLS is not supported"++stopTLS :: IO ()+stopTLS = return ()++bindHttps :: ByteString -> Int -> FilePath -> FilePath -> IO ListenSocket+bindHttps _ _ _ _ = throwIO $ TLSException "TLS is not supported"++freePort :: ListenSocket -> IO ()+freePort _ = return ()++createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession+createSession _ _ _ _ = throwIO $ TLSException "TLS is not supported"++endSession :: NetworkSession -> IO ()+endSession _ = return ()++send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()+send _ _ _ _ = return ()++recv :: IO b -> NetworkSession -> IO (Maybe ByteString)+recv _ _ = throwIO $ TLSException "TLS is not supported"++------------------------------------------------------------------------------+#else++initTLS :: IO ()+initTLS = withOpenSSL $ return ()++stopTLS :: IO ()+stopTLS = return ()++bindHttps :: ByteString+ -> Int+ -> FilePath+ -> FilePath+ -> IO ListenSocket+bindHttps bindAddress bindPort cert key = do+ sock <- Socket.socket Socket.AF_INET Socket.Stream 0+ addr <- getHostAddr bindPort bindAddress+ Socket.setSocketOption sock Socket.ReuseAddr 1+ Socket.bindSocket sock addr+ Socket.listen sock 150++ ctx <- context+ contextSetPrivateKeyFile ctx key+ contextSetCertificateFile ctx cert+ contextSetDefaultCiphers ctx+ certOK <- contextCheckPrivateKey ctx+ when (not certOK) $ do+ throwIO $ TLSException $ "OpenSSL says that the certificate "+ ++ "doesn't match the private key!"++ return $ ListenHttps sock ctx+++freePort :: ListenSocket -> IO ()+freePort (ListenHttps sock _) = Socket.sClose sock+freePort _ = return ()+++createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession+createSession (ListenHttps _ ctx) recvSize socket _ = do+ csock <- mkSocket socket AF_INET Stream defaultProtocol Connected+ ssl <- connection ctx csock++ accept ssl+ return $ NetworkSession socket (unsafeCoerce ssl) recvSize+createSession _ _ _ _ = error "can't call createSession on a ListenHttp"+++endSession :: NetworkSession -> IO ()+endSession (NetworkSession _ aSSL _) = shutdown ssl Bidirectional+ where+ ssl = unsafeCoerce aSSL+++send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()+send tickleTimeout _ (NetworkSession _ aSSL sz) bs = go bs+ where+ ssl = unsafeCoerce aSSL++ -- I think we have to chop the data into chunks here because HsOpenSSL+ -- won't; of course, blaze-builder may already be doing this for us, but I+ -- don't want to risk it.+ go !s = if S.null s+ then return ()+ else do+ SSL.write ssl a+ tickleTimeout+ go b++ where+ (a,b) = S.splitAt sz s+++recv :: IO b -> NetworkSession -> IO (Maybe ByteString)+recv _ (NetworkSession _ aSSL recvLen) = do+ b <- SSL.read ssl recvLen+ if S.null b then return Nothing else return $ Just b+ where+ ssl = unsafeCoerce aSSL+++------------------------------------------------------------------------------+getHostAddr :: Int+ -> ByteString+ -> IO Socket.SockAddr+getHostAddr p s = do+ h <- if s == "*"+ then return Socket.iNADDR_ANY+ else Socket.inet_addr (S.unpack $ s)++ return $ Socket.SockAddrInet (fromIntegral p) h+++#endif
− src/Snap/Internal/Http/Server/gnutls_helpers.c
@@ -1,17 +0,0 @@-#include <gnutls/gnutls.h>-#include <gcrypt.h>-#include <errno.h>-#include <pthread.h>-GCRY_THREAD_OPTION_PTHREAD_IMPL;--/* See http://www.gnu.org/software/gnutls/manual/html_node/Multi_002dthreaded-applications.html */--static int threading_init = 0;- -void gnutls_set_threading_helper()-{- if (!threading_init) {- gcry_control (GCRYCTL_SET_THREAD_CBS, &gcry_threads_pthread);- threading_init = 1;- }-}
test/snap-server-testsuite.cabal view
@@ -12,8 +12,8 @@ optimizations such as C routines will be used. Default: False -Flag gnutls- Description: Enable https support using the libgnutls library.+Flag openssl+ Description: Enable https support using the HsOpenSSL library. Default: False Executable testsuite@@ -37,7 +37,6 @@ directory-tree, enumerator >= 0.4.13.1 && <0.5, filepath,- haskell98, http-enumerator >= 0.6.5.4 && <0.7, HUnit >= 1.2 && < 2, monads-fd >= 0.1.0.4 && <0.2,@@ -46,7 +45,7 @@ old-locale, parallel > 2, process,- snap-core >= 0.5.2 && <0.6,+ snap-core >= 0.5.3 && <0.6, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3,@@ -66,10 +65,9 @@ build-depends: hlibev >= 0.2.5 && < 0.3 cpp-options: -DLIBEV - if flag(gnutls)- extra-libraries: gnutls- cpp-options: -DGNUTLS- c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c+ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL >= 0.10 && <0.11 if flag(portable) || os(windows) cpp-options: -DPORTABLE@@ -100,7 +98,6 @@ directory-tree, enumerator >= 0.4.7 && <0.5, filepath,- haskell98, HUnit >= 1.2 && < 2, monads-fd >= 0.1.0.4 && <0.2, murmur-hash >= 0.1 && < 0.2,@@ -108,7 +105,7 @@ parallel > 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, network == 2.3.*,- snap-core >= 0.5.1 && <0.6,+ snap-core >= 0.5.3 && <0.6, template-haskell, time, transformers,@@ -127,10 +124,9 @@ build-depends: hlibev >= 0.2.5 && < 0.3 cpp-options: -DLIBEV - if flag(gnutls)- extra-libraries: gnutls- cpp-options: -DGNUTLS- c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c+ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL >= 0.10 && <0.11 if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE@@ -173,12 +169,11 @@ blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4,- case-insensitive >= 0.2 && < 0.3,+ case-insensitive >= 0.2 && < 0.5, containers, directory-tree, enumerator >= 0.4.7 && <0.5, filepath,- haskell98, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, monads-fd >= 0.1.0.4 && <0.2,@@ -186,7 +181,7 @@ network == 2.3.*, old-locale, parallel > 2,- snap-core >= 0.5.1 && <0.6,+ snap-core >= 0.5.3 && <0.6, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3,@@ -205,10 +200,9 @@ build-depends: hlibev >= 0.2.5 && < 0.3 cpp-options: -DLIBEV - if flag(gnutls)- extra-libraries: gnutls- cpp-options: -DGNUTLS- c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c+ if flag(openssl)+ cpp-options: -DOPENSSL+ build-depends: HsOpenSSL >= 0.10 && <0.11 if flag(portable) || os(windows) cpp-options: -DPORTABLE
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-} module Snap.Internal.Http.Server.Tests ( tests ) where
test/suite/Test/Blackbox.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE BangPatterns #-} module Test.Blackbox ( tests
test/suite/TestSuite.hs view
@@ -22,7 +22,7 @@ ports :: Int -> [Int] ports sp = [sp..] -#ifdef GNUTLS+#ifdef OPENSSL sslports :: Int -> [Maybe Int] sslports sp = map Just [(sp + 100)..] #else