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 e33c38bcd1ef43de9b2addea1ea5dfb62b03efb4 (commit)
from f3007d5b5b9bc1cf7ad1a7be545d680d4be53c18 (commit)
Summary of changes:
snap-server.cabal | 1 +
src/Snap/Http/Server.hs | 38 +++++++++++
src/Snap/Http/Server/Config.hs | 145 +++++++++++++++++++++++++++-------------
3 files changed, 138 insertions(+), 46 deletions(-)
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 e33c38bcd1ef43de9b2addea1ea5dfb62b03efb4
Author: Carl Howells <[email protected]>
Date: Mon Jun 28 22:57:01 2010 -0700
Do a lot more work on Config support
diff --git a/snap-server.cabal b/snap-server.cabal
index c7883fa..7861a37 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -108,6 +108,7 @@ Library
dlist >= 0.5 && < 0.6,
filepath,
iteratee >= 0.3.1 && <0.4,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
monads-fd,
network == 2.2.1.*,
old-locale,
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index bab1a2d..8d69a35 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -5,15 +5,23 @@
module Snap.Http.Server
(
httpServe
+, httpServeConfig
+, quickHttpServe
, snapServerVersion
) where
+import Control.Exception (SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import qualified Data.ByteString.Char8 as S
import Data.ByteString (ByteString)
import Snap.Types
import qualified Snap.Internal.Http.Server as Int
+import Snap.Http.Server.Config
------------------------------------------------------------------------------
+-- | A short string describing the Snap server version
snapServerVersion :: ByteString
snapServerVersion = Int.snapServerVersion
@@ -33,3 +41,33 @@ httpServe bindAddress bindPort localHostname alog elog
handler =
Int.httpServe bindAddress bindPort localHostname 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.."
+ where
+ ifNoisy = when $ configVerbose conf
+ serve = httpServe (configBindAddress conf)
+ (configListenPort conf)
+ (configLocalHostname conf)
+ (configAccessLog conf)
+ (configErrorLog conf)
+ handler
+
+
+------------------------------------------------------------------------------
+-- | 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
index 1accaa5..be5fd07 100644
--- a/src/Snap/Http/Server/Config.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -1,16 +1,22 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
module Snap.Http.Server.Config
( Config(..)
+ , Flags(..)
, readConfigFromCmdLineArgs
+ , readFlagsFromCmdLineArgs
+ , flagsToConfig
+ , flagLH
+ , flagBA
+ , flagPt
+ , flagAL
+ , flagEL
+ , flagHelp
+ , flagV
) where
+import qualified Data.ByteString.Char8 as S
import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import Data.ByteString.Internal (c2w)
-import Data.ByteString.Char8 ()
import Data.Maybe
import Data.Monoid
import System.Console.GetOpt
@@ -18,100 +24,141 @@ import System.Environment
import System.Exit
import System.IO
+------------------------------------------------------------------------------
+-- | Holds http server configuration.
data Config = Config
- { localHostname :: !ByteString
- , bindAddress :: !ByteString
- , listenPort :: !Int
- , accessLog :: !(Maybe FilePath)
- , errorLog :: !(Maybe FilePath)
+ { 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)
-data Flag = Flag
+------------------------------------------------------------------------------
+-- | 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 Flag where
- mempty = Flag Nothing Nothing Nothing Nothing Nothing False
- (Flag a1 b1 c1 d1 e1 f1) `mappend` (Flag a2 b2 c2 d2 e2 f2) =
- Flag (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)
+------------------------------------------------------------------------------
+instance Monoid Flags where
+ mempty = Flags Nothing Nothing Nothing Nothing Nothing False False
-flagLH :: String -> Flag
+ (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 }
-flagBA :: String -> Flag
+
+------------------------------------------------------------------------------
+-- | Create a flag with the bind address attribute set.
+flagBA :: String -> Flags
flagBA s = mempty { flagBindAddress = Just s }
-flagPt :: String -> Flag
+
+------------------------------------------------------------------------------
+-- | Create a flag with the port attribute set.
+flagPt :: String -> Flags
flagPt p = mempty { flagPort = Just (read p) }
-flagAL :: String -> Flag
+
+------------------------------------------------------------------------------
+-- | Create a flag with the access log attribute set.
+flagAL :: String -> Flags
flagAL s = mempty { flagAccessLog = Just s }
-flagEL :: String -> Flag
+
+------------------------------------------------------------------------------
+-- | Create a flag with the error log attribute set.
+flagEL :: String -> Flags
flagEL s = mempty { flagErrorLog = Just s }
-flagHelp :: Flag
+
+------------------------------------------------------------------------------
+-- | Create a flag with the help attribute set.
+flagHelp :: Flags
flagHelp = mempty { flagUsage = True }
-fromStr :: String -> ByteString
-fromStr = B.pack . map c2w
-flags2config :: Flag -> Config
-flags2config (Flag a b c d e _) =
- Config (maybe "localhost" fromStr a)
- (maybe "*" fromStr b)
- (fromMaybe 8888 c)
+------------------------------------------------------------------------------
+-- | 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 Flag]
+------------------------------------------------------------------------------
+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 8888"
+ "port to listen on, default 8000"
, Option "b" ["bindAddress"]
(ReqArg flagBA "STR")
- "address to bind to, default '*'"
+ "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" ]
+ "display this usage statement"
+ ]
-readConfigFromCmdLineArgs :: String -- ^ application description, e.g.
- -- \"Foo applet v0.2\"
- -> IO Config
-readConfigFromCmdLineArgs appName = do
+------------------------------------------------------------------------------
+-- | 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
+ (f, _, [] ) -> withFlags progName f
+ (_, _, errs) -> bombout progName errs
where
bombout progName errs = do
- let hdr = appName ++ "\n\nUsage: " ++ progName ++ " [OPTIONS]"
+ let hdr = "\nUsage: " ++ progName ++ " [OPTIONS]"
let msg = concat errs ++ usageInfo hdr options
hPutStrLn stderr msg
exitFailure
@@ -119,5 +166,11 @@ readConfigFromCmdLineArgs appName = do
withFlags progName fs = do
let f = mconcat fs
if flagUsage f
- then bombout progName []
- else return $ flags2config 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
