1{-# LANGUAGE BangPatterns        #-}
2{-# LANGUAGE CPP                 #-}
3{-# LANGUAGE OverloadedStrings   #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5
6------------------------------------------------------------------------------
7-- | The Snap HTTP server is a high performance web server library written in
8-- Haskell. Together with the @snap-core@ library upon which it depends, it
9-- provides a clean and efficient Haskell programming interface to the HTTP
10-- protocol.
11--
12module Snap.Http.Server
13  ( simpleHttpServe
14  , httpServe
15  , quickHttpServe
16  , snapServerVersion
17  , setUnicodeLocale
18  , rawHttpServe
19  , module Snap.Http.Server.Config
20  ) where
21
22------------------------------------------------------------------------------
23import           Control.Applicative               ((<$>), (<|>))
24import           Control.Concurrent                (killThread, newEmptyMVar, newMVar, putMVar, readMVar, withMVar)
25import           Control.Concurrent.Extended       (forkIOLabeledWithUnmaskBs)
26import           Control.Exception                 (SomeException, bracket, catch, finally, mask, mask_)
27import qualified Control.Exception.Lifted          as L
28import           Control.Monad                     (liftM, when)
29import           Control.Monad.Trans               (MonadIO)
30import           Data.ByteString.Char8             (ByteString)
31import qualified Data.ByteString.Char8             as S
32import qualified Data.ByteString.Lazy.Char8        as L
33import           Data.Maybe                        (catMaybes, fromJust, fromMaybe)
34import qualified Data.Text                         as T
35import qualified Data.Text.Encoding                as T
36import           Data.Version                      (showVersion)
37import           Data.Word                         (Word64)
38import           Network.Socket                    (Socket, close)
39import           Prelude                           (Bool (..), Eq (..), IO, Maybe (..), Monad (..), Show (..), String, const, flip, fst, id, mapM, mapM_, maybe, snd, unzip3, zip, ($), ($!), (++), (.))
40import           System.IO                         (hFlush, hPutStrLn, stderr)
41#ifndef PORTABLE
42import           System.Posix.Env
43#endif
44------------------------------------------------------------------------------
45import           Data.ByteString.Builder           (Builder, toLazyByteString)
46------------------------------------------------------------------------------
47import qualified Paths_snap_server                 as V
48import           Snap.Core                         (MonadSnap (..), Request, Response, Snap, rqClientAddr, rqHeaders, rqMethod, rqURI, rqVersion, rspStatus)
49-- Don't use explicit imports for Snap.Http.Server.Config because we're
50-- re-exporting everything.
51import           Snap.Http.Server.Config
52import qualified Snap.Http.Server.Types            as Ty
53import           Snap.Internal.Debug               (debug)
54import           Snap.Internal.Http.Server.Config  (ProxyType (..), emptyStartupInfo, setStartupConfig, setStartupSockets)
55import           Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler)
56import qualified Snap.Internal.Http.Server.Socket  as Sock
57import qualified Snap.Internal.Http.Server.TLS     as TLS
58import           Snap.Internal.Http.Server.Types   (AcceptFunc, ServerConfig, ServerHandler)
59import qualified Snap.Types.Headers                as H
60import           Snap.Util.GZip                    (withCompression)
61import           Snap.Util.Proxy                   (behindProxy)
62import qualified Snap.Util.Proxy                   as Proxy
63import           System.FastLogger                 (combinedLogEntry, logMsg, newLoggerWithCustomErrorFunction, stopLogger, timestampedLogEntry)
64
65
66------------------------------------------------------------------------------
67-- | A short string describing the Snap server version
68snapServerVersion :: ByteString
69snapServerVersion = S.pack $! showVersion V.version
70
71
72------------------------------------------------------------------------------
73rawHttpServe :: ServerHandler s  -- ^ server handler
74             -> ServerConfig s   -- ^ server config
75             -> [AcceptFunc]     -- ^ listening server backends
76             -> IO ()
77rawHttpServe h cfg loops = do
78    mvars <- mapM (const newEmptyMVar) loops
79    mask $ \restore -> bracket (mapM runLoop $ mvars `zip` loops)
80                               (\mvTids -> do
81                                   mapM_ (killThread . snd) mvTids
82                                   mapM_ (readMVar . fst) mvTids)
83                               (const $ restore $ mapM_ readMVar mvars)
84  where
85    -- parents and children have a mutual suicide pact
86    runLoop (mvar, loop) = do
87        tid <- forkIOLabeledWithUnmaskBs
88               "snap-server http master thread" $
89               \r -> (r $ httpAcceptLoop h cfg loop) `finally` putMVar mvar ()
90        return (mvar, tid)
91
92------------------------------------------------------------------------------
93-- | Starts serving HTTP requests using the given handler. This function never
94-- returns; to shut down the HTTP server, kill the controlling thread.
95--
96-- This function is like 'httpServe' except it doesn't setup compression,
97-- reverse proxy address translation (via 'Snap.Util.Proxy.behindProxy'), or
98-- the error handler; this allows it to be used from 'MonadSnap'.
99simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
100simpleHttpServe config handler = do
101    conf <- completeConfig config
102    let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr
103    (descrs, sockets, afuncs) <- unzip3 <$> listeners conf
104    mapM_ (output . ("Listening on " ++) . S.unpack) descrs
105
106    go conf sockets afuncs `finally` (mask_ $ do
107        output "\nShutting down.."
108        mapM_ (eatException . close) sockets)
109
110  where
111    eatException :: IO a -> IO ()
112    eatException act =
113        let r0 = return $! ()
114        in (act >> r0) `catch` \(_::SomeException) -> r0
115
116    --------------------------------------------------------------------------
117    -- FIXME: this logging code *sucks*
118    --------------------------------------------------------------------------
119    debugE :: (MonadIO m) => ByteString -> m ()
120    debugE s = debug $ "Error: " ++ S.unpack s
121
122
123    --------------------------------------------------------------------------
124    logE :: Maybe (ByteString -> IO ()) -> Builder -> IO ()
125    logE elog b = let x = S.concat $ L.toChunks $ toLazyByteString b
126                  in (maybe debugE (\l s -> debugE s >> logE' l s) elog) x
127
128    --------------------------------------------------------------------------
129    logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
130    logE' logger s = (timestampedLogEntry s) >>= logger
131
132    --------------------------------------------------------------------------
133    logA :: Maybe (ByteString -> IO ())
134         -> Request
135         -> Response
136         -> Word64
137         -> IO ()
138    logA alog = maybe (\_ _ _ -> return $! ()) logA' alog
139
140    --------------------------------------------------------------------------
141    logA' logger req rsp cl = do
142        let hdrs      = rqHeaders req
143        let host      = rqClientAddr req
144        let user      = Nothing -- TODO we don't do authentication yet
145        let (v, v')   = rqVersion req
146        let ver       = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
147        let method    = bshow (rqMethod req)
148        let reql      = S.intercalate " " [ method, rqURI req, ver ]
149        let status    = rspStatus rsp
150        let referer   = H.lookup "referer" hdrs
151        let userAgent = fromMaybe "-" $ H.lookup "user-agent" hdrs
152
153        msg <- combinedLogEntry host user reql status cl referer userAgent
154        logger msg
155
156    --------------------------------------------------------------------------
157    go conf sockets afuncs = do
158        let tout = fromMaybe 60 $ getDefaultTimeout conf
159        let shandler = snapToServerHandler handler
160
161        setUnicodeLocale $ fromJust $ getLocale conf
162
163        withLoggers (fromJust $ getAccessLog conf)
164                    (fromJust $ getErrorLog conf) $ \(alog, elog) -> do
165            let scfg = Ty.setDefaultTimeout tout .
166                       Ty.setLocalHostname (fromJust $ getHostname conf) .
167                       Ty.setLogAccess (logA alog) .
168                       Ty.setLogError (logE elog) $
169                       Ty.emptyServerConfig
170            maybe (return $! ())
171                  ($ mkStartupInfo sockets conf)
172                  (getStartupHook conf)
173            rawHttpServe shandler scfg afuncs
174
175    --------------------------------------------------------------------------
176    mkStartupInfo sockets conf =
177        setStartupSockets sockets $
178        setStartupConfig conf emptyStartupInfo
179
180    --------------------------------------------------------------------------
181    maybeSpawnLogger f (ConfigFileLog fp) =
182        liftM Just $ newLoggerWithCustomErrorFunction f fp
183    maybeSpawnLogger _ _                  = return Nothing
184
185    --------------------------------------------------------------------------
186    maybeIoLog (ConfigIoLog a) = Just a
187    maybeIoLog _               = Nothing
188
189    --------------------------------------------------------------------------
190    withLoggers afp efp act =
191        bracket (do mvar <- newMVar ()
192                    let f s = withMVar mvar
193                                (const $ S.hPutStr stderr s >> hFlush stderr)
194                    alog <- maybeSpawnLogger f afp
195                    elog <- maybeSpawnLogger f efp
196                    return (alog, elog))
197                (\(alog, elog) -> do
198                    maybe (return ()) stopLogger alog
199                    maybe (return ()) stopLogger elog)
200                (\(alog, elog) -> act ( liftM logMsg alog <|> maybeIoLog afp
201                                      , liftM logMsg elog <|> maybeIoLog efp))
202{-# INLINE simpleHttpServe #-}
203
204
205------------------------------------------------------------------------------
206listeners :: Config m a -> IO [(ByteString, Socket, AcceptFunc)]
207listeners conf = TLS.withTLS $ do
208  let fs = catMaybes [httpListener, httpsListener, unixListener]
209  mapM (\(str, mkAfunc) -> do (sock, afunc) <- mkAfunc
210                              return $! (str, sock, afunc)) fs
211  where
212    httpsListener = do
213        b    <- getSSLBind conf
214        p    <- getSSLPort conf
215        cert <- getSSLCert conf
216        chainCert <- getSSLChainCert conf
217        key  <- getSSLKey conf
218        return (S.concat [ "https://"
219                         , b
220                         , ":"
221                         , bshow p ],
222                do (sock, ctx) <- TLS.bindHttps b p cert chainCert key
223                   return (sock, TLS.httpsAcceptFunc sock ctx)
224                )
225    httpListener = do
226        p <- getPort conf
227        b <- getBind conf
228        return (S.concat [ "http://"
229                         , b
230                         , ":"
231                         , bshow p ],
232                do sock <- Sock.bindSocket b p
233                   if getProxyType conf == Just HaProxy
234                     then return (sock, Sock.haProxyAcceptFunc sock)
235                     else return (sock, Sock.httpAcceptFunc sock))
236    unixListener = do
237        path <- getUnixSocket conf
238        let accessMode = getUnixSocketAccessMode conf
239        return (T.encodeUtf8 . T.pack  $ "unix:" ++ path,
240                 do sock <- Sock.bindUnixSocket accessMode path
241                    return (sock, Sock.httpAcceptFunc sock))
242
243
244------------------------------------------------------------------------------
245-- | Starts serving HTTP requests using the given handler, with settings from
246-- the 'Config' passed in. This function never returns; to shut down the HTTP
247-- server, kill the controlling thread.
248httpServe :: Config Snap a -> Snap () -> IO ()
249httpServe config handler0 = do
250    conf <- completeConfig config
251    let !handler = chooseProxy conf
252    let serve    = compress conf . catch500 conf $ handler
253    simpleHttpServe conf serve
254
255  where
256    chooseProxy conf = maybe handler0
257                             (\ptype -> pickProxy ptype handler0)
258                             (getProxyType conf)
259
260    pickProxy NoProxy         = id
261    pickProxy HaProxy         = id  -- we handle this case elsewhere
262    pickProxy X_Forwarded_For = behindProxy Proxy.X_Forwarded_For
263
264
265------------------------------------------------------------------------------
266catch500 :: MonadSnap m => Config m a -> m () -> m ()
267catch500 conf = flip L.catch $ fromJust $ getErrorHandler conf
268
269
270------------------------------------------------------------------------------
271compress :: MonadSnap m => Config m a -> m () -> m ()
272compress conf = if fromJust $ getCompression conf then withCompression else id
273
274
275------------------------------------------------------------------------------
276-- | Starts serving HTTP using the given handler. The configuration is read
277-- from the options given on the command-line, as returned by
278-- 'commandLineConfig'. This function never returns; to shut down the HTTP
279-- server, kill the controlling thread.
280quickHttpServe :: Snap () -> IO ()
281quickHttpServe handler = do
282    conf <- commandLineConfig defaultConfig
283    httpServe conf handler
284
285
286------------------------------------------------------------------------------
287-- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\".
288-- This doesn't work on Windows.
289setUnicodeLocale :: String -> IO ()
290#ifndef PORTABLE
291setUnicodeLocale lang = mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True)
292                            [ "LANG"
293                            , "LC_CTYPE"
294                            , "LC_NUMERIC"
295                            , "LC_TIME"
296                            , "LC_COLLATE"
297                            , "LC_MONETARY"
298                            , "LC_MESSAGES"
299                            , "LC_PAPER"
300                            , "LC_NAME"
301                            , "LC_ADDRESS"
302                            , "LC_TELEPHONE"
303                            , "LC_MEASUREMENT"
304                            , "LC_IDENTIFICATION"
305                            , "LC_ALL" ]
306#else
307setUnicodeLocale = const $ return ()
308#endif
309
310------------------------------------------------------------------------------
311bshow :: (Show a) => a -> ByteString
312bshow = S.pack . show
313