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