/
Server.hs
172 lines (146 loc) · 6.22 KB
/
Server.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web
server library written in Haskell. Together with the @snap-core@ library upon
which it depends, it provides a clean and efficient Haskell programming
interface to the HTTP protocol.
-}
module Snap.Http.Server
( simpleHttpServe
, httpServe
, quickHttpServe
, snapServerVersion
, setUnicodeLocale
, module Snap.Http.Server.Config
) where
import Control.Applicative
import Control.Concurrent (newMVar, withMVar)
import Control.Monad
import Control.Monad.CatchIO
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List
import Data.Maybe
import Prelude hiding (catch)
import Snap.Http.Server.Config
import qualified Snap.Internal.Http.Server as Int
import Snap.Core
import Snap.Util.GZip
#ifndef PORTABLE
import System.Posix.Env
#endif
import System.IO
import System.FastLogger
------------------------------------------------------------------------------
-- | A short string describing the Snap server version
snapServerVersion :: ByteString
snapServerVersion = Int.snapServerVersion
------------------------------------------------------------------------------
-- | Starts serving HTTP requests using the given handler. This function never
-- returns; to shut down the HTTP server, kill the controlling thread.
--
-- This function is like 'httpServe' except it doesn't setup compression or the
-- error handler; this allows it to be used from 'MonadSnap'.
simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
simpleHttpServe config handler = do
conf <- completeConfig config
let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr
mapM_ (output . ("Listening on "++) . show) $ listeners conf
go conf `finally` output "\nShutting down..."
where
go conf = do
let tout = fromMaybe 60 $ getDefaultTimeout conf
setUnicodeLocale $ fromJust $ getLocale conf
withLoggers (fromJust $ getAccessLog conf) (fromJust $ getErrorLog conf) $
\(alog, elog) -> Int.httpServe tout
(listeners conf)
(fmap backendToInternal $ getBackend conf)
(fromJust $ getHostname conf)
alog
elog
(runSnap handler)
maybeSpawnLogger f (ConfigFileLog fp) = liftM Just $
newLoggerWithCustomErrorFunction f fp
maybeSpawnLogger _ _ = return Nothing
maybeIoLog (ConfigIoLog a) = Just a
maybeIoLog _ = Nothing
withLoggers afp efp act =
bracket (do mvar <- newMVar ()
let f s = withMVar mvar
(const $ BS.hPutStr stderr s >> hFlush stderr)
alog <- maybeSpawnLogger f afp
elog <- maybeSpawnLogger f efp
return (alog, elog))
(\(alog, elog) -> do
maybe (return ()) stopLogger alog
maybe (return ()) stopLogger elog)
(\(alog, elog) -> act ( liftM logMsg alog <|> maybeIoLog afp
, liftM logMsg elog <|> maybeIoLog efp))
{-# INLINE simpleHttpServe #-}
listeners :: Config m a -> [Int.ListenPort]
listeners conf = catMaybes [ httpListener, httpsListener ]
where
httpsListener = do
b <- getSSLBind conf
p <- getSSLPort conf
cert <- getSSLCert conf
key <- getSSLKey conf
return $ Int.HttpsPort b p cert key
httpListener = do
p <- getPort conf
b <- getBind conf
return $ Int.HttpPort b p
------------------------------------------------------------------------------
-- | Starts serving HTTP requests using the given handler, with settings from
-- the 'Config' passed in. This function never returns; to shut down the HTTP
-- server, kill the controlling thread.
httpServe :: Config Snap a -> Snap () -> IO ()
httpServe config handler = do
conf <- completeConfig config
let serve = compress conf . catch500 conf $ handler
simpleHttpServe conf serve
{-# INLINE httpServe #-}
------------------------------------------------------------------------------
catch500 :: MonadSnap m => Config m a -> m () -> m ()
catch500 conf = flip catch $ fromJust $ getErrorHandler conf
{-# INLINE catch500 #-}
------------------------------------------------------------------------------
compress :: MonadSnap m => Config m a -> m () -> m ()
compress conf = if fromJust $ getCompression conf then withCompression else id
{-# INLINE compress #-}
------------------------------------------------------------------------------
-- | Starts serving HTTP using the given handler. The configuration is read
-- from the options given on the command-line, as returned by
-- 'commandLineConfig'. This function never returns; to shut down the HTTP
-- server, kill the controlling thread.
quickHttpServe :: Snap () -> IO ()
quickHttpServe m = commandLineConfig emptyConfig >>= \c -> httpServe c m
------------------------------------------------------------------------------
-- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\".
-- This doesn't work on Windows.
setUnicodeLocale :: String -> IO ()
setUnicodeLocale =
#ifndef PORTABLE
\lang -> mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True)
[ "LANG"
, "LC_CTYPE"
, "LC_NUMERIC"
, "LC_TIME"
, "LC_COLLATE"
, "LC_MONETARY"
, "LC_MESSAGES"
, "LC_PAPER"
, "LC_NAME"
, "LC_ADDRESS"
, "LC_TELEPHONE"
, "LC_MEASUREMENT"
, "LC_IDENTIFICATION"
, "LC_ALL" ]
#else
const $ return ()
#endif
------------------------------------------------------------------------------
backendToInternal :: ConfigBackend -> Int.EventLoopType
backendToInternal ConfigSimpleBackend = Int.EventLoopSimple
backendToInternal ConfigLibEvBackend = Int.EventLoopLibEv