packages feed

snap-core 0.1.2 → 0.2.1

raw patch · 13 files changed

+104/−53 lines, 13 files

Files

README.SNAP.md view
@@ -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
README.md view
@@ -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
extra/haddock.css view
@@ -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;
snap-core.cabal view
@@ -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
src/Data/CIByteString.hs view
@@ -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
src/Snap/Internal/Routing.hs view
@@ -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
src/Snap/Internal/Types.hs view
@@ -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 #-}
src/Snap/Starter.hs view
@@ -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\") <|>"
src/Snap/Types.hs view
@@ -34,6 +34,9 @@   , withRequest   , withResponse +    -- ** Logging+  , logError+     -- ** Grabbing request bodies   , runRequestBody   , getRequestBody
test/suite/Snap/Internal/Routing/Tests.hs view
@@ -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
test/suite/Snap/Types/Tests.hs view
@@ -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
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -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
test/suite/Snap/Util/GZip/Tests.hs view
@@ -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 ()