diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -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 diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -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 diff --git a/src/Snap/Internal/Http/Server/Backend.hs b/src/Snap/Internal/Http/Server/Backend.hs --- a/src/Snap/Internal/Http/Server/Backend.hs +++ b/src/Snap/Internal/Http/Server/Backend.hs @@ -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 } diff --git a/src/Snap/Internal/Http/Server/Date.hs b/src/Snap/Internal/Http/Server/Date.hs --- a/src/Snap/Internal/Http/Server/Date.hs +++ b/src/Snap/Internal/Http/Server/Date.hs @@ -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 diff --git a/src/Snap/Internal/Http/Server/GnuTLS.hs b/src/Snap/Internal/Http/Server/GnuTLS.hs deleted file mode 100644 --- a/src/Snap/Internal/Http/Server/GnuTLS.hs +++ /dev/null @@ -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 diff --git a/src/Snap/Internal/Http/Server/HttpPort.hs b/src/Snap/Internal/Http/Server/HttpPort.hs --- a/src/Snap/Internal/Http/Server/HttpPort.hs +++ b/src/Snap/Internal/Http/Server/HttpPort.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server/ListenHelpers.hs b/src/Snap/Internal/Http/Server/ListenHelpers.hs --- a/src/Snap/Internal/Http/Server/ListenHelpers.hs +++ b/src/Snap/Internal/Http/Server/ListenHelpers.hs @@ -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 diff --git a/src/Snap/Internal/Http/Server/TLS.hs b/src/Snap/Internal/Http/Server/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/TLS.hs @@ -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 diff --git a/src/Snap/Internal/Http/Server/gnutls_helpers.c b/src/Snap/Internal/Http/Server/gnutls_helpers.c deleted file mode 100644 --- a/src/Snap/Internal/Http/Server/gnutls_helpers.c +++ /dev/null @@ -1,17 +0,0 @@ -#include -#include -#include -#include -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; - } -} diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -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 diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} module Snap.Internal.Http.Server.Tests ( tests ) where diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs --- a/test/suite/Test/Blackbox.hs +++ b/test/suite/Test/Blackbox.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE BangPatterns #-} module Test.Blackbox ( tests diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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