packages feed

happstack-server-tls-cryptonite (empty) → 0.1.1

raw patch · 5 files changed

+336/−0 lines, 5 filesdep +basedep +bytestringdep +cryptonitesetup-changed

Dependencies added: base, bytestring, cryptonite, data-default-class, extensible-exceptions, happstack-server, hslogger, network, sendfile, time, tls, unix

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happstack-server-tls-cryptonite.cabal view
@@ -0,0 +1,38 @@+Name:                happstack-server-tls-cryptonite+Version:             0.1.1+Synopsis:            Extend happstack-server with native HTTPS support (TLS/SSL)+Description:         Extend happstack-server with native HTTPS support (TLS/SSL)+License:             BSD3+Author:              Andrey Sverdlichenko+Maintainer:          blaze@ruddy.ru+Copyright:           2012 Jeremy Shaw, 2015 Andrey Sverdlichenko+Category:            Web, Happstack+Build-type:          Simple+Cabal-version:       >=1.6++source-repository head+    type:     git+    location: https://github.com/rblaze/happstack-server-tls-cryptonite.git++Library+    hs-source-dirs:    src+    ghc-options:       -W -Wall -fno-warn-unused-do-bind+    Exposed-modules:   Happstack.Server.Internal.Cryptonite.TimeoutSocketTLS+                       Happstack.Server.Internal.Cryptonite.TLS+                       Happstack.Server.SimpleTLS++    Build-Depends:     base                  <  5,+                       bytestring            >= 0.9 && < 0.11,+                       cryptonite            >= 0.6,+                       data-default-class    >= 0.0.1,+                       extensible-exceptions == 0.1.*,+                       happstack-server      >= 6.6.4 && < 7.5,+                       hslogger              >=  1.1 && < 1.3,+                       network               >= 2.3 && < 2.7,+                       sendfile              == 0.7.*,+                       time                  >= 1.2 && < 1.6,+                       tls                   >= 1.2++    if !os(windows)+       Build-Depends:  unix+       cpp-options:    -DUNIX
+ src/Happstack/Server/Internal/Cryptonite/TLS.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+{- | core functions and types for HTTPS support+-}+module Happstack.Server.Internal.Cryptonite.TLS where++import Control.Concurrent                         (forkIO, killThread, myThreadId)+import Control.Exception.Extensible               as E+import Control.Monad                              (forever, when)+import Crypto.Random.EntropyPool+import Data.Default.Class+import Data.Time                                  (UTCTime)+import GHC.IO.Exception                           (IOErrorType(..))+import Happstack.Server.Internal.Listen           (listenOn)+import Happstack.Server.Internal.Handler          (request)+import Happstack.Server.Internal.Socket           (acceptLite)+import Happstack.Server.Internal.TimeoutManager   (cancel, initialize, register)+import Happstack.Server.Internal.Cryptonite.TimeoutSocketTLS as TSS+import Happstack.Server.Internal.Types            (Request, Response)+import Network.Socket                             (HostName, PortNumber, Socket, sClose, socketPort)+import Network.TLS+import Network.TLS.Extra.Cipher+import Happstack.Server.Types                     (LogAccess, logMAccess)+import System.IO.Error                            (ioeGetErrorType, isFullError, isDoesNotExistError)+import System.Log.Logger                          (Priority(..), logM)+#ifndef mingw32_HOST_OS+import System.Posix.Signals                       (Handler(Ignore), installHandler, openEndedPipe)+#endif+++-- | wrapper around 'logM' for this module+log':: Priority -> String -> IO ()+log' = logM "Happstack.Server.Internal.TLS"+++-- | configuration for using https:\/\/+data TLSConf = TLSConf {+      tlsPort      :: Int        -- port (usually 443)+    , tlsCert      :: FilePath   -- path to SSL certificate+    , tlsKey       :: FilePath   -- path to SSL private key+    , tlsCA        :: Maybe FilePath -- PEM encoded list of CA certificates+    , tlsTimeout   :: Int        -- kill connect of timeout (in seconds)+    , tlsLogAccess :: Maybe (LogAccess UTCTime) -- see 'logMAccess'+    , tlsValidator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly+    }++-- | a partially complete 'TLSConf' . You must sete 'tlsCert' and 'tlsKey' at a mininum.+nullTLSConf :: TLSConf+nullTLSConf =+    TLSConf { tlsPort      = 443+            , tlsCert      = ""+            , tlsKey       = ""+            , tlsCA        = Nothing+            , tlsTimeout   = 30+            , tlsLogAccess = Just logMAccess+            , tlsValidator = Nothing+            }+++-- | record that holds the 'Socket' and 'SSLContext' needed to start+-- the https:\/\/ event loop. Used with 'simpleHTTPWithSocket''+--+-- see also: 'httpOnSocket'+data HTTPS = HTTPS+    { httpsSocket :: Socket+    , sslContext  :: ServerParams+    }++-- | generate the 'HTTPS' record needed to start the https:\/\/ event loop+--+httpsOnSocket :: FilePath  -- ^ path to ssl certificate+              -> FilePath  -- ^ path to ssl private key+              -> Maybe FilePath -- ^ path to PEM encoded list of CA certificates+              -> Socket    -- ^ listening socket (on which listen() has been called, but not accept())+              -> IO HTTPS+httpsOnSocket cert key _ socket =+    do creds <- credentialLoadX509 cert key+       let credentials = either (\msg -> error $ "Can't load certificate " ++ cert ++ " and key " ++ key ++ ": " ++ msg) id creds+       let params = def {+            serverSupported = def { supportedCiphers = ciphersuite_strong },+            serverShared = def {+                sharedCredentials = Credentials [credentials]+             }+         }+--       case mca of+--         Nothing   -> return ()+--         (Just ca) -> SSL.contextSetCAFile ctx ca++       return (HTTPS socket params)++-- | accept a TLS connection+acceptTLS :: Socket      -- ^ the socket returned from 'acceptLite'+          -> ServerParams+          -> IO Context+acceptTLS sck params =+      handle (\ (e :: SomeException) -> sClose sck >> throwIO e) $ do+          ssl <- contextNew sck params+          handshake ssl+          return ssl++-- | https:// 'Request'/'Response' loop+--+-- This function initializes SSL, and starts accepting and handling+-- 'Request's and sending 'Respone's.+--+-- Each 'Request' is processed in a separate thread.+listenTLS :: TLSConf                  -- ^ tls configuration+          -> (Request -> IO Response) -- ^ request handler+          -> IO ()+listenTLS tlsConf hand =+    do+       tlsSocket <- listenOn (tlsPort tlsConf)+       https     <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) (tlsCA tlsConf) tlsSocket+       listenTLS' (tlsTimeout tlsConf) (tlsLogAccess tlsConf) https hand++-- | low-level https:// 'Request'/'Response' loop+--+-- This is the low-level loop that reads 'Request's and sends+-- 'Respone's. It assumes that SSL has already been initialized and+-- that socket is listening.+--+-- Each 'Request' is processed in a separate thread.+--+-- see also: 'listenTLS'+listenTLS' :: Int -> Maybe (LogAccess UTCTime) -> HTTPS -> (Request -> IO Response) -> IO ()+listenTLS' timeout mlog https@(HTTPS lsocket _) handler = do+#ifndef mingw32_HOST_OS+  installHandler openEndedPipe Ignore Nothing+#endif+  tm <- initialize (timeout * (10^(6 :: Int)))+  do let work :: (Socket, Context, HostName, PortNumber) -> IO ()+         work (socket, ssl, hn, p) =+             do -- add this thread to the timeout table+                tid     <- myThreadId+                thandle <- register tm $ do shutdownClose socket ssl+                                            killThread tid+                -- handle the request+                let timeoutIO = TSS.timeoutSocketIO thandle socket ssl++                request timeoutIO mlog (hn, fromIntegral p) handler+                            `E.catches` [ Handler ignoreConnectionAbruptlyTerminated+                                        , Handler ehs+                                        ]++                -- remove thread from timeout table+                cancel thandle++                -- close connection+                shutdownClose socket ssl++         loop :: IO ()+         loop = forever $ do -- do a normal accept+                             (sck, peer, port) <- acceptLite (httpsSocket https)+                             forkIO $ do -- do the TLS accept/handshake+                                         ssl <- acceptTLS sck (sslContext https)+                                         work (sck, ssl, peer, port)+                                           `catch` (\(e :: SomeException) -> do+                                                          shutdownClose sck ssl+                                                          throwIO e)+                             return ()+         pe e = log' ERROR ("ERROR in https accept thread: " ++ show e)+         infi = loop `catchSome` pe >> infi+     -- sockName <- getSocketName lsocket+     sockPort <- socketPort lsocket+     log' NOTICE ("Listening for https:// on port " ++ show sockPort)+     (infi `catch` (\e -> do log' ERROR ("https:// terminated by " ++ show (e :: SomeException))+                             throwIO e))+       `finally` (sClose lsocket)++         where+           shutdownClose :: Socket -> Context -> IO ()+           shutdownClose _ ssl =+               do bye ssl          `E.catch` ignoreException+                  contextClose ssl `E.catch` ignoreException++           -- exception handlers+           ignoreConnectionAbruptlyTerminated :: TLSException -> IO ()  -- FIXME+           ignoreConnectionAbruptlyTerminated _ = return ()++           ignoreSSLException :: TLSException -> IO ()+           ignoreSSLException _ = return ()++           ignoreException :: SomeException -> IO ()+           ignoreException _ = return ()++           ehs :: SomeException -> IO ()+           ehs x = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTPS request failed with: " ++ show x)++           catchSome op h =+               op `E.catches` [ Handler $ ignoreSSLException+                              , Handler $ \(e :: ArithException) -> h (toException e)+                              , Handler $ \(e :: ArrayException) -> h (toException e)+                              , Handler $ \(e :: IOException)    ->+                                  if isFullError e || isDoesNotExistError e || isResourceVanishedError e+                                  then return () -- h (toException e) -- we could log the exception, but there could be thousands of them+                                  else log' ERROR ("HTTPS accept loop ignoring " ++ show e)+                              ]+           isResourceVanishedError :: IOException -> Bool+           isResourceVanishedError = isResourceVanishedType . ioeGetErrorType+           isResourceVanishedType :: IOErrorType -> Bool+           isResourceVanishedType ResourceVanished = True+           isResourceVanishedType _                = False
+ src/Happstack/Server/Internal/Cryptonite/TimeoutSocketTLS.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{- |+-- borrowed from snap-server. Check there periodically for updates.+-}+module Happstack.Server.Internal.Cryptonite.TimeoutSocketTLS where++import           Control.Exception             (SomeException, catch)+import qualified Data.ByteString.Char8         as B+import qualified Data.ByteString.Lazy.Char8    as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString               as S+import qualified Happstack.Server.Internal.TimeoutManager as TM+import           Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))+import           Network.Socket                (Socket)+import           Network.Socket.SendFile (ByteCount, Offset)+import           Network.TLS+import           System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile)+import           System.IO.Unsafe (unsafeInterleaveIO)++sPutLazyTickle :: TM.Handle -> Context -> L.ByteString -> IO ()+sPutLazyTickle thandle ssl cs =+    do L.foldrChunks (\c rest -> sendData ssl (L.fromStrict c) >> TM.tickle thandle >> rest) (return ()) cs+{-# INLINE sPutLazyTickle #-}++sPutTickle :: TM.Handle -> Context -> B.ByteString -> IO ()+sPutTickle thandle ssl cs =+    do sendData ssl (L.fromStrict cs)+       TM.tickle thandle+{-# INLINE sPutTickle #-}++sGetContents :: TM.Handle+             -> Context          -- ^ Connected socket+             -> IO L.ByteString  -- ^ Data received+sGetContents handle ssl =+    fmap L.fromChunks loop+    where+      loop = unsafeInterleaveIO $ do+               s <- recvData ssl+               TM.tickle handle+               if S.null s+                then do return []+                else do ss <- loop+                        return (s:ss)++timeoutSocketIO :: TM.Handle -> Socket -> Context -> TimeoutIO+timeoutSocketIO handle _ ssl =+    TimeoutIO { toHandle      = handle+              , toShutdown    = do bye ssl          `catch` ignoreException+                                   contextClose ssl `catch` ignoreException+              , toPutLazy     = sPutLazyTickle handle ssl+              , toPut         = sPutTickle     handle ssl+              , toGetContents = sGetContents   handle ssl+              , toSendFile    = sendFileTickle handle ssl+              , toSecure      = True+              }+    where+      ignoreException :: SomeException -> IO ()+      ignoreException _ = return ()++sendFileTickle :: TM.Handle -> Context -> FilePath -> Offset -> ByteCount -> IO ()+sendFileTickle thandle ssl fp offset count =+    do withBinaryFile fp ReadMode $ \h -> do+         hSeek h AbsoluteSeek offset+         c <- L.hGetContents h+         sPutLazyTickle thandle ssl (L.take (fromIntegral count) c)
+ src/Happstack/Server/SimpleTLS.hs view
@@ -0,0 +1,30 @@+module Happstack.Server.SimpleTLS+     ( TLSConf(..)+     , nullTLSConf+     , simpleHTTPS+     , simpleHTTPS'+     ) where++import Data.Maybe                    (fromMaybe)+import Happstack.Server              (ToMessage(..), UnWebT, ServerPartT, simpleHTTP'', mapServerPartT, runValidator)+import Happstack.Server.Internal.Cryptonite.TLS (TLSConf(..), nullTLSConf, listenTLS)++-- |start the https:\/\/ server, and handle requests using the supplied+-- 'ServerPart'.+--+-- This function will not return, though it may throw an exception.+--+simpleHTTPS :: (ToMessage a) =>+               TLSConf           -- ^ tls server configuration+            -> ServerPartT IO a  -- ^ server part to run+            -> IO ()+simpleHTTPS = simpleHTTPS' id++-- | similar 'simpleHTTPS' but allows you to supply a function to convert 'm' to 'IO'.+simpleHTTPS' :: (ToMessage b, Monad m, Functor m) =>+                (UnWebT m a -> UnWebT IO b)+            -> TLSConf+            -> ServerPartT m a+            -> IO ()+simpleHTTPS' toIO tlsConf hs =+    listenTLS tlsConf (\req -> runValidator (fromMaybe return (tlsValidator tlsConf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))