This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, 0.3 has been updated
via 243d9b22e9935b8296b03731bb2fa72ed4c5286c (commit)
from ae0d526607ab639a2cb97567da89d7df87c26595 (commit)
Summary of changes:
snap-server.cabal | 2 +-
src/Snap/Http/Server.hs | 376 +++++++++++++++++++++++++++++++++++-----
src/Snap/Http/Server/Config.hs | 169 ------------------
3 files changed, 329 insertions(+), 218 deletions(-)
delete mode 100644 src/Snap/Http/Server/Config.hs
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 243d9b22e9935b8296b03731bb2fa72ed4c5286c
Author: Shane <[email protected]>
Date: Fri Jul 9 11:43:14 2010 +0100
Completely redid server config stuff, see commit message for
9e0b1bc0e75e872fef1cf83019a1a052b2f91a63.
diff --git a/snap-server.cabal b/snap-server.cabal
index 076921a..53b5ae0 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -89,7 +89,6 @@ Library
exposed-modules:
Snap.Http.Server,
- Snap.Http.Server.Config,
System.FastLogger
other-modules:
@@ -121,6 +120,7 @@ Library
snap-core >= 0.3 && <0.4,
time,
transformers,
+ utf8-string,
unix-compat,
vector >= 0.6 && <0.7
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index 8d69a35..10cf682 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -1,23 +1,270 @@
--- | 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.
+{-# 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
-(
- httpServe
-, httpServeConfig
-, quickHttpServe
-, snapServerVersion
-) where
+ ( Config(..)
+ , defaultConfig
+ , commandLineConfig
+ , simpleHttpServe
+ , internalError
+ , httpServe
+ , quickHttpServe
+ , snapServerVersion
+ ) where
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
-import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString as B
+import qualified Data.ByteString.UTF8 as U
import Data.ByteString (ByteString)
-import Snap.Types
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Prelude hiding (catch)
import qualified Snap.Internal.Http.Server as Int
-import Snap.Http.Server.Config
+import Snap.Iteratee ((>.), enumBS)
+import Snap.Types
+import Snap.Util.GZip
+import System.Console.GetOpt
+import System.Environment hiding (getEnv)
+#ifndef PORTABLE
+import System.Posix.Env
+#endif
+import System.Exit
+import System.IO
+
+
+------------------------------------------------------------------------------
+-- | A record type which represents partial configurations (for 'httpServe')
+-- by wrapping all of its fields in a 'Maybe'. Values of this type are usually
+-- constructed via its 'Monoid' instance by doing something like:
+--
+-- > mempty { port = Just 9000}
+--
+-- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
+-- this is the norm) are filled in with default values from 'defaultConfig'.
+data Config = Config
+ { hostname :: Maybe ByteString
+ -- ^ The name of the server
+ , address :: Maybe ByteString
+ -- ^ The local interface to bind to
+ , port :: Maybe Int
+ -- ^ The local port to bind to
+ , accessLog :: Maybe (Maybe FilePath)
+ -- ^ The path to the access log
+ , errorLog :: Maybe (Maybe FilePath)
+ -- ^ The path to the error log
+ , locale :: Maybe String
+ -- ^ The locale to use
+ , compression :: Maybe Bool
+ -- ^ Whether to use compression
+ , verbose :: Maybe Bool
+ -- ^ Whether to write server status updates to stderr
+ , errorHandler :: Maybe (SomeException -> Snap ())
+ -- ^ A Snap action to handle 500 errors
+ }
+
+
+------------------------------------------------------------------------------
+instance Show (Config) where
+ show c = "Config {" ++ concat (intersperse ", " $ filter (/="") $ map ($c)
+ [ showM "hostname" . hostname
+ , showM "address" . address
+ , showM "port" . port
+ , showM "accessLog" . accessLog
+ , showM "errorLog" . errorLog
+ , showM "locale" . locale
+ , showM "compression" . compression
+ , showM "verbose" . verbose
+ , showM "errorHandler" . fmap (const ()) . errorHandler
+ ]) ++ "}"
+ where
+ showM s = maybe "" ((++) (s ++ " = ") . show)
+
+
+------------------------------------------------------------------------------
+instance Monoid (Config) where
+ mempty = Config
+ { hostname = Nothing
+ , address = Nothing
+ , port = Nothing
+ , accessLog = Nothing
+ , errorLog = Nothing
+ , locale = Nothing
+ , compression = Nothing
+ , verbose = Nothing
+ , errorHandler = Nothing
+ }
+
+ a `mappend` b = Config
+ { hostname = (hostname b) `mplus` (hostname a)
+ , address = (address b) `mplus` (address a)
+ , port = (port b) `mplus` (port a)
+ , accessLog = (accessLog b) `mplus` (accessLog a)
+ , errorLog = (errorLog b) `mplus` (errorLog a)
+ , locale = (locale b) `mplus` (locale a)
+ , compression = (compression b) `mplus` (compression a)
+ , verbose = (verbose b) `mplus` (verbose a)
+ , errorHandler = (errorHandler b) `mplus` (errorHandler a)
+ }
+
+
+------------------------------------------------------------------------------
+-- | This function creates a simple plain text error page with the provided
+-- content. It sets the response status to 500, and short-circuits further
+-- handling of the request
+internalError :: (MonadSnap m) => ByteString -> m a
+internalError msg =
+ let rsp = setContentType "text/plain; charset=utf-8"
+ . setContentLength (fromIntegral $ B.length msg)
+ . setResponseStatus 500 "Internal Server Error"
+ . modifyResponseBody (>. enumBS msg)
+ $ emptyResponse
+ in finishWith rsp
+
+
+------------------------------------------------------------------------------
+-- | These are the default values for all the fields in 'Config'.
+--
+-- > hostname = "localhost"
+-- > address = "0.0.0.0"
+-- > port = 8000
+-- > accessLog = "log/access.log"
+-- > errorLog = "log/error.log"
+-- > locale = "en_US"
+-- > compression = True
+-- > verbose = True
+-- > errorHandler = prints the error message
+--
+defaultConfig :: Config
+defaultConfig = Config
+ { hostname = Just "localhost"
+ , address = Just "0.0.0.0"
+ , port = Just 8000
+ , accessLog = Just $ Just "log/access.log"
+ , errorLog = Just $ Just "log/error.log"
+ , locale = Just "en_US"
+ , compression = Just True
+ , verbose = Just True
+ , errorHandler = Just $ \e -> do
+ internalError $ "A web handler threw an exception. Details:\n"
+Â Â Â Â Â Â Â Â `mappend` (U.fromString $ show e)
+ }
+
+
+------------------------------------------------------------------------------
+-- | Completes a partial 'Config' by filling in the unspecified values with
+-- the default values from 'defaultConfig'.
+completeConfig :: Config -> Config
+completeConfig = mappend defaultConfig
+
+
+------------------------------------------------------------------------------
+-- | A description of the command-line options accepted by
+-- 'commandLineConfig'.
+--
+-- The 'Config' parameter is just for specifying any default values which are
+-- to override those in 'defaultConfig'. This is so the usage message can
+-- accurately inform the user what the default values for the options are. In
+-- most cases, you will probably just end up passing 'mempty' for this
+-- parameter.
+--
+-- The return type is a list of options describing a @'Maybe' 'Config@ as
+-- opposed to a @'Config'@, because if the @--help@ option is given, the set
+-- of command-line options no longer describe a config, but an action
+-- (printing out the usage message).
+options :: Config -> [OptDescr (Maybe Config)]
+options defaults =
+ [ Option [] ["hostname"]
+ (ReqArg (\h -> Just $ mempty {hostname = Just $ bs h}) "NAME")
+ $ "local hostname" ++ default_ hostname
+ , Option ['b'] ["address"]
+ (ReqArg (\a -> Just $ mempty {address = Just $ bs a}) "ADDRESS")
+ $ "address to bind to" ++ default_ address
+ , Option ['p'] ["port"]
+ (ReqArg (\p -> Just $ mempty {port = Just $ read p}) "PORT")
+ $ "port to listen on" ++ default_ port
+ , Option [] ["access-log"]
+ (ReqArg (\l -> Just $ mempty {accessLog = Just $ Just l}) "PATH")
+ $ "access log" ++ (default_ $ join . accessLog)
+ , Option [] ["error-log"]
+ (ReqArg (\l -> Just $ mempty {errorLog = Just $ Just l}) "PATH")
+ $ "error log" ++ (default_ $ join . errorLog)
+ , Option [] ["no-access-log"]
+ (NoArg $ Just mempty {accessLog = Just Nothing})
+ $ "don't have an access log"
+ , Option [] ["no-error-log"]
+ (NoArg $ Just mempty {errorLog = Just Nothing})
+ $ "don't have an error log"
+ , Option ['c'] ["compression"]
+ (NoArg $ Just $ mempty {compression = Just True})
+ $ "use gzip compression on responses"
+ , Option [] ["no-compression"]
+ (NoArg $ Just $ mempty {compression = Just False})
+ $ "serve responses uncompressed"
+ , Option ['v'] ["verbose"]
+ (NoArg $ Just $ mempty {verbose = Just True})
+ $ "print server status updates to stderr"
+ , Option ['q'] ["quiet"]
+ (NoArg $ Just $ mempty {verbose = Just False})
+ $ "do not print anything to stderr"
+ , Option ['h'] ["help"]
+ (NoArg Nothing)
+ $ "display this help and exit"
+ ]
+ where
+ bs = U.fromString
+ conf = completeConfig defaults
+ default_ f = maybe "" ((", default " ++) . show) $ f conf
+
+
+------------------------------------------------------------------------------
+-- | This returns a 'Config' gotten from parsing the options specified on the
+-- command-line.
+--
+-- The 'Config' parameter is just for specifying any default values which are
+-- to override those in 'defaultConfig'. This is so the usage message can
+-- accurately inform the user what the default values for the options are. In
+-- most cases, you will probably just end up passing 'mempty' for this
+-- parameter.
+--
+-- On Unix systems, the locale is read from the @LANG@ environment variable.
+commandLineConfig :: Config -> IO Config
+commandLineConfig defaults = do
+ args <- getArgs
+ prog <- getProgName
+
+ result <- either (usage prog) return $ case getOpt Permute opts args of
+ (f, _, [] ) -> maybe (Left []) Right $ fmap mconcat $ sequence f
+ (_, _, errs) -> Left errs
+
+#ifndef PORTABLE
+ lang <- getEnv "LANG"
+ return $ mconcat [defaults, result, mempty {locale = fmap untilUTF8 lang}]
+#else
+ return $ mconcat [defaults, result]
+#endif
+
+ where
+ opts = options defaults
+ usage prog errs = do
+ let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:"
+ let msg = concat errs ++ usageInfo hdr opts
+ hPutStrLn stderr msg
+ exitFailure
+ untilUTF8 = takeWhile $ \c -> c == '_' || isAlpha c
------------------------------------------------------------------------------
@@ -27,47 +274,80 @@ snapServerVersion = Int.snapServerVersion
------------------------------------------------------------------------------
--- | Starts serving HTTP requests on the given port using the given handler.
--- This function never returns; to shut down the HTTP server, kill the
--- controlling thread.
-httpServe :: ByteString -- ^ bind address, or \"*\" for all
- -> Int -- ^ port to bind to
- -> ByteString -- ^ local hostname (server name)
- -> Maybe FilePath -- ^ path to the (optional) access log
- -> Maybe FilePath -- ^ path to the (optional) error log
- -> Snap () -- ^ handler procedure
- -> IO ()
-httpServe bindAddress bindPort localHostname alog elog handler =
- Int.httpServe bindAddress bindPort localHostname alog elog handler'
+-- | Starts serving HTTP requests using the given handler. Any settings it
+-- requires are passed directly to it.
+simpleHttpServe :: ByteString -- ^ bind address, or \"*\" for all
+ -> Int -- ^ port to bind to
+ -> ByteString -- ^ local hostname (server name)
+ -> Maybe FilePath -- ^ path to the (optional) access log
+ -> Maybe FilePath -- ^ path to the (optional) error log
+ -> Snap () -- ^ handler procedure
+ -> IO ()
+
+simpleHttpServe address' port' hostname' alog elog handler =
+ Int.httpServe address' port' hostname' alog elog handler'
where
handler' = runSnap handler
------------------------------------------------------------------------------
--- | Starts serving HTTP requests using the given handler, with
--- settings from the 'Config' passed in. This function will only
--- return after being interrupted by an asynchronous exception.
-httpServeConfig :: Config -> Snap () -> IO ()
-httpServeConfig conf handler = do
- ifNoisy . putStrLn $ "Listening on " ++
- (S.unpack $ configBindAddress conf) ++
- ":" ++ show (configListenPort conf)
- _ <- try serve :: IO (Either SomeException ())
- ifNoisy $ putStrLn " shutting down.."
+-- | 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
+ -- ^ Any configuration options which override the defaults
+ -> Snap ()
+ -- ^ The application to be served
+ -> IO ()
+httpServe config handler = do
+ setUnicodeLocale $ conf locale
+ output $ "Listening on " ++ (U.toString $ conf address) ++ ":" ++
+ (show $ conf port)
+ try $ serve $ compress $ catch500 handler :: IO (Either SomeException ())
+ output " shutting down.."
where
- ifNoisy = when $ configVerbose conf
- serve = httpServe (configBindAddress conf)
- (configListenPort conf)
- (configLocalHostname conf)
- (configAccessLog conf)
- (configErrorLog conf)
- handler
+ conf g = fromJust $ g $ completeConfig config
+ output = when (conf verbose) . hPutStrLn stderr
+ serve = simpleHttpServe (conf address)
+ (conf port)
+ (conf hostname)
+ (conf accessLog)
+ (conf errorLog)
+ catch500 = flip catch $ conf errorHandler
+ compress = if conf compression then withCompression else id
+
+
+------------------------------------------------------------------------------
+-- | Starts serving HTTP using the given handler. The configuration is read
+-- from the options given on the command-line, as returned by
+-- 'commandLineConfig'.
+quickHttpServe :: Snap ()
+ -- ^ The application to be served
+ -> IO ()
+quickHttpServe m = commandLineConfig mempty >>= \c -> httpServe c m
------------------------------------------------------------------------------
--- | Starts serving HTTP using the given handler. The configuration
--- is picked up from command-line parameters, as returned by
--- 'readConfigFromCmdLineArgs'.
-quickHttpServe :: Snap () -> IO ()
-quickHttpServe handler =
- readConfigFromCmdLineArgs >>= flip httpServeConfig handler
+-- | Given a string like \"en_US\", this sets the locale to \"en_US.utf8\".
+-- This doesn't work on Windows.
+setUnicodeLocale :: String -> IO ()
+setUnicodeLocale lang = do
+#ifndef PORTABLE
+Â Â Â Â 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
+ return ()
+#endif
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
deleted file mode 100644
index 5fa5dde..0000000
--- a/src/Snap/Http/Server/Config.hs
+++ /dev/null
@@ -1,169 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Snap.Http.Server.Config
- ( Config(..)
- , Flags(..)
- , readConfigFromCmdLineArgs
- , readFlagsFromCmdLineArgs
- , flagsToConfig
- ) where
-
-import qualified Data.ByteString.Char8 as S
-import Data.ByteString (ByteString)
-import Data.Maybe
-import Data.Monoid
-import System.Console.GetOpt
-import System.Environment
-import System.Exit
-import System.IO
-
-------------------------------------------------------------------------------
--- | Holds http server configuration.
-data Config = Config
- { configLocalHostname :: !ByteString -- ^ The name of the server
- , configBindAddress :: !ByteString -- ^ The local interface to
- -- bind to
- , configListenPort :: !Int -- ^ The local port to bind to
- , configAccessLog :: !(Maybe FilePath) -- ^ The path to the access log
- , configErrorLog :: !(Maybe FilePath) -- ^ The path to the error log
- , configVerbose :: !Bool -- ^ Whether to write server status
- -- updates to standard out
- } deriving (Show)
-
-
-------------------------------------------------------------------------------
--- | A monoid instance for use in building 'Config' structures.
-data Flags = Flags
- { flagLocalHost :: Maybe String
- , flagBindAddress :: Maybe String
- , flagPort :: Maybe Int
- , flagAccessLog :: Maybe String
- , flagErrorLog :: Maybe String
- , flagUsage :: Bool
- , flagVerbose :: Bool
- }
-
-
-------------------------------------------------------------------------------
-instance Monoid Flags where
- mempty = Flags Nothing Nothing Nothing Nothing Nothing False False
-
- (Flags a1 b1 c1 d1 e1 f1 g1) `mappend` (Flags a2 b2 c2 d2 e2 f2 g2) =
- Flags (getLast $ Last a1 `mappend` Last a2)
- (getLast $ Last b1 `mappend` Last b2)
- (getLast $ Last c1 `mappend` Last c2)
- (getLast $ Last d1 `mappend` Last d2)
- (getLast $ Last e1 `mappend` Last e2)
- (f1 || f2)
- (g1 || g2)
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the local host attribute set.
-flagLH :: String -> Flags
-flagLH s = mempty { flagLocalHost = Just s }
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the bind address attribute set.
-flagBA :: String -> Flags
-flagBA s = mempty { flagBindAddress = Just s }
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the port attribute set.
-flagPt :: String -> Flags
-flagPt p = mempty { flagPort = Just (read p) }
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the access log attribute set.
-flagAL :: String -> Flags
-flagAL s = mempty { flagAccessLog = Just s }
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the error log attribute set.
-flagEL :: String -> Flags
-flagEL s = mempty { flagErrorLog = Just s }
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the help attribute set.
-flagHelp :: Flags
-flagHelp = mempty { flagUsage = True }
-
-
-------------------------------------------------------------------------------
--- | Create a flag with the verbose attribute set.
-flagV :: Flags
-flagV = mempty { flagVerbose = True }
-
-
-------------------------------------------------------------------------------
--- | Convert 'Flags' to a 'Config'.
-flagsToConfig :: Flags -> Config
-flagsToConfig (Flags a b c d e _ g) =
- Config (maybe "localhost" S.pack a)
- (maybe "0.0.0.0" S.pack b)
- (fromMaybe 8000 c)
- d
- e
- g
-
-
-------------------------------------------------------------------------------
-options :: [OptDescr Flags]
-options =
- [ Option "l" ["localHostname"]
- (ReqArg flagLH "STR")
- "local hostname, default 'localhost'"
- , Option "p" ["listenPort"]
- (ReqArg flagPt "NUM")
- "port to listen on, default 8000"
- , Option "b" ["bindAddress"]
- (ReqArg flagBA "STR")
- "address to bind to, default '0.0.0.0'"
- , Option "a" ["accessLog"]
- (ReqArg flagAL "STR")
- "access log in the 'combined' format, optional"
- , Option "e" ["errorLog"]
- (ReqArg flagEL "STR")
- "error log, optional"
- , Option "v" ["verbose"]
- (NoArg flagV)
- "print server status updates to standard out"
- , Option "h" ["help"]
- (NoArg flagHelp)
- "display this usage statement"
- ]
-
-
-------------------------------------------------------------------------------
--- | Read the command line arguments and parse 'Flags' out of them.
-readFlagsFromCmdLineArgs :: IO Flags
-readFlagsFromCmdLineArgs = do
- argv <- getArgs
- progName <- getProgName
-
- case getOpt Permute options argv of
- (f, _, [] ) -> withFlags progName f
- (_, _, errs) -> bombout progName errs
- where
- bombout progName errs = do
- let hdr = "\nUsage: " ++ progName ++ " [OPTIONS]"
- let msg = concat errs ++ usageInfo hdr options
- hPutStrLn stderr msg
- exitFailure
-
- withFlags progName fs = do
- let f = mconcat fs
- if flagUsage f
- then bombout progName []
- else return f
-
-
-------------------------------------------------------------------------------
--- | Read the command line arguments and parse a 'Config' out of them.
-readConfigFromCmdLineArgs :: IO Config
-readConfigFromCmdLineArgs = fmap flagsToConfig readFlagsFromCmdLineArgs
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
