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 05004c9505fa80af1b3dfbc9121c1f200d41495e (commit)
from 9e0b1bc0e75e872fef1cf83019a1a052b2f91a63 (commit)
Summary of changes:
CONTRIBUTORS | 1 -
snap-server.cabal | 2 +-
src/Snap/Http/Server.hs | 349 ++++++----------------------------------
src/Snap/Http/Server/Config.hs | 169 +++++++++++++++++++
4 files changed, 218 insertions(+), 303 deletions(-)
create 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 05004c9505fa80af1b3dfbc9121c1f200d41495e
Author: Shane <[email protected]>
Date: Fri Jul 2 15:46:37 2010 +0100
Revert "Refactored Server/Config.hs by removing duplication and renaming
Flags to Config."
I'm reverting this commit because it changes the snap-server interface,
breaking snap's project template, and I don't yet have the expertise to fix it.
Rather than leaving it broken until I figure out how to fix it I'll just revert.
This reverts commit 9e0b1bc0e75e872fef1cf83019a1a052b2f91a63.
diff --git a/CONTRIBUTORS b/CONTRIBUTORS
index 8f8e3ab..cc14685 100644
--- a/CONTRIBUTORS
+++ b/CONTRIBUTORS
@@ -2,6 +2,5 @@ Doug Beardsley <[email protected]>
Gregory Collins <[email protected]>
Shu-yu Guo <[email protected]>
Carl Howells <[email protected]>
-Shane O'Brien <[email protected]>
James Sanders <[email protected]>
Jacob Stanley <[email protected]>
diff --git a/snap-server.cabal b/snap-server.cabal
index ff921dd..7861a37 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -85,6 +85,7 @@ Library
exposed-modules:
Snap.Http.Server,
+ Snap.Http.Server.Config,
System.FastLogger
other-modules:
@@ -115,7 +116,6 @@ Library
time,
transformers,
unix-compat,
- utf8-string,
vector >= 0.6 && <0.7
if flag(portable) || os(windows)
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index 1c3c2e1..8d69a35 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -1,253 +1,23 @@
-{-# 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.
-
--}
-
+-- | 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
- ( Config(..)
- , defaultConfig
- , commandLineConfig
- , httpServe
- , quickHttpServe
- , snapServerVersion
- ) where
+(
+ httpServe
+, httpServeConfig
+, quickHttpServe
+, snapServerVersion
+) where
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
-import qualified Data.ByteString.UTF8 as U
+import qualified Data.ByteString.Char8 as S
import Data.ByteString (ByteString)
-import Data.Char
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Prelude hiding (catch)
import Snap.Types
-import Snap.Util.GZip
import qualified Snap.Internal.Http.Server as Int
-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 MonadSnap m => Config m = 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 -> m ())
- -- ^ A MonadSnap action to handle 500 errors
- }
-
-
-------------------------------------------------------------------------------
-instance MonadSnap m => Show (Config m) 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 MonadSnap m => Monoid (Config m) 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)
- }
-
-
-------------------------------------------------------------------------------
--- | 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 :: MonadSnap m => Config m
-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
- putResponse $ setContentType "text/plain; charset=utf-8" $
- Â Â Â Â Â Â Â Â setResponseStatus 500 "Internal Server Error" emptyResponse
-Â Â Â Â Â Â Â Â writeBS "A web handler threw an exception. Details:\n"
-Â Â Â Â Â Â Â Â writeBS $ U.fromString $ show e
- }
-
-
-------------------------------------------------------------------------------
--- | Completes a partial 'Config' by filling in the unspecified values with
--- the default values from 'defaultConfig'.
-completeConfig :: MonadSnap m => Config m -> Config m
-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' m)@
--- as opposed to a @'Config' m@, 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 :: MonadSnap m => Config m -> [OptDescr (Maybe (Config m))]
-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 :: MonadSnap m => Config m -> IO (Config m)
-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
+import Snap.Http.Server.Config
------------------------------------------------------------------------------
@@ -257,70 +27,47 @@ snapServerVersion = Int.snapServerVersion
------------------------------------------------------------------------------
--- | 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 :: MonadSnap m
- => Config m
- -> (m () -> IO (Snap ()))
- -- ^ Any configuration options which override the defaults
- -> m ()
- -- ^ The @run@ function for the application's monad
+-- | 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 ()
- -- ^ The application to be served
-httpServe config f handler = do
- setUnicodeLocale $ conf locale
- output $ "Listening on " ++ (U.toString $ conf address) ++ ":" ++
- (show $ conf port)
- snap <- f $ compress $ catch500 handler
- _ <- try $ serve snap :: IO (Either SomeException ())
- output " shutting down.."
+httpServe bindAddress bindPort localHostname alog elog handler =
+ Int.httpServe bindAddress bindPort localHostname alog elog handler'
where
- conf g = fromJust $ g $ completeConfig config
- output = when (conf verbose) . hPutStrLn stderr
- serve = Int.httpServe (conf address)
- (conf port)
- (conf hostname)
- (conf accessLog)
- (conf errorLog) . runSnap
- catch500 = flip catch $ conf errorHandler
- compress = if conf compression then withCompression else id
+ handler' = runSnap handler
------------------------------------------------------------------------------
--- | Starts serving HTTP using the given handler. The configuration is read
--- from the options given on the command-line, as returned by
--- 'commandLineConfig'.
-quickHttpServe :: MonadSnap m
- => (m () -> IO (Snap ()))
- -> m ()
- -- ^ The @run@ function for the application's monad
- -> IO ()
- -- ^ The application to be served
-quickHttpServe f m = commandLineConfig mempty >>= \c -> httpServe c f m
+-- | 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.."
+ where
+ ifNoisy = when $ configVerbose conf
+ serve = httpServe (configBindAddress conf)
+ (configListenPort conf)
+ (configLocalHostname conf)
+ (configAccessLog conf)
+ (configErrorLog conf)
+ 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 ++ ".utf8") 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
+-- | 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
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
new file mode 100644
index 0000000..5fa5dde
--- /dev/null
+++ b/src/Snap/Http/Server/Config.hs
@@ -0,0 +1,169 @@
+{-# 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
