diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -1,5 +1,5 @@ -Snap Framework 0.1.1 --------------------- +Snap Framework +-------------- This is the first developer prerelease of the Snap framework. Snap is a simple and fast web development framework and server written in Haskell. For more diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -Snap Framework Core 0.1.1 -========================== +Snap Framework Core +=================== This is the first developer prerelease of the Snap Framework Core library. For more information about Snap, read the `README.SNAP.md` or visit the Snap diff --git a/extra/haddock.css b/extra/haddock.css --- a/extra/haddock.css +++ b/extra/haddock.css @@ -50,7 +50,7 @@ BODY { -moz-border-radius:5px; -webkit-border-radius:5px; - width: 90ex; + width: 50em; margin: 2em auto; padding: 0; background-color: #ffffff; diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.1.2 +version: 0.2.1 synopsis: Snap: A Haskell Web Framework (Core) description: @@ -41,7 +41,7 @@ license: BSD3 license-file: LICENSE -author: James Sanders, Gregory Collins, Doug Beardsley +author: James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley maintainer: snap@snapframework.com build-type: Simple cabal-version: >= 1.6 @@ -191,4 +191,4 @@ source-repository head type: git - location: http://git.snapframework.com/snap-core + location: http://git.snapframework.com/snap-core.git diff --git a/src/Data/CIByteString.hs b/src/Data/CIByteString.hs --- a/src/Data/CIByteString.hs +++ b/src/Data/CIByteString.hs @@ -19,6 +19,7 @@ ( CIByteString , toCI , unCI + , ciToLower ) where -- for IsString instance @@ -38,6 +39,9 @@ toCI s = CIByteString s t where t = lowercase s + +ciToLower :: CIByteString -> ByteString +ciToLower = _lowercased instance Show CIByteString where show (CIByteString s _) = show s diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs --- a/src/Snap/Internal/Routing.hs +++ b/src/Snap/Internal/Routing.hs @@ -88,10 +88,6 @@ -- set to \"@\/foo\/bar\/quux\/@\" and 'rqPathInfo' set to -- \"@...anything...@\". -- --- @FIXME@\/@TODO@: we need a version with and without the context path setting --- behaviour; if the route is \"@article\/:id\/print@\", we probably want the --- contextPath to be \"@\/article@\" instead of \"@\/article\/whatever\/print@\". --- -- A path component within an URL entry point beginning with a colon (\"@:@\") -- is treated as a /variable capture/; the corresponding path component within -- the request URI will be entered into the 'rqParams' parameters mapping with diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -90,7 +90,8 @@ ------------------------------------------------------------------------------ data SnapState = SnapState { _snapRequest :: Request - , _snapResponse :: Response } + , _snapResponse :: Response + , _snapLogError :: ByteString -> IO () } ------------------------------------------------------------------------------ @@ -357,6 +358,14 @@ ------------------------------------------------------------------------------ +-- | Log an error message in the 'Snap' monad +logError :: ByteString -> Snap () +logError s = Snap $ gets _snapLogError >>= (\l -> liftIO $ l s) + >> return (Just $ Right ()) +{-# INLINE logError #-} + + +------------------------------------------------------------------------------ -- | Adds the output from the given enumerator to the 'Response' -- stored in the 'Snap' monad state. addToOutput :: (forall a . Enumerator a) -- ^ output to add @@ -456,8 +465,11 @@ ------------------------------------------------------------------------------ -- | Runs a 'Snap' monad action in the 'Iteratee IO' monad. -runSnap :: Snap a -> Request -> Iteratee IO (Request,Response) -runSnap (Snap m) req = do +runSnap :: Snap a + -> (ByteString -> IO ()) + -> Request + -> Iteratee IO (Request,Response) +runSnap (Snap m) logerr req = do (r, ss') <- runStateT m ss e <- maybe (return $ Left fourohfour) @@ -479,13 +491,16 @@ dresp = emptyResponse { rspHttpVersion = rqVersion req } - ss = SnapState req dresp + ss = SnapState req dresp logerr {-# INLINE runSnap #-} ------------------------------------------------------------------------------ -evalSnap :: Snap a -> Request -> Iteratee IO a -evalSnap (Snap m) req = do +evalSnap :: Snap a + -> (ByteString -> IO ()) + -> Request + -> Iteratee IO a +evalSnap (Snap m) logerr req = do (r, _) <- runStateT m ss e <- maybe (liftIO $ throwIO NoHandlerException) @@ -498,7 +513,7 @@ Right x -> return x where dresp = emptyResponse { rspHttpVersion = rqVersion req } - ss = SnapState req dresp + ss = SnapState req dresp logerr {-# INLINE evalSnap #-} diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs --- a/src/Snap/Starter.hs +++ b/src/Snap/Starter.hs @@ -3,6 +3,7 @@ ------------------------------------------------------------------------------ import System import System.Directory +import System.Console.GetOpt import System.FilePath.Posix ------------------------------------------------------------------------------ @@ -20,29 +21,62 @@ ------------------------------------------------------------------------------ -initProject :: IO () -initProject = do - cur <- getCurrentDirectory - let dirs = splitDirectories cur - projName = last dirs - writeFile (projName++".cabal") (cabalFile projName) - createDirectory "src" - writeFile "src/Main.hs" mainFile +data InitFlag = InitBareBones + | InitHelp + deriving (Show, Eq) ------------------------------------------------------------------------------ +initProject :: [String] -> IO () +initProject args = do + case getOpt Permute options args of + (flags, _, []) + | InitHelp `elem` flags -> do putStrLn initUsage + exitFailure + | otherwise -> init' (InitBareBones `elem` flags) + + (_, _, errs) -> do putStrLn $ concat errs + putStrLn initUsage + exitFailure + where + initUsage = unlines + ["Usage:" + ,"" + ," snap init" + ,"" + ," -b --barebones Depend only on -core and -server" + ," -h --help Print this message" + ] + + options = + [ Option ['b'] ["barebones"] (NoArg InitBareBones) + "Depend only on -core and -server" + , Option ['h'] ["help"] (NoArg InitHelp) + "Print this message" + ] + + init' isBareBones = do + cur <- getCurrentDirectory + let dirs = splitDirectories cur + projName = last dirs + writeFile (projName++".cabal") (cabalFile projName isBareBones) + createDirectory "src" + writeFile "src/Main.hs" (mainFile isBareBones) + + +------------------------------------------------------------------------------ main :: IO () main = do args <- getArgs case args of - ["init"] -> initProject - _ -> do putStrLn usage - exitFailure + ("init":args') -> initProject args' + _ -> do putStrLn usage + exitFailure ------------------------------------------------------------------------------ -cabalFile :: String -> String -cabalFile projName = unlines +cabalFile :: String -> Bool -> String +cabalFile projName isBareBones = unlines $ ["Name: "++projName ,"Version: 0.1" ,"Synopsis: Project Synopsis Here" @@ -64,21 +98,20 @@ ," haskell98," ," monads-fd >= 0.1 && <0.2," ," bytestring >= 0.9.1 && <0.10," - ," snap-core >= 0.1 && <0.2," - ," snap-server >= 0.1 && <0.2," - ," heist >= 0.1 && <0.2," - ," filepath >= 1.1 && <1.2" + ," snap-core >= 0.2 && <0.3," + ," snap-server >= 0.3 && <0.3," + ] ++ (if isBareBones then [] else [" heist >= 0.1 && <0.2,"]) ++ + [" filepath >= 1.1 && <1.2" ,"" ," ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-imports" - ,"" - ," Extensions: OverloadedStrings" ] ------------------------------------------------------------------------------ -mainFile :: String -mainFile = unlines - ["module Main where" +mainFile :: Bool -> String +mainFile isBareBones = unlines $ + ["{-# LANGUAGE OverloadedStrings #-}" + ,"module Main where" ,"" ,"import System" ,"import Control.Applicative" @@ -86,8 +119,8 @@ ,"import Snap.Http.Server" ,"import Snap.Types" ,"import Snap.Util.FileServe" - ,"import Text.Templating.Heist" - ,"" + ] ++ (if isBareBones then [] else ["import Text.Templating.Heist"]) ++ + ["" ,"site :: Snap ()" ,"site =" ," ifTop (writeBS \"hello world\") <|>" diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs --- a/src/Snap/Types.hs +++ b/src/Snap/Types.hs @@ -34,6 +34,9 @@ , withRequest , withResponse + -- ** Logging + , logError + -- ** Grabbing request bodies , runRequestBody , getRequestBody diff --git a/test/suite/Snap/Internal/Routing/Tests.hs b/test/suite/Snap/Internal/Routing/Tests.hs --- a/test/suite/Snap/Internal/Routing/Tests.hs +++ b/test/suite/Snap/Internal/Routing/Tests.hs @@ -69,7 +69,7 @@ go :: Snap a -> ByteString -> IO a go m s = do req <- mkRequest s - run $ evalSnap m $ req + run $ evalSnap m (const $ return ()) req routes :: Snap ByteString diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs --- a/test/suite/Snap/Types/Tests.hs +++ b/test/suite/Snap/Types/Tests.hs @@ -91,13 +91,13 @@ go :: Snap a -> IO (Request,Response) go m = do zomgRq <- mkZomgRq - run $ runSnap m zomgRq + run $ runSnap m (const $ return ()) zomgRq goPath :: ByteString -> Snap a -> IO (Request,Response) goPath s m = do rq <- mkRequest s - run $ runSnap m $ rq + run $ runSnap m (const $ return ()) rq goPathQuery :: ByteString @@ -107,13 +107,13 @@ -> IO (Request,Response) goPathQuery s k v m = do rq <- mkRequestQuery s k v - run $ runSnap m $ rq + run $ runSnap m (const $ return ()) rq goBody :: Snap a -> IO (Request,Response) goBody m = do rq <- mkRqWithBody - run $ runSnap m rq + run $ runSnap m (const $ return ()) rq testFail :: Test diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs --- a/test/suite/Snap/Util/FileServe/Tests.hs +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -39,13 +39,13 @@ go :: Snap a -> ByteString -> IO Response go m s = do rq <- mkRequest s - liftM snd (run $ runSnap m rq) + liftM snd (run $ runSnap m (const $ return ()) rq) goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response goIfModifiedSince m s lm = do rq <- mkRequest s let r = setHeader "if-modified-since" lm rq - liftM snd (run $ runSnap m r) + liftM snd (run $ runSnap m (const $ return ()) r) mkRequest :: ByteString -> IO Request diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -87,15 +87,15 @@ goGZip, goCompress, goBad :: Snap a -> IO (Request,Response) goGZip m = do gzipRq <- mkGzipRq - run $ runSnap m gzipRq + run $ runSnap m (const $ return ()) gzipRq goCompress m = do compressRq <- mkCompressRq - run $ runSnap m compressRq + run $ runSnap m (const $ return ()) compressRq goBad m = do badRq <- mkBadRq - run $ runSnap m badRq + run $ runSnap m (const $ return ()) badRq ------------------------------------------------------------------------------ textPlain :: L.ByteString -> Snap ()