[Snap Framework] snap-server branch, 0.3, updated. 243d9b22e9935b8296b03731bb2fa72ed4c5286c

noreply at snapframework.com noreply at snapframework.com
Fri Jul 9 07:24:05 CDT 2010


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 <shane at duairc.com>
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


More information about the Snap mailing list