{-# 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 = [Char] -> ByteString
S.pack forall a b. (a -> b) -> a -> b
$! Version -> [Char]
showVersion Version
V.version
rawHttpServe :: ServerHandler s
-> ServerConfig s
-> [AcceptFunc]
-> IO ()
rawHttpServe :: forall s.
ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
rawHttpServe ServerHandler s
h ServerConfig s
cfg [AcceptFunc]
loops = do
[MVar ()]
mvars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const forall a. IO (MVar a)
newEmptyMVar) [AcceptFunc]
loops
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MVar (), AcceptFunc) -> IO (MVar (), ThreadId)
runLoop forall a b. (a -> b) -> a -> b
$ [MVar ()]
mvars forall a b. [a] -> [b] -> [(a, b)]
`zip` [AcceptFunc]
loops)
(\[(MVar (), ThreadId)]
mvTids -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(MVar (), ThreadId)]
mvTids
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. MVar a -> IO a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(MVar (), ThreadId)]
mvTids)
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 b. (a -> b) -> a -> b
$
\forall a. IO a -> IO a
r -> (forall a. IO a -> IO a
r forall a b. (a -> b) -> a -> b
$ forall hookState.
ServerHandler hookState
-> ServerConfig hookState -> AcceptFunc -> IO ()
httpAcceptLoop ServerHandler s
h ServerConfig s
cfg AcceptFunc
loop) forall a b. IO a -> IO b -> IO a
`finally` forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar ()
mvar, ThreadId
tid)
simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
simpleHttpServe :: forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> Snap () -> IO ()
simpleHttpServe Config m a
config Snap ()
handler = do
Config m a
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config m a
config
let output :: [Char] -> IO ()
output = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose Config m a
conf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr
([ByteString]
descrs, [Socket]
sockets, [AcceptFunc]
afuncs) <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners Config m a
conf
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
output forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Listening on " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
S.unpack) [ByteString]
descrs
forall {m :: * -> *} {a}.
Config m a -> [Socket] -> [AcceptFunc] -> IO ()
go Config m a
conf [Socket]
sockets [AcceptFunc]
afuncs forall a b. IO a -> IO b -> IO a
`finally` (forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
output [Char]
"\nShutting down.."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. IO a -> IO ()
eatException forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO ()
close) [Socket]
sockets)
where
eatException :: IO a -> IO ()
eatException :: forall a. IO a -> IO ()
eatException IO a
act =
let r0 :: IO ()
r0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()
in (IO a
act forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
r0) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_::SomeException) -> IO ()
r0
debugE :: (MonadIO m) => ByteString -> m ()
debugE :: forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE ByteString
s = forall (m :: * -> *). MonadIO m => [Char] -> m ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Error: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
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 forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b
in (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE (\ByteString -> IO ()
l ByteString
s -> forall (m :: * -> *). MonadIO m => ByteString -> m ()
debugE ByteString
s 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) 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (\Request
_ Response
_ Word64
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()) 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 = 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/", forall a. Show a => a -> ByteString
bshow Int
v, ByteString
".", forall a. Show a => a -> ByteString
bshow Int
v' ]
let method :: ByteString
method = 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 = forall a. a -> Maybe a -> a
fromMaybe 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 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 = forall a. a -> Maybe a -> a
fromMaybe Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe Int
getDefaultTimeout Config m a
conf
let shandler :: ServerHandler hookState
shandler = forall a hookState. Snap a -> ServerHandler hookState
snapToServerHandler Snap ()
handler
[Char] -> IO ()
setUnicodeLocale forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe [Char]
getLocale Config m a
conf
forall {c}.
ConfigLog
-> ConfigLog
-> ((Maybe (ByteString -> IO ()), Maybe (ByteString -> IO ()))
-> IO c)
-> IO c
withLoggers (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
getAccessLog Config m a
conf)
(forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe ConfigLog
getErrorLog Config m a
conf) forall a b. (a -> b) -> a -> b
$ \(Maybe (ByteString -> IO ())
alog, Maybe (ByteString -> IO ())
elog) -> do
let scfg :: ServerConfig hookState
scfg = forall hookState.
Int -> ServerConfig hookState -> ServerConfig hookState
Ty.setDefaultTimeout Int
tout forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall hookState.
ByteString -> ServerConfig hookState -> ServerConfig hookState
Ty.setLocalHostname (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe ByteString
getHostname Config m a
conf) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall hookState.
(Request -> Response -> Word64 -> IO ())
-> ServerConfig hookState -> ServerConfig hookState
Ty.setLogAccess (Maybe (ByteString -> IO ())
-> Request -> Response -> Word64 -> IO ()
logA Maybe (ByteString -> IO ())
alog) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall hookState.
(Builder -> IO ())
-> ServerConfig hookState -> ServerConfig hookState
Ty.setLogError (Maybe (ByteString -> IO ()) -> Builder -> IO ()
logE Maybe (ByteString -> IO ())
elog) forall a b. (a -> b) -> a -> b
$
forall a. ServerConfig a
Ty.emptyServerConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ())
(forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. [Socket] -> Config m a -> StartupInfo m a
mkStartupInfo [Socket]
sockets Config m a
conf)
(forall (m :: * -> *) a.
Config m a -> Maybe (StartupInfo m a -> IO ())
getStartupHook Config m a
conf)
forall s.
ServerHandler s -> ServerConfig s -> [AcceptFunc] -> IO ()
rawHttpServe forall {hookState}. ServerHandler hookState
shandler forall a. ServerConfig a
scfg [AcceptFunc]
afuncs
mkStartupInfo :: [Socket] -> Config m a -> StartupInfo m a
mkStartupInfo [Socket]
sockets Config m a
conf =
forall (m :: * -> *) a.
[Socket] -> StartupInfo m a -> StartupInfo m a
setStartupSockets [Socket]
sockets forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
Config m a -> StartupInfo m a -> StartupInfo m a
setStartupConfig Config m a
conf forall (m :: * -> *) a. StartupInfo m a
emptyStartupInfo
maybeSpawnLogger :: (ByteString -> IO ()) -> ConfigLog -> IO (Maybe Logger)
maybeSpawnLogger ByteString -> IO ()
f (ConfigFileLog [Char]
fp) =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (ByteString -> IO ()) -> [Char] -> IO Logger
newLoggerWithCustomErrorFunction ByteString -> IO ()
f [Char]
fp
maybeSpawnLogger ByteString -> IO ()
_ ConfigLog
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
maybeIoLog :: ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog (ConfigIoLog ByteString -> IO ()
a) = forall a. a -> Maybe a
Just ByteString -> IO ()
a
maybeIoLog ConfigLog
_ = 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 =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (do MVar ()
mvar <- forall a. a -> IO (MVar a)
newMVar ()
let f :: ByteString -> IO ()
f ByteString
s = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mvar
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
S.hPutStr Handle
stderr ByteString
s 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
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Logger
alog, Maybe Logger
elog))
(\(Maybe Logger
alog, Maybe Logger
elog) -> do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Logger -> IO ()
stopLogger Maybe Logger
alog
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 ( forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> ByteString -> IO ()
logMsg Maybe Logger
alog forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ConfigLog -> Maybe (ByteString -> IO ())
maybeIoLog ConfigLog
afp
, forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Logger -> ByteString -> IO ()
logMsg Maybe Logger
elog 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 :: forall (m :: * -> *) a.
Config m a -> IO [(ByteString, Socket, AcceptFunc)]
listeners Config m a
conf = forall a. IO a -> IO a
TLS.withTLS forall a b. (a -> b) -> a -> b
$ do
let fs :: [(ByteString, IO (Socket, AcceptFunc))]
fs = forall a. [Maybe a] -> [a]
catMaybes [Maybe (ByteString, IO (Socket, AcceptFunc))
httpListener, Maybe (ByteString, IO (Socket, AcceptFunc))
httpsListener, Maybe (ByteString, IO (Socket, AcceptFunc))
unixListener]
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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *) a. Config m a -> Maybe ByteString
getSSLBind Config m a
conf
Int
p <- forall (m :: * -> *) a. Config m a -> Maybe Int
getSSLPort Config m a
conf
[Char]
cert <- forall (m :: * -> *) a. Config m a -> Maybe [Char]
getSSLCert Config m a
conf
Bool
chainCert <- forall (m :: * -> *) a. Config m a -> Maybe Bool
getSSLChainCert Config m a
conf
[Char]
key <- forall (m :: * -> *) a. Config m a -> Maybe [Char]
getSSLKey Config m a
conf
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"https://"
, ByteString
b
, ByteString
":"
, forall a. Show a => a -> ByteString
bshow Int
p ],
do (Socket
sock, ()
ctx) <- ByteString -> Int -> [Char] -> Bool -> [Char] -> IO (Socket, ())
TLS.bindHttps ByteString
b Int
p [Char]
cert Bool
chainCert [Char]
key
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 <- forall (m :: * -> *) a. Config m a -> Maybe Int
getPort Config m a
conf
ByteString
b <- forall (m :: * -> *) a. Config m a -> Maybe ByteString
getBind Config m a
conf
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
S.concat [ ByteString
"http://"
, ByteString
b
, ByteString
":"
, forall a. Show a => a -> ByteString
bshow Int
p ],
do Socket
sock <- ByteString -> Int -> IO Socket
Sock.bindSocket ByteString
b Int
p
if forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType Config m a
conf forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ProxyType
HaProxy
then forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.haProxyAcceptFunc Socket
sock)
else 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
[Char]
path <- forall (m :: * -> *) a. Config m a -> Maybe [Char]
getUnixSocket Config m a
conf
let accessMode :: Maybe Int
accessMode = forall (m :: * -> *) a. Config m a -> Maybe Int
getUnixSocketAccessMode Config m a
conf
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"unix:" forall a. [a] -> [a] -> [a]
++ [Char]
path,
do Socket
sock <- Maybe Int -> [Char] -> IO Socket
Sock.bindUnixSocket Maybe Int
accessMode [Char]
path
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, Socket -> AcceptFunc
Sock.httpAcceptFunc Socket
sock))
httpServe :: Config Snap a -> Snap () -> IO ()
httpServe :: forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap a
config Snap ()
handler0 = do
Config Snap a
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config Snap a
config
let !handler :: Snap ()
handler = forall {m :: * -> *} {a}. Config m a -> Snap ()
chooseProxy Config Snap a
conf
let serve :: Snap ()
serve = forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
compress Config Snap a
conf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
catch500 Config Snap a
conf forall a b. (a -> b) -> a -> b
$ Snap ()
handler
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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Snap ()
handler0
(\ProxyType
ptype -> forall {m :: * -> *} {a}. MonadSnap m => ProxyType -> m a -> m a
pickProxy ProxyType
ptype Snap ()
handler0)
(forall (m :: * -> *) a. Config m a -> Maybe ProxyType
getProxyType Config m a
conf)
pickProxy :: ProxyType -> m a -> m a
pickProxy ProxyType
NoProxy = forall a. a -> a
id
pickProxy ProxyType
HaProxy = forall a. a -> a
id
pickProxy ProxyType
X_Forwarded_For = 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 :: forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
catch500 Config m a
conf = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
L.catch forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
getErrorHandler Config m a
conf
compress :: MonadSnap m => Config m a -> m () -> m ()
compress :: forall (m :: * -> *) a. MonadSnap m => Config m a -> m () -> m ()
compress Config m a
conf = if forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression Config m a
conf then forall (m :: * -> *) a. MonadSnap m => m a -> m ()
withCompression else forall a. a -> a
id
quickHttpServe :: Snap () -> IO ()
quickHttpServe :: Snap () -> IO ()
quickHttpServe Snap ()
handler = do
Config Snap Any
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
commandLineConfig forall (m :: * -> *) a. MonadSnap m => Config m a
defaultConfig
forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap Any
conf Snap ()
handler
setUnicodeLocale :: String -> IO ()
#ifndef PORTABLE
setUnicodeLocale :: [Char] -> IO ()
setUnicodeLocale [Char]
lang = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
k -> [Char] -> [Char] -> Bool -> IO ()
setEnv [Char]
k ([Char]
lang forall a. [a] -> [a] -> [a]
++ [Char]
".UTF-8") Bool
True)
[ [Char]
"LANG"
, [Char]
"LC_CTYPE"
, [Char]
"LC_NUMERIC"
, [Char]
"LC_TIME"
, [Char]
"LC_COLLATE"
, [Char]
"LC_MONETARY"
, [Char]
"LC_MESSAGES"
, [Char]
"LC_PAPER"
, [Char]
"LC_NAME"
, [Char]
"LC_ADDRESS"
, [Char]
"LC_TELEPHONE"
, [Char]
"LC_MEASUREMENT"
, [Char]
"LC_IDENTIFICATION"
, [Char]
"LC_ALL" ]
#else
setUnicodeLocale = const $ return ()
#endif
bshow :: (Show a) => a -> ByteString
bshow :: forall a. Show a => a -> ByteString
bshow = [Char] -> ByteString
S.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show