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 ca9653aa7f3b0f60232c1a776e2f581c1d9fd68b (commit)
via 830436d4301db8b1608bc6b10d96ab1f3bf7bab4 (commit)
from 243d9b22e9935b8296b03731bb2fa72ed4c5286c (commit)
Summary of changes:
snap-server.cabal | 1 +
src/Snap/Http/Server.hs | 308 +++----------------------
src/Snap/Http/{Server.hs => Server/Config.hs} | 303 +++++++++++++-----------
3 files changed, 202 insertions(+), 410 deletions(-)
copy src/Snap/Http/{Server.hs => Server/Config.hs} (54%)
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 ca9653aa7f3b0f60232c1a776e2f581c1d9fd68b
Author: Shane <[email protected]>
Date: Wed Jul 14 13:27:46 2010 +0100
Small cosmetic changes and bug fixes
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index 00628d1..066fab9 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -49,8 +49,9 @@ snapServerVersion = Int.snapServerVersion
-- settings from the given config; error handling and compression are ignored.
-- This function never returns; to shut down the HTTP server, kill the
-- controlling thread.
-simpleHttpServe :: Config Snap () -> Snap () -> IO ()
-simpleHttpServe config handler =
+simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
+simpleHttpServe config handler = do
+ setUnicodeLocale $ fromJust $ getLocale conf
Int.httpServe (fromJust $ getAddress conf)
(fromJust $ getPort conf)
(fromJust $ getHostname conf)
@@ -67,15 +68,14 @@ simpleHttpServe config handler =
-- server, kill the controlling thread.
httpServe :: Config Snap () -> Snap () -> IO ()
httpServe config handler = do
- setUnicodeLocale $ fromJust $ getLocale conf
output $ "Listening on " ++ (U.toString $ fromJust $ getAddress conf) ++
":" ++ (show $ fromJust $ getPort conf)
- try $ serve $ compress $ catch500 handler :: IO (Either SomeException ())
- output " shutting down..."
+ _ <- try $ serve handler :: IO (Either SomeException ())
+ output "\nShutting down..."
where
conf = completeConfig config
output = when (fromJust $ getVerbose conf) . hPutStrLn stderr
- serve = simpleHttpServe config
+ serve = simpleHttpServe config . compress . catch500
catch500 = flip catch $ fromJust $ getErrorHandler conf
compress = if fromJust $ getCompression conf then withCompression else id
@@ -90,12 +90,12 @@ quickHttpServe m = commandLineConfig emptyConfig >>= \c ->
httpServe c m
------------------------------------------------------------------------------
--- | Given a string like \"en_US\", this sets the locale to \"en_US.utf8\".
+-- | 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 lang = do
+setUnicodeLocale lang =
#ifndef PORTABLE
-Â Â Â Â mapM_ (\k -> setEnv k (lang ++ ".utf8") True)
+Â Â Â Â mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True)
          [ "LANG"
          , "LC_CTYPE"
          , "LC_NUMERIC"
commit 830436d4301db8b1608bc6b10d96ab1f3bf7bab4
Author: Shane <[email protected]>
Date: Tue Jul 13 21:21:05 2010 +0100
Moved the Config part of Server.hs to a separate module, as it was before.
The Config code can then be reused in the construction of domain-specific
"httpServe" functions.
diff --git a/snap-server.cabal b/snap-server.cabal
index 53b5ae0..9e0518f 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -89,6 +89,7 @@ Library
exposed-modules:
Snap.Http.Server,
+ Snap.Http.Server.Config,
System.FastLogger
other-modules:
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index 10cf682..00628d1 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -10,321 +10,83 @@ interface to the HTTP protocol.
-}
-
module Snap.Http.Server
- ( Config(..)
- , defaultConfig
- , commandLineConfig
- , simpleHttpServe
- , internalError
+ ( simpleHttpServe
, httpServe
, quickHttpServe
, snapServerVersion
+ , setUnicodeLocale
+ , module Snap.Http.Server.Config
) where
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
-import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as U
import Data.ByteString (ByteString)
import Data.Char
import Data.List
import Data.Maybe
-import Data.Monoid
import Prelude hiding (catch)
+import Snap.Http.Server.Config
import qualified Snap.Internal.Http.Server as Int
-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
-
-
-------------------------------------------------------------------------------
-- | A short string describing the Snap server version
snapServerVersion :: ByteString
snapServerVersion = Int.snapServerVersion
------------------------------------------------------------------------------
--- | 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'
+-- | Starts serving HTTP requests using the given handler. Uses only the basic
+-- settings from the given config; error handling and compression are ignored.
+-- This function never returns; to shut down the HTTP server, kill the
+-- controlling thread.
+simpleHttpServe :: Config Snap () -> Snap () -> IO ()
+simpleHttpServe config handler =
+ Int.httpServe (fromJust $ getAddress conf)
+ (fromJust $ getPort conf)
+ (fromJust $ getHostname conf)
+ (fromJust $ getAccessLog conf)
+ (fromJust $ getErrorLog conf)
+ (runSnap handler)
where
- handler' = runSnap handler
+ conf = completeConfig config
------------------------------------------------------------------------------
-- | 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 Snap () -> Snap () -> IO ()
httpServe config handler = do
- setUnicodeLocale $ conf locale
- output $ "Listening on " ++ (U.toString $ conf address) ++ ":" ++
- (show $ conf port)
+ setUnicodeLocale $ fromJust $ getLocale conf
+ output $ "Listening on " ++ (U.toString $ fromJust $ getAddress conf) ++
+ ":" ++ (show $ fromJust $ getPort conf)
try $ serve $ compress $ catch500 handler :: IO (Either SomeException ())
- output " shutting down.."
+ output " shutting down..."
where
- 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
+ conf = completeConfig config
+ output = when (fromJust $ getVerbose conf) . hPutStrLn stderr
+ serve = simpleHttpServe config
+ catch500 = flip catch $ fromJust $ getErrorHandler conf
+ compress = if fromJust $ getCompression conf 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
+-- '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
------------------------------------------------------------------------------
@@ -333,7 +95,7 @@ quickHttpServe m = commandLineConfig mempty >>= \c ->
httpServe c m
setUnicodeLocale :: String -> IO ()
setUnicodeLocale lang = do
#ifndef PORTABLE
-Â Â Â Â mapM_ (\k -> setEnv k (lang ++ ".utf-8") True)
+Â Â Â Â mapM_ (\k -> setEnv k (lang ++ ".utf8") True)
          [ "LANG"
          , "LC_CTYPE"
          , "LC_NUMERIC"
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server/Config.hs
similarity index 54%
copy from src/Snap/Http/Server.hs
copy to src/Snap/Http/Server/Config.hs
index 10cf682..1dd78be 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -3,40 +3,53 @@
{-|
-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.
+This module exports the 'Config' datatype which represents partially-specified
+configurations of \"serve\" functions which run 'Snap' actions in 'IO'.
-}
-
-module Snap.Http.Server
- ( Config(..)
+module Snap.Http.Server.Config
+ ( Config
+ , emptyConfig
, defaultConfig
+ , completeConfig
, commandLineConfig
- , simpleHttpServe
- , internalError
- , httpServe
- , quickHttpServe
- , snapServerVersion
+
+ , getHostname
+ , getAddress
+ , getPort
+ , getAccessLog
+ , getErrorLog
+ , getLocale
+ , getCompression
+ , getVerbose
+ , getErrorHandler
+ , getOther
+
+ , setHostname
+ , setAddress
+ , setPort
+ , setAccessLog
+ , setErrorLog
+ , setLocale
+ , setCompression
+ , setVerbose
+ , setErrorHandler
+ , setOther
) where
import Control.Exception (SomeException)
import Control.Monad
-import Control.Monad.CatchIO
-import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as U
+import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
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.Iteratee ((>.), enumBS)
import Snap.Types
-import Snap.Util.GZip
+import Snap.Iteratee ((>.), enumBS)
import System.Console.GetOpt
import System.Environment hiding (getEnv)
#ifndef PORTABLE
@@ -51,11 +64,11 @@ import System.IO
-- 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}
+-- > setPort 9000 mempty
--
-- 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
+data MonadSnap m => Config m a = Config
{ hostname :: Maybe ByteString
-- ^ The name of the server
, address :: Maybe ByteString
@@ -72,13 +85,15 @@ data Config = Config
-- ^ 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
+ , errorHandler :: Maybe (SomeException -> m ())
+ -- ^ A MonadSnap action to handle 500 errors
+ , other :: Maybe a
+ -- ^ This is for any other state needed to initialize a custom server
}
------------------------------------------------------------------------------
-instance Show (Config) where
+instance MonadSnap m => Show (Config m a) where
show c = "Config {" ++ concat (intersperse ", " $ filter (/="") $ map ($c)
[ showM "hostname" . hostname
, showM "address" . address
@@ -95,7 +110,14 @@ instance Show (Config) where
------------------------------------------------------------------------------
-instance Monoid (Config) where
+-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
+-- 'Config''s 'Monoid' instance.
+emptyConfig :: MonadSnap m => Config m a
+emptyConfig = mempty
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => Monoid (Config m a) where
mempty = Config
{ hostname = Nothing
, address = Nothing
@@ -106,6 +128,7 @@ instance Monoid (Config) where
, compression = Nothing
, verbose = Nothing
, errorHandler = Nothing
+ , other = Nothing
}
a `mappend` b = Config
@@ -118,24 +141,11 @@ instance Monoid (Config) where
, compression = (compression b) `mplus` (compression a)
, verbose = (verbose b) `mplus` (verbose a)
, errorHandler = (errorHandler b) `mplus` (errorHandler a)
+ , other = (other b) `mplus` (other 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"
@@ -148,7 +158,7 @@ internalError msg =
-- > verbose = True
-- > errorHandler = prints the error message
--
-defaultConfig :: Config
+defaultConfig :: MonadSnap m => Config m a
defaultConfig = Config
{ hostname = Just "localhost"
, address = Just "0.0.0.0"
@@ -158,16 +168,21 @@ defaultConfig = Config
, 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)
+ , errorHandler = Just $ \e -> let msg = U.fromString $ show e in
+ finishWith $ setContentType "text/plain; charset=utf-8"
+ . setContentLength (fromIntegral $ B.length msg)
+ . setResponseStatus 500 "Internal Server Error"
+ . modifyResponseBody (>. (enumBS $ mappend
+ "A web handler threw an exception. Details:\n" msg))
+ $ emptyResponse
+ , other = Nothing
}
------------------------------------------------------------------------------
-- | Completes a partial 'Config' by filling in the unspecified values with
-- the default values from 'defaultConfig'.
-completeConfig :: Config -> Config
+completeConfig :: MonadSnap m => Config m a -> Config m a
completeConfig = mappend defaultConfig
@@ -181,51 +196,50 @@ completeConfig = mappend defaultConfig
-- 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
+-- 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 :: Config -> [OptDescr (Maybe Config)]
+options :: MonadSnap m => Config m a -> [OptDescr (Maybe (Config m a))]
options defaults =
[ Option [] ["hostname"]
- (ReqArg (\h -> Just $ mempty {hostname = Just $ bs h}) "NAME")
- $ "local hostname" ++ default_ hostname
+ (ReqArg (Just . flip setHostname mempty . U.fromString) "NAME")
+ $ "local hostname" ++ default_ getHostname
, Option ['b'] ["address"]
- (ReqArg (\a -> Just $ mempty {address = Just $ bs a}) "ADDRESS")
- $ "address to bind to" ++ default_ address
+ (ReqArg (Just . flip setAddress mempty . U.fromString) "ADDRESS")
+ $ "address to bind to" ++ default_ getAddress
, Option ['p'] ["port"]
- (ReqArg (\p -> Just $ mempty {port = Just $ read p}) "PORT")
- $ "port to listen on" ++ default_ port
+ (ReqArg (Just . flip setPort mempty . read) "PORT")
+ $ "port to listen on" ++ default_ getPort
, Option [] ["access-log"]
- (ReqArg (\l -> Just $ mempty {accessLog = Just $ Just l}) "PATH")
- $ "access log" ++ (default_ $ join . accessLog)
+ (ReqArg (Just . flip setAccessLog mempty . Just) "PATH")
+ $ "access log" ++ (default_ $ join . getAccessLog)
, Option [] ["error-log"]
- (ReqArg (\l -> Just $ mempty {errorLog = Just $ Just l}) "PATH")
- $ "error log" ++ (default_ $ join . errorLog)
+ (ReqArg (Just . flip setErrorLog mempty . Just) "PATH")
+ $ "error log" ++ (default_ $ join . getErrorLog)
, Option [] ["no-access-log"]
- (NoArg $ Just mempty {accessLog = Just Nothing})
+ (NoArg $ Just $ setErrorLog Nothing mempty)
$ "don't have an access log"
, Option [] ["no-error-log"]
- (NoArg $ Just mempty {errorLog = Just Nothing})
+ (NoArg $ Just $ setAccessLog Nothing mempty)
$ "don't have an error log"
, Option ['c'] ["compression"]
- (NoArg $ Just $ mempty {compression = Just True})
+ (NoArg $ Just $ setCompression True mempty)
$ "use gzip compression on responses"
, Option [] ["no-compression"]
- (NoArg $ Just $ mempty {compression = Just False})
+ (NoArg $ Just $ setCompression False mempty)
$ "serve responses uncompressed"
, Option ['v'] ["verbose"]
- (NoArg $ Just $ mempty {verbose = Just True})
+ (NoArg $ Just $ setVerbose True mempty)
$ "print server status updates to stderr"
, Option ['q'] ["quiet"]
- (NoArg $ Just $ mempty {verbose = Just False})
+ (NoArg $ Just $ setVerbose False mempty)
$ "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
@@ -241,7 +255,7 @@ options defaults =
-- parameter.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.
-commandLineConfig :: Config -> IO Config
+commandLineConfig :: MonadSnap m => Config m a -> IO (Config m a)
commandLineConfig defaults = do
args <- getArgs
prog <- getProgName
@@ -252,7 +266,7 @@ commandLineConfig defaults = do
#ifndef PORTABLE
lang <- getEnv "LANG"
- return $ mconcat [defaults, result, mempty {locale = fmap untilUTF8 lang}]
+ return $ mconcat [defaults, result, mempty {locale = fmap upToUtf8 lang}]
#else
return $ mconcat [defaults, result]
#endif
@@ -264,90 +278,105 @@ commandLineConfig defaults = do
let msg = concat errs ++ usageInfo hdr opts
hPutStrLn stderr msg
exitFailure
- untilUTF8 = takeWhile $ \c -> c == '_' || isAlpha c
+ upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c
------------------------------------------------------------------------------
--- | A short string describing the Snap server version
-snapServerVersion :: ByteString
-snapServerVersion = Int.snapServerVersion
+getHostname :: MonadSnap m => Config m a -> Maybe ByteString
+getHostname = hostname
------------------------------------------------------------------------------
--- | 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
+getAddress :: MonadSnap m => Config m a -> Maybe ByteString
+getAddress = address
------------------------------------------------------------------------------
--- | 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
- 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
+getPort :: MonadSnap m => Config m a -> Maybe Int
+getPort = port
------------------------------------------------------------------------------
--- | 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
+getAccessLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)
+getAccessLog = accessLog
------------------------------------------------------------------------------
--- | 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
+getErrorLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)
+getErrorLog = errorLog
+
+
+------------------------------------------------------------------------------
+getLocale :: MonadSnap m => Config m a -> Maybe String
+getLocale = locale
+
+
+------------------------------------------------------------------------------
+getCompression :: MonadSnap m => Config m a -> Maybe Bool
+getCompression = compression
+
+
+------------------------------------------------------------------------------
+getVerbose :: MonadSnap m => Config m a -> Maybe Bool
+getVerbose = verbose
+
+
+------------------------------------------------------------------------------
+getErrorHandler :: MonadSnap m => Config m a -> Maybe (SomeException -> m ())
+getErrorHandler = errorHandler
+
+
+------------------------------------------------------------------------------
+getOther :: MonadSnap m => Config m a -> Maybe a
+getOther = other
+
+
+------------------------------------------------------------------------------
+setHostname :: MonadSnap m => ByteString -> Config m a -> Config m a
+setHostname a m = m {hostname = Just a}
+
+
+------------------------------------------------------------------------------
+setAddress :: MonadSnap m => ByteString -> Config m a -> Config m a
+setAddress a m = m {address = Just a}
+
+
+------------------------------------------------------------------------------
+setPort :: MonadSnap m => Int -> Config m a -> Config m a
+setPort a m = m {port = Just a}
+
+
+------------------------------------------------------------------------------
+setAccessLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a
+setAccessLog a m = m {accessLog = Just a}
+
+
+------------------------------------------------------------------------------
+setErrorLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a
+setErrorLog a m = m {errorLog = Just a}
+
+
+------------------------------------------------------------------------------
+setLocale :: MonadSnap m => String -> Config m a -> Config m a
+setLocale a m = m {locale = Just a}
+
+
+------------------------------------------------------------------------------
+setCompression :: MonadSnap m => Bool -> Config m a -> Config m a
+setCompression a m = m {compression = Just a}
+
+
+------------------------------------------------------------------------------
+setVerbose :: MonadSnap m => Bool -> Config m a -> Config m a
+setVerbose a m = m {verbose = Just a}
+
+
+------------------------------------------------------------------------------
+setErrorHandler :: MonadSnap m => (SomeException -> m ()) -> Config m a
+ -> Config m a
+setErrorHandler a m = m {errorHandler = Just a}
+
+
+------------------------------------------------------------------------------
+setOther :: MonadSnap m => a -> Config m a -> Config m a
+setOther a m = m {other = Just a}
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
