{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Http.Server
( simpleHttpServe
, httpServe
, quickHttpServe
, snapServerVersion
, setUnicodeLocale
, rawHttpServe
, module Snap.Http.Server.Config
) where
import Control.Applicative ((<$>), (<|>))
import Control.Concurrent (killThread, newEmptyMVar, newMVar, putMVar, readMVar, withMVar)
import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs)
import Control.Exception (SomeException, bracket, catch, finally, mask, mask_)
import qualified Control.Exception.Lifted as L
import Control.Monad (liftM, when)
import Control.Monad.Trans (MonadIO)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Version (showVersion)
import Data.Word (Word64)
import Network.Socket (Socket, close)
import Prelude (Bool (..), Eq (..), IO, Maybe (..), Monad (..), Show (..), String, const, flip, fst, id, mapM, mapM_, maybe, snd, unzip3, zip, ($), ($!), (++), (.))
import System.IO (hFlush, hPutStrLn, stderr)
#ifndef PORTABLE
import System.Posix.Env
#endif
import Data.ByteString.Builder (Builder, toLazyByteString)
import qualified Paths_snap_server as V
import Snap.Core (MonadSnap (..), Request, Response, Snap, rqClientAddr, rqHeaders, rqMethod, rqURI, rqVersion, rspStatus)
import Snap.Http.Server.Config
import qualified Snap.Http.Server.Types as Ty
import Snap.Internal.Debug (debug)
import Snap.Internal.Http.Server.Config (ProxyType (..), emptyStartupInfo, setStartupConfig, setStartupSockets)
import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler)
import qualified Snap.Internal.Http.Server.Socket as Sock
import qualified Snap.Internal.Http.Server.TLS as TLS
import Snap.Internal.Http.Server.Types (AcceptFunc, ServerConfig, ServerHandler)
import qualified Snap.Types.Headers as H
import Snap.Util.GZip (withCompression)
import Snap.Util.Proxy (behindProxy)
import qualified Snap.Util.Proxy as Proxy
import System.FastLogger (combinedLogEntry, logMsg, newLoggerWithCustomErrorFunction, stopLogger, timestampedLogEntry)
snapServerVersion :: ByteString
snapServerVersion :: ByteString
snapServerVersion = String -> ByteString
S.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$! Version -> String
showVersion Version
V.version
rawHttpServe :: ServerHandler s
-> ServerConfig s
-> [AcceptFunc]
-> IO ()
rawHttpServe :: ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
rawHttpServe ServerHandler s
h ServerConfig s
cfg [AcceptFunc]
loops = do
[MVar ()]
mvars <- (AcceptFunc -> IO (MVar ())) -> [AcceptFunc] -> IO [MVar ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO (MVar ()) -> AcceptFunc -> IO (MVar ())
forall a b. a -> b -> a
const IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar) [AcceptFunc]
loops
((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> IO [(MVar (), ThreadId)]
-> ([(MVar (), ThreadId)] -> IO ())
-> ([(MVar (), ThreadId)] -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (((MVar (), AcceptFunc) -> IO (MVar (), ThreadId))
-> [(MVar (), AcceptFunc)] -> IO [(MVar (), ThreadId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MVar (), AcceptFunc) -> IO (MVar (), ThreadId)
runLoop ([(MVar (), AcceptFunc)] -> IO [(MVar (), ThreadId)])
-> [(MVar (), AcceptFunc)] -> IO [(MVar (), ThreadId)]
forall a b. (a -> b) -> a -> b
$ [MVar ()]
mvars [MVar ()] -> [AcceptFunc] -> [(MVar (), AcceptFunc)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [AcceptFunc]
loops)
(\[(MVar (), ThreadId)]
mvTids -> do
((MVar (), ThreadId) -> IO ()) -> [(MVar (), ThreadId)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread (ThreadId -> IO ())
-> ((MVar (), ThreadId) -> ThreadId)
-> (MVar (), ThreadId)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar (), ThreadId) -> ThreadId
forall a b. (a, b) -> b
snd) [(MVar (), ThreadId)]
mvTids
((MVar (), ThreadId) -> IO ()) -> [(MVar (), ThreadId)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MVar () -> IO ()
forall a. MVar a -> IO a
readMVar (MVar () -> IO ())
-> ((MVar (), ThreadId) -> MVar ()) -> (MVar (), ThreadId) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar (), ThreadId) -> MVar ()
forall a b. (a, b) -> a
fst) [(MVar (), ThreadId)]
mvTids)
(IO () -> [(MVar (), ThreadId)] -> IO ()
forall a b. a -> b -> a
const (IO () -> [(MVar (), ThreadId)] -> IO ())
-> IO () -> [(MVar (), ThreadId)] -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (MVar () -> IO ()) -> [MVar ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MVar () -> IO ()
forall a. MVar a -> IO a
readMVar [MVar ()]
mvars)
where
runLoop :: (MVar (), AcceptFunc) -> IO (MVar (), ThreadId)
runLoop (MVar ()
mvar, AcceptFunc
loop) = do
ThreadId
tid <- ByteString -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOLabeledWithUnmaskBs
ByteString
"snap-server http master thread" (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
\forall a. IO a -> IO a
r -> (IO () -> IO ()
forall a. IO a -> IO a
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerHandler s -> ServerConfig s -> AcceptFunc -> IO ()
forall hookState.
ServerHandler hookState
-> ServerConfig hookState -> AcceptFunc -> IO ()
httpAcceptLoop ServerHandler s
h ServerConfig s
cfg AcceptFunc
loop) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
(MVar (), ThreadId) -> IO (MVar (), ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar ()
mvar, ThreadId
tid)
simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
simpleHttpServe :: Config m a -> Snap () -> IO ()
simpleHttpServe Config m a
config Snap ()
handler = do
Config m a
conf <- Config m a -> IO (Config m a)
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config m a
config
let output :: String -> IO ()
output = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose Config m a
conf) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr
([ByteString]
descrs, [Socket]
sockets, [AcceptFunc]
afuncs) <- [(ByteString, Socket, AcceptFunc)]
-> ([ByteString], [Socket], [AcceptFunc])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(ByteString, Socket, AcceptFunc)]
-> ([ByteString], [Socket], [AcceptFunc]))
-> IO [(ByteString, Socket, AcceptFunc)]
-> IO ([ByteString], [Socket], [AcceptFunc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config m a -> IO [(ByteString, Socket, AcceptFunc)]
forall (m :: * -> *) a.
Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners Config m a
conf
(ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
output (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Listening on " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S.unpack) [ByteString]
descrs
Config m a -> [Socket] -> [AcceptFunc] -> IO ()
forall (m :: * -> *) a.
Config m a -> [Socket] -> [AcceptFunc] -> IO ()
go Config m a
conf [Socket]
sockets [AcceptFunc]
afuncs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` (IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
output String
"\nShutting down.."
(Socket -> IO ()) -> [Socket] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> IO ()
forall a. IO a -> IO ()
eatException (IO () -> IO ()) -> (Socket -> IO ()) -> Socket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO ()
close) [Socket]
sockets)
where
eatException :: IO a -> IO ()
eatException :: IO a -> IO ()
eatException IO a
act =
let r0 :: IO ()
r0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ()
in (IO a
act IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
r0) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_::SomeException) -> IO ()
r0
debugE :: (MonadIO m) => ByteString -> m ()
debugE :: ByteString -> m ()
debugE ByteString
s = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
S.unpack ByteString
s
logE :: Maybe (ByteString -> IO ()) -> Builder -> IO ()
logE :: Maybe (ByteString -> IO ()) -> Builder -> IO ()
logE Maybe (ByteString -> IO ())
elog Builder
b = let x :: ByteString
x = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b
in ((ByteString -> IO ())
-> ((ByteString -> IO ()) -> ByteString -> IO ())
-> Maybe (ByteString -> IO ())
-> ByteString
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE (\ByteString -> IO ()
l ByteString
s -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE ByteString
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ByteString -> IO ()) -> ByteString -> IO ()
logE' ByteString -> IO ()
l ByteString
s) Maybe (ByteString -> IO ())
elog) ByteString
x
logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
logE' ByteString -> IO ()
logger ByteString
s = (ByteString -> IO ByteString
timestampedLogEntry ByteString
s) IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
logger
logA :: Maybe (ByteString -> IO ())
-> Request
-> Response
-> Word64
-> IO ()
logA :: Maybe (ByteString -> IO ())
-> Request -> Response -> Word64 -> IO ()
logA Maybe (ByteString -> IO ())
alog = (Request -> Response -> Word64 -> IO ())
-> ((ByteString -> IO ())
-> Request -> Response -> Word64 -> IO ())
-> Maybe (ByteString -> IO ())
-> Request
-> Response
-> Word64
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (\Request
_ Response
_ Word64
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ()) (ByteString -> IO ()) -> Request -> Response -> Word64 -> IO ()
forall b.
(ByteString -> IO b) -> Request -> Response -> Word64 -> IO b
logA' Maybe (ByteString -> IO ())
alog
logA' :: (ByteString -> IO b) -> Request -> Response -> Word64 -> IO b
logA' ByteString -> IO b
logger Request
req Response
rsp Word64
cl = do
let hdrs :: Headers
hdrs = Request -> Headers
rqHeaders Request
req
let host :: ByteString
host = Request -> ByteString
rqClientAddr Request
req
let user :: Maybe a
user = Maybe a
forall a. Maybe a
Nothing
let (Int
v, Int
v') = Request -> (Int, Int)
rqVersion Request
req
let ver :: ByteString
ver = [ByteString] -> ByteString
S.concat [ ByteString
"HTTP/", Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
v, ByteString
".", Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
v' ]
let method :: ByteString
method = Method -> ByteString
forall a. Show a => a -> ByteString
bshow (Request -> Method
rqMethod Request
req)
let reql :: ByteString
reql = ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
" " [ ByteString
method, Request -> ByteString
rqURI Request
req, ByteString
ver ]
let status :: Int
status = Response -> Int
rspStatus Response
rsp
let referer :: Maybe ByteString
referer = CI ByteString -> Headers -> Maybe ByteString
H.lookup CI ByteString
"referer" Headers
hdrs
let userAgent :: ByteString
userAgent = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"-" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Headers -> Maybe ByteString
H.lookup CI ByteString
"user-agent" Headers
hdrs
ByteString
msg <- ByteString
-> Maybe ByteString
-> ByteString
-> Int
-> Word64
-> Maybe ByteString
-> ByteString
-> IO ByteString
combinedLogEntry ByteString
host Maybe ByteString
forall a. Maybe a
user ByteString
reql Int
status Word64
cl Maybe ByteString
referer ByteString
userAgent
ByteString -> IO b
logger ByteString
msg
go :: Config m a -> [Socket] -> [AcceptFunc] -> IO ()
go Config m a
conf [Socket]
sockets [AcceptFunc]
afuncs = do
let tout :: Int
tout = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
60 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getDefaultTimeout Config m a
conf
let shandler :: ServerHandler hookState
shandler = Snap () -> ServerHandler hookState
forall a hookState. Snap a -> ServerHandler hookState
snapToServerHandler Snap ()
handler
String -> IO ()
setUnicodeLocale (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getLocale Config m a
conf
ConfigLog
-> ConfigLog
-> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
-> IO ())
-> IO ()
forall c.
ConfigLog
-> ConfigLog
-> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
-> IO c)
-> IO c
withLoggers (Maybe ConfigLog -> ConfigLog
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ConfigLog -> ConfigLog) -> Maybe ConfigLog -> ConfigLog
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
getAccessLog Config m a
conf)
(Maybe ConfigLog -> ConfigLog
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ConfigLog -> ConfigLog) -> Maybe ConfigLog -> ConfigLog
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ConfigLog
forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
getErrorLog Config m a
conf) (((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
-> IO ())
-> IO ())
-> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
-> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Maybe (ByteString -> IO ())
alog, Maybe (ByteString -> IO ())
elog) -> do
let scfg :: ServerConfig hookState
scfg = Int -> ServerConfig hookState -> ServerConfig hookState
forall hookState.
Int -> ServerConfig hookState -> ServerConfig hookState
Ty.setDefaultTimeout Int
tout (ServerConfig hookState -> ServerConfig hookState)
-> (ServerConfig hookState -> ServerConfig hookState)
-> ServerConfig hookState
-> ServerConfig hookState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ByteString -> ServerConfig hookState -> ServerConfig hookState
forall hookState.
ByteString -> ServerConfig hookState -> ServerConfig hookState
Ty.setLocalHostname (Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getHostname Config m a
conf) (ServerConfig hookState -> ServerConfig hookState)
-> (ServerConfig hookState -> ServerConfig hookState)
-> ServerConfig hookState
-> ServerConfig hookState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Request -> Response -> Word64 -> IO ())
-> ServerConfig hookState -> ServerConfig hookState
forall hookState.
(Request -> Response -> Word64 -> IO ())
-> ServerConfig hookState -> ServerConfig hookState
Ty.setLogAccess (Maybe (ByteString -> IO ())
-> Request -> Response -> Word64 -> IO ()
logA Maybe (ByteString -> IO ())
alog) (ServerConfig hookState -> ServerConfig hookState)
-> (ServerConfig hookState -> ServerConfig hookState)
-> ServerConfig hookState
-> ServerConfig hookState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Builder -> IO ())
-> ServerConfig hookState -> ServerConfig hookState
forall hookState.
(Builder -> IO ())
-> ServerConfig hookState -> ServerConfig hookState
Ty.setLogError (Maybe (ByteString -> IO ()) -> Builder -> IO ()
logE Maybe (ByteString -> IO ())
elog) (ServerConfig hookState -> ServerConfig hookState)
-> ServerConfig hookState -> ServerConfig hookState
forall a b. (a -> b) -> a -> b
$
ServerConfig hookState
forall a. ServerConfig a
Ty.emptyServerConfig
IO ()
-> ((StartupInfo m a -> IO ()) -> IO ())
-> Maybe (StartupInfo m a -> IO ())
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ())
((StartupInfo m a -> IO ()) -> StartupInfo m a -> IO ()
forall a b. (a -> b) -> a -> b
$ [Socket] -> Config m a -> StartupInfo m a
forall (m :: * -> *) a. [Socket] -> Config m a -> StartupInfo m a
mkStartupInfo [Socket]
sockets Config m a
conf)
(Config m a -> Maybe (StartupInfo m a -> IO ())
forall (m :: * -> *) a.
Config m a -> Maybe (StartupInfo m a -> IO ())
getStartupHook Config m a
conf)
ServerHandler Any -> ServerConfig Any -> [AcceptFunc] -> IO ()
forall s.
ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
rawHttpServe ServerHandler Any
forall hookState. ServerHandler hookState
shandler ServerConfig Any
forall a. ServerConfig a
scfg [AcceptFunc]
afuncs
mkStartupInfo :: [Socket] -> Config m a -> StartupInfo m a
mkStartupInfo [Socket]
sockets Config m a
conf =
[Socket] -> StartupInfo m a -> StartupInfo m a
forall (m :: * -> *) a.
[Socket] -> StartupInfo m a -> StartupInfo m a
setStartupSockets [Socket]
sockets (StartupInfo m a -> StartupInfo m a)
-> StartupInfo m a -> StartupInfo m a
forall a b. (a -> b) -> a -> b
$
Config m a -> StartupInfo m a -> StartupInfo m a
forall (m :: * -> *) a.
Config m a -> StartupInfo m a -> StartupInfo m a
setStartupConfig Config m a
conf StartupInfo m a
forall (m :: * -> *) a. StartupInfo m a
emptyStartupInfo
maybeSpawnLogger :: (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
maybeSpawnLogger ByteString -> IO ()
f (ConfigFileLog String
fp) =
(Logger -> Maybe Logger) -> IO Logger -> IO (Maybe Logger)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> Maybe Logger
forall a. a -> Maybe a
Just (IO Logger -> IO (Maybe Logger)) -> IO Logger -> IO (Maybe Logger)
forall a b. (a -> b) -> a -> b
$ (ByteString -> IO ()) -> String -> IO Logger
newLoggerWithCustomErrorFunction ByteString -> IO ()
f String
fp
maybeSpawnLogger ByteString -> IO ()
_ ConfigLog
_ = Maybe Logger -> IO (Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Logger
forall a. Maybe a
Nothing
maybeIoLog :: ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog (ConfigIoLog ByteString -> IO ()
a) = (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
forall a. a -> Maybe a
Just ByteString -> IO ()
a
maybeIoLog ConfigLog
_ = Maybe (ByteString -> IO ())
forall a. Maybe a
Nothing
withLoggers :: ConfigLog
-> ConfigLog
-> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
-> IO c)
-> IO c
withLoggers ConfigLog
afp ConfigLog
efp (Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ())) -> IO c
act =
IO (Maybe Logger, Maybe Logger)
-> ((Maybe Logger, Maybe Logger) -> IO ())
-> ((Maybe Logger, Maybe Logger) -> IO c)
-> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (do MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
let f :: ByteString -> IO ()
f ByteString
s = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mvar
(IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
S.hPutStr Handle
stderr ByteString
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr)
Maybe Logger
alog <- (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
maybeSpawnLogger ByteString -> IO ()
f ConfigLog
afp
Maybe Logger
elog <- (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
maybeSpawnLogger ByteString -> IO ()
f ConfigLog
efp
(Maybe Logger, Maybe Logger) -> IO (Maybe Logger, Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Logger
alog, Maybe Logger
elog))
(\(Maybe Logger
alog, Maybe Logger
elog) -> do
IO () -> (Logger -> IO ()) -> Maybe Logger -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Logger -> IO ()
stopLogger Maybe Logger
alog
IO () -> (Logger -> IO ()) -> Maybe Logger -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Logger -> IO ()
stopLogger Maybe Logger
elog)
(\(Maybe Logger
alog, Maybe Logger
elog) -> (Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ())) -> IO c
act ( (Logger -> ByteString -> IO ())
-> Maybe Logger -> Maybe (ByteString -> IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> ByteString -> IO ()
logMsg Maybe Logger
alog Maybe (ByteString -> IO ())
-> Maybe (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog ConfigLog
afp
, (Logger -> ByteString -> IO ())
-> Maybe Logger -> Maybe (ByteString -> IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> ByteString -> IO ()
logMsg Maybe Logger
elog Maybe (ByteString -> IO ())
-> Maybe (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog ConfigLog
efp))
{-# INLINE simpleHttpServe #-}
listeners :: Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners :: Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners Config m a
conf = IO [(ByteString, Socket, AcceptFunc)]
-> IO [(ByteString, Socket, AcceptFunc)]
forall a. IO a -> IO a
TLS.withTLS (IO [(ByteString, Socket, AcceptFunc)]
-> IO [(ByteString, Socket, AcceptFunc)])
-> IO [(ByteString, Socket, AcceptFunc)]
-> IO [(ByteString, Socket, AcceptFunc)]
forall a b. (a -> b) -> a -> b
$ do
let fs :: [(ByteString, IO (Socket, AcceptFunc))]
fs = [Maybe (ByteString, IO (Socket, AcceptFunc))]
-> [(ByteString, IO (Socket, AcceptFunc))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (ByteString, IO (Socket, AcceptFunc))
httpListener, Maybe (ByteString, IO (Socket, AcceptFunc))
httpsListener, Maybe (ByteString, IO (Socket, AcceptFunc))
unixListener]
((ByteString, IO (Socket, AcceptFunc))
-> IO (ByteString, Socket, AcceptFunc))
-> [(ByteString, IO (Socket, AcceptFunc))]
-> IO [(ByteString, Socket, AcceptFunc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ByteString
str, IO (Socket, AcceptFunc)
mkAfunc) -> do (Socket
sock, AcceptFunc
afunc) <- IO (Socket, AcceptFunc)
mkAfunc
(ByteString, Socket, AcceptFunc)
-> IO (ByteString, Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, Socket, AcceptFunc)
-> IO (ByteString, Socket, AcceptFunc))
-> (ByteString, Socket, AcceptFunc)
-> IO (ByteString, Socket, AcceptFunc)
forall a b. (a -> b) -> a -> b
$! (ByteString
str, Socket
sock, AcceptFunc
afunc)) [(ByteString, IO (Socket, AcceptFunc))]
fs
where
httpsListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
httpsListener = do
ByteString
b <- Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getSSLBind Config m a
conf
Int
p <- Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getSSLPort Config m a
conf
String
cert <- Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getSSLCert Config m a
conf
Bool
chainCert <- Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getSSLChainCert Config m a
conf
String
key <- Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getSSLKey Config m a
conf
(ByteString, IO (Socket, AcceptFunc))
-> Maybe (ByteString, IO (Socket, AcceptFunc))
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"https://"
, ByteString
b
, ByteString
":"
, Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
p ],
do (Socket
sock, ()
ctx) <- ByteString -> Int -> String -> Bool -> String -> IO (Socket, ())
TLS.bindHttps ByteString
b Int
p String
cert Bool
chainCert String
key
(Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> () -> AcceptFunc
TLS.httpsAcceptFunc Socket
sock ()
ctx)
)
httpListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
httpListener = do
Int
p <- Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getPort Config m a
conf
ByteString
b <- Config m a -> Maybe ByteString
forall (m :: * -> *) a. Config m a -> Maybe ByteString
getBind Config m a
conf
(ByteString, IO (Socket, AcceptFunc))
-> Maybe (ByteString, IO (Socket, AcceptFunc))
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"http://"
, ByteString
b
, ByteString
":"
, Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
p ],
do Socket
sock <- ByteString -> Int -> IO Socket
Sock.bindSocket ByteString
b Int
p
if Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType Config m a
conf Maybe ProxyType -> Maybe ProxyType -> Bool
forall a. Eq a => a -> a -> Bool
== ProxyType -> Maybe ProxyType
forall a. a -> Maybe a
Just ProxyType
HaProxy
then (Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.haProxyAcceptFunc Socket
sock)
else (Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.httpAcceptFunc Socket
sock))
unixListener :: Maybe (ByteString, IO (Socket, AcceptFunc))
unixListener = do
String
path <- Config m a -> Maybe String
forall (m :: * -> *) a. Config m a -> Maybe String
getUnixSocket Config m a
conf
let accessMode :: Maybe Int
accessMode = Config m a -> Maybe Int
forall (m :: * -> *) a. Config m a -> Maybe Int
getUnixSocketAccessMode Config m a
conf
(ByteString, IO (Socket, AcceptFunc))
-> Maybe (ByteString, IO (Socket, AcceptFunc))
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"unix:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path,
do Socket
sock <- Maybe Int -> String -> IO Socket
Sock.bindUnixSocket Maybe Int
accessMode String
path
(Socket, AcceptFunc) -> IO (Socket, AcceptFunc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.httpAcceptFunc Socket
sock))
httpServe :: Config Snap a -> Snap () -> IO ()
httpServe :: Config Snap a -> Snap () -> IO ()
httpServe Config Snap a
config Snap ()
handler0 = do
Config Snap a
conf <- Config Snap a -> IO (Config Snap a)
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config Snap a
config
let !handler :: Snap ()
handler = Config Snap a -> Snap ()
forall (m :: * -> *) a. Config m a -> Snap ()
chooseProxy Config Snap a
conf
let serve :: Snap ()
serve = Config Snap a -> Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
compress Config Snap a
conf (Snap () -> Snap ()) -> (Snap () -> Snap ()) -> Snap () -> Snap ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config Snap a -> Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
catch500 Config Snap a
conf (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ Snap ()
handler
Config Snap a -> Snap () -> IO ()
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> Snap () -> IO ()
simpleHttpServe Config Snap a
conf Snap ()
serve
where
chooseProxy :: Config m a -> Snap ()
chooseProxy Config m a
conf = Snap () -> (ProxyType -> Snap ()) -> Maybe ProxyType -> Snap ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Snap ()
handler0
(\ProxyType
ptype -> ProxyType -> Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => ProxyType -> m a -> m a
pickProxy ProxyType
ptype Snap ()
handler0)
(Config m a -> Maybe ProxyType
forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType Config m a
conf)
pickProxy :: ProxyType -> m a -> m a
pickProxy ProxyType
NoProxy = m a -> m a
forall a. a -> a
id
pickProxy ProxyType
HaProxy = m a -> m a
forall a. a -> a
id
pickProxy ProxyType
X_Forwarded_For = ProxyType -> m a -> m a
forall (m :: * -> *) a. MonadSnap m => ProxyType -> m a -> m a
behindProxy ProxyType
Proxy.X_Forwarded_For
catch500 :: MonadSnap m => Config m a -> m () -> m ()
catch500 :: Config m a -> m () -> m ()
catch500 Config m a
conf = (m () -> (SomeException -> m ()) -> m ())
-> (SomeException -> m ()) -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
L.catch ((SomeException -> m ()) -> m () -> m ())
-> (SomeException -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (SomeException -> m ()) -> SomeException -> m ()
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (SomeException -> m ()) -> SomeException -> m ())
-> Maybe (SomeException -> m ()) -> SomeException -> m ()
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe (SomeException -> m ())
forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
getErrorHandler Config m a
conf
compress :: MonadSnap m => Config m a -> m () -> m ()
compress :: Config m a -> m () -> m ()
compress Config m a
conf = if Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config m a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression Config m a
conf then m () -> m ()
forall (m :: * -> *) a. MonadSnap m => m a -> m ()
withCompression else m () -> m ()
forall a. a -> a
id
quickHttpServe :: Snap () -> IO ()
quickHttpServe :: Snap () -> IO ()
quickHttpServe Snap ()
handler = do
Config Snap Any
conf <- Config Snap Any -> IO (Config Snap Any)
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
commandLineConfig Config Snap Any
forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig
Config Snap Any -> Snap () -> IO ()
forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap Any
conf Snap ()
handler
setUnicodeLocale :: String -> IO ()
#ifndef PORTABLE
setUnicodeLocale :: String -> IO ()
setUnicodeLocale String
lang = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
k -> String -> String -> Bool -> IO ()
setEnv String
k (String
lang String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".UTF-8") Bool
True)
[ String
"LANG"
, String
"LC_CTYPE"
, String
"LC_NUMERIC"
, String
"LC_TIME"
, String
"LC_COLLATE"
, String
"LC_MONETARY"
, String
"LC_MESSAGES"
, String
"LC_PAPER"
, String
"LC_NAME"
, String
"LC_ADDRESS"
, String
"LC_TELEPHONE"
, String
"LC_MEASUREMENT"
, String
"LC_IDENTIFICATION"
, String
"LC_ALL" ]
#else
setUnicodeLocale = const $ return ()
#endif
bshow :: (Show a) => a -> ByteString
bshow :: a -> ByteString
bshow = String -> ByteString
S.pack (String -> ByteString) -> (a -> String) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show