snap-core 0.2.6 → 0.2.7
raw patch · 19 files changed
+469/−335 lines, 19 filesdep +ListLike
Dependencies added: ListLike
Files
- CONTRIBUTORS +2/−1
- project_template/barebones/foo.cabal +4/−2
- project_template/barebones/src/Common.hs +0/−59
- project_template/barebones/src/Main.hs +2/−13
- project_template/barebones/src/Server.hs +111/−0
- project_template/default/foo.cabal +3/−3
- project_template/default/src/Common.hs +0/−151
- project_template/default/src/Glue.hs +46/−0
- project_template/default/src/Main.hs +12/−16
- snap-core.cabal +6/−4
- src/Snap/Internal/Http/Types.hs +16/−5
- src/Snap/Internal/Routing.hs +69/−32
- src/Snap/Internal/Types.hs +59/−5
- src/Snap/Iteratee.hs +61/−35
- src/Snap/Types.hs +4/−2
- src/Snap/Util/FileServe.hs +1/−1
- test/snap-core-testsuite.cabal +1/−0
- test/suite/Snap/Internal/Routing/Tests.hs +24/−3
- test/suite/Snap/Iteratee/Tests.hs +48/−3
CONTRIBUTORS view
@@ -1,6 +1,7 @@ Doug Beardsley <mightybyte@gmail.com> Gregory Collins <greg@gregorycollins.net> Shu-yu Guo <shu@rfrn.org>-Carl Howells+Carl Howells <chowells79@gmail.com>+Shane O'Brien <shane@duairc.com> James Sanders <jimmyjazz14@gmail.com> Jacob Stanley <jystic@jystic.com>
project_template/barebones/foo.cabal view
@@ -21,13 +21,15 @@ bytestring >= 0.9.1 && <0.10, snap-core >= 0.2 && <0.3, snap-server >= 0.2 && <0.3,+ xhtml-combinators, unix,+ text, containers, MonadCatchIO-transformers, filepath >= 1.1 && <1.2 if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/barebones/src/Common.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}--module Common where--import Control.Concurrent-import Control.Exception (SomeException)-import Control.Monad-import Control.Monad.CatchIO-import Prelude hiding (catch)-import Snap.Http.Server-import Snap.Types-import Snap.Util.GZip-import System-import System.Posix.Env--setLocaleToUTF8 :: IO ()-setLocaleToUTF8 = do- mapM_ (\k -> setEnv k "en_US.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" ]--data AppConfig = AppConfig {- accessLog :: Maybe FilePath,- errorLog :: Maybe FilePath-}--quickServer :: AppConfig -> Snap () -> IO ()-quickServer config siteHandlers = do- args <- getArgs- port <- case args of- [] -> error "You must specify a port!" >> exitFailure- (port:_) -> return $ read port-- setLocaleToUTF8-- (try $ httpServe "*" port "myserver"- (accessLog config)- (errorLog config)- (withCompression siteHandlers))- :: IO (Either SomeException ())-- threadDelay 1000000- putStrLn "exiting"- return ()-
project_template/barebones/src/Main.hs view
@@ -5,20 +5,10 @@ import Snap.Types import Snap.Util.FileServe -import Common--config :: AppConfig-config = AppConfig {- accessLog = Just "access.log",- errorLog = Just "error.log"-}+import Server main :: IO ()-main = do- quickServer config site--site :: Snap ()-site =+main = quickServer $ ifTop (writeBS "hello world") <|> route [ ("foo", writeBS "bar") , ("echo/:echoparam", echoHandler)@@ -30,4 +20,3 @@ param <- getParam "echoparam" maybe (writeBS "must specify echo/param in URL") writeBS param-
+ project_template/barebones/src/Server.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+module Server+ ( ServerConfig(..)+ , emptyServerConfig+ , commandLineConfig+ , server+ , quickServer+ ) where+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import Data.Char+import Control.Concurrent+import Control.Exception (SomeException)+import Control.Monad.CatchIO+import qualified Data.Text as T+import Prelude hiding (catch)+import Snap.Http.Server+import Snap.Types+import Snap.Util.GZip+import System hiding (getEnv)+import System.Posix.Env+import qualified Text.XHtmlCombinators.Escape as XH+++data ServerConfig = ServerConfig+ { locale :: String+ , interface :: ByteString+ , port :: Int+ , hostname :: ByteString+ , accessLog :: Maybe FilePath+ , errorLog :: Maybe FilePath+ , compression :: Bool+ , error500Handler :: SomeException -> Snap ()+ }+++emptyServerConfig :: ServerConfig+emptyServerConfig = ServerConfig+ { locale = "en_US"+ , interface = "0.0.0.0"+ , port = 8000+ , hostname = "myserver"+ , accessLog = Just "access.log"+ , errorLog = Just "error.log"+ , compression = True+ , error500Handler = \e -> do+ let t = T.pack $ show e+ r = setContentType "text/html; charset=utf-8" $+ setResponseStatus 500 "Internal Server Error" emptyResponse+ putResponse r+ writeBS "<html><head><title>Internal Server Error</title></head>"+ writeBS "<body><h1>Internal Server Error</h1>"+ writeBS "<p>A web handler threw an exception. Details:</p>"+ writeBS "<pre>\n"+ writeText $ XH.escape t+ writeBS "\n</pre></body></html>"+ }+++commandLineConfig :: IO ServerConfig+commandLineConfig = do+ args <- getArgs+ let conf = case args of+ [] -> emptyServerConfig+ (port':_) -> emptyServerConfig { port = read port' }+ locale' <- getEnv "LANG"+ return $ case locale' of+ Nothing -> conf+ Just l -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}++server :: ServerConfig -> Snap () -> IO ()+server config handler = do+ putStrLn $ "Listening on " ++ (B.unpack $ interface config)+ ++ ":" ++ show (port config)+ setUTF8Locale (locale config)+ try $ httpServe+ (interface config)+ (port config)+ (hostname config)+ (accessLog config)+ (errorLog config)+ (catch500 $ compress $ handler)+ :: IO (Either SomeException ())+ threadDelay 1000000+ putStrLn "Shutting down"+ where+ catch500 = (`catch` (error500Handler config))+ compress = if compression config then withCompression else id+++quickServer :: Snap () -> IO ()+quickServer = (commandLineConfig >>=) . flip server+++setUTF8Locale :: String -> IO ()+setUTF8Locale locale' = do+ mapM_ (\k -> setEnv k (locale' ++ ".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" ]
project_template/default/foo.cabal view
@@ -21,7 +21,7 @@ bytestring >= 0.9.1 && <0.10, snap-core >= 0.2 && <0.3, snap-server >= 0.2 && <0.3,- heist >= 0.1 && <0.2,+ heist >= 0.2.2 && <0.3, hexpat == 0.16, xhtml-combinators, unix,@@ -31,7 +31,7 @@ filepath >= 1.1 && <1.2 if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/default/src/Common.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}--module Common where--import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.Maybe-import qualified Data.Text as T-import Control.Applicative-import Control.Concurrent-import Control.Exception (SomeException)-import Control.Monad-import Control.Monad.CatchIO-import Control.Monad.Trans-import Prelude hiding (catch)-import Snap.Http.Server-import Snap.Types-import Snap.Util.FileServe-import Snap.Util.GZip-import System-import System.Posix.Env-import Text.Templating.Heist-import Text.Templating.Heist.Splices.Static-import qualified Text.XHtmlCombinators.Escape as XH---setLocaleToUTF8 :: IO ()-setLocaleToUTF8 = do- mapM_ (\k -> setEnv k "en_US.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" ]------------------------------------------------------------------------------------ General purpose code. This code will eventually get moved into Snap once--- we have a good place to put it.------------------------------------------------------------------------------------------------------------------------------------------------------------------ |-renderTmpl :: MVar (TemplateState Snap)- -> ByteString- -> Snap ()-renderTmpl tsMVar n = do- ts <- liftIO $ readMVar tsMVar- maybe pass writeBS =<< renderTemplate ts n---templateServe :: TemplateState Snap- -> MVar (TemplateState Snap)- -> StaticTagState- -> Snap ()-templateServe orig tsMVar staticState = do- p- modifyResponse $ setContentType "text/html"-- where- p = ifTop (renderTmpl tsMVar "index") <|>- path "admin/reload" (reloadTemplates orig tsMVar staticState) <|>- (renderTmpl tsMVar . B.pack =<< getSafePath)---loadError :: String -> String-loadError str = "Error loading templates\n"++str--reloadTemplates :: TemplateState Snap- -> MVar (TemplateState Snap)- -> StaticTagState- -> Snap ()-reloadTemplates origTs tsMVar staticState = do- liftIO $ clearStaticTagCache staticState- ts <- liftIO $ loadTemplates "templates" origTs- either bad good ts- where- bad msg = do writeBS $ B.pack $ loadError msg ++ "Keeping old templates."- good ts = do liftIO $ modifyMVar_ tsMVar (const $ return ts)- writeBS "Templates loaded successfully"---basicHandlers :: TemplateState Snap- -> MVar (TemplateState Snap)- -> StaticTagState- -> Snap ()- -> Snap ()-basicHandlers origTs tsMVar staticState userHandlers =- catch500 $ withCompression $- userHandlers <|>- templateServe origTs tsMVar staticState---catch500 :: Snap a -> Snap ()-catch500 m = (m >> return ()) `catch` \(e::SomeException) -> do- let t = T.pack $ show e- putResponse r- writeBS "<html><head><title>Internal Server Error</title></head>"- writeBS "<body><h1>Internal Server Error</h1>"- writeBS "<p>A web handler threw an exception. Details:</p>"- writeBS "<pre>\n"- writeText $ XH.escape t- writeBS "\n</pre></body></html>"-- where- r = setContentType "text/html" $- setResponseStatus 500 "Internal Server Error" emptyResponse--data AppConfig = AppConfig {- templateDir :: FilePath,- accessLog :: Maybe FilePath,- errorLog :: Maybe FilePath-}--quickServer :: AppConfig -> Snap () -> IO ()-quickServer config siteHandlers = do- args <- getArgs- port <- case args of- [] -> error "You must specify a port!" >> exitFailure- (port:_) -> return $ read port-- setLocaleToUTF8-- (origTs,staticState) <- bindStaticTag emptyTemplateState-- ets <- loadTemplates (templateDir config) origTs- let ts = either error id ets- either (\s -> putStrLn (loadError s) >> exitFailure) (const $ return ()) ets- tsMVar <- newMVar $ ts-- (try $ httpServe "*" port "myserver"- (accessLog config)- (errorLog config)- (basicHandlers origTs tsMVar staticState siteHandlers))- :: IO (Either SomeException ())-- threadDelay 1000000- putStrLn "exiting"- return ()-
+ project_template/default/src/Glue.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Glue+ ( templateHandler+ , defaultReloadHandler+ , templateServe+ , render+ ) where++import Control.Applicative+import Control.Monad+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Prelude hiding (catch)+import Snap.Types hiding (dir)+import Snap.Util.FileServe+import Text.Templating.Heist+import Text.Templating.Heist.TemplateDirectory+++templateHandler :: TemplateDirectory Snap+ -> (TemplateDirectory Snap -> Snap ())+ -> (TemplateState Snap -> Snap ())+ -> Snap ()+templateHandler td reload f = reload td <|> (f =<< getDirectoryTS td)+++defaultReloadHandler :: TemplateDirectory Snap -> Snap ()+defaultReloadHandler td = path "admin/reload" $ do+ e <- reloadTemplateDirectory td+ modifyResponse $ setContentType "text/plain; charset=utf-8"+ writeBS . B.pack $ either id (const "Templates loaded successfully.") e+++render :: TemplateState Snap -> ByteString -> Snap ()+render ts template = do+ bytes <- renderTemplate ts template+ flip (maybe pass) bytes $ \x -> do+ modifyResponse $ setContentType "text/html; charset=utf-8"+ writeBS x+++templateServe :: TemplateState Snap -> Snap ()+templateServe ts = ifTop (render ts "index") <|> do+ path' <- getSafePath+ when (head path' == '_') pass+ render ts $ B.pack path'
project_template/default/src/Main.hs view
@@ -4,31 +4,27 @@ import Control.Applicative import Snap.Types import Snap.Util.FileServe+import Text.Templating.Heist+import Text.Templating.Heist.TemplateDirectory -import Common+import Glue+import Server -config :: AppConfig-config = AppConfig {- templateDir = "templates",- accessLog = Just "access.log",- errorLog = Just "error.log"-} main :: IO () main = do- quickServer config site+ td <- newTemplateDirectory' "templates" emptyTemplateState+ quickServer $ templateHandler td defaultReloadHandler $ \ts ->+ ifTop (writeBS "hello world") <|>+ route [ ("foo", writeBS "bar")+ , ("echo/:echoparam", echoHandler)+ ] <|>+ templateServe ts <|>+ dir "static" (fileServe ".") -site :: Snap ()-site =- ifTop (writeBS "hello world") <|>- route [ ("foo", writeBS "bar")- , ("echo/:echoparam", echoHandler)- ] <|>- dir "static" (fileServe ".") echoHandler :: Snap () echoHandler = do param <- getParam "echoparam" maybe (writeBS "must specify echo/param in URL") writeBS param-
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.6+version: 0.2.7 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -74,11 +74,12 @@ haddock.sh, LICENSE, project_template/barebones/foo.cabal,- project_template/barebones/src/Common.hs, project_template/barebones/src/Main.hs,+ project_template/barebones/src/Server.hs, project_template/default/foo.cabal,- project_template/default/src/Common.hs,+ project_template/default/src/Glue.hs, project_template/default/src/Main.hs,+ project_template/barebones/src/Server.hs, README.md, README.SNAP.md, Setup.hs,@@ -151,7 +152,8 @@ directory, dlist >= 0.5 && < 0.6, filepath,- iteratee >= 0.3.1 && <0.4,+ iteratee >= 0.3.1 && < 0.4,+ ListLike >= 1 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, monads-fd, old-locale,
src/Snap/Internal/Http/Types.hs view
@@ -22,6 +22,7 @@ import Data.Attoparsec hiding (many, Result(..)) import Data.Bits import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w,w2c) import qualified Data.ByteString.Nums.Careless.Hex as Cvt import qualified Data.ByteString as S@@ -29,7 +30,9 @@ import Data.Char import Data.DList (DList) import qualified Data.DList as DL+import Data.Int import Data.IORef+import Data.List hiding (take) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid@@ -290,7 +293,9 @@ ] beginheaders = "Headers:\n ========================================" endheaders = " ========================================"- hdrs = " " ++ show (rqHeaders r)+ hdrs' (a,b) = (B.unpack $ unCI a) ++ ": " ++ (show (map B.unpack b))+ hdrs = " " ++ (concat $ intersperse "\n " $+ map hdrs' (Map.toAscList $ rqHeaders r)) contentlength = concat [ "content-length: " , show $ rqContentLength r ]@@ -300,18 +305,24 @@ version = concat [ "version: " , show $ rqVersion r ]+ cookies' = " " ++ (concat $ intersperse "\n " $+ map show $ rqCookies r) cookies = concat [ "cookies:\n" , " ========================================\n"- , " " ++ (show $ rqCookies r)+ , cookies' , "\n ========================================" ] pathinfo = concat [ "pathinfo: ", toStr $ rqPathInfo r ] contextpath = concat [ "contextpath: ", toStr $ rqContextPath r ] snapletpath = concat [ "snapletpath: ", toStr $ rqSnapletPath r ] uri = concat [ "URI: ", toStr $ rqURI r ]+ params' = " " +++ (concat $ intersperse "\n " $+ map (\ (a,b) -> B.unpack a ++ ": " ++ show b) $+ Map.toAscList $ rqParams r) params = concat [ "params:\n" , " ========================================\n"- , " " ++ (show $ rqParams r)+ , params' , "\n ========================================" ] @@ -357,7 +368,7 @@ -- | We will need to inspect the content length no matter what, and -- looking up \"content-length\" in the headers and parsing the number -- out of the text will be too expensive.- , rspContentLength :: !(Maybe Int)+ , rspContentLength :: !(Maybe Int64) , rspBody :: ResponseBody -- | Returns the HTTP status code.@@ -501,7 +512,7 @@ -- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For HTTP\/1.1 -- clients, Snap will switch to the chunked transfer encoding if -- @Content-Length@ is not specified.-setContentLength :: Int -> Response -> Response+setContentLength :: Int64 -> Response -> Response setContentLength l r = r { rspContentLength = Just l } {-# INLINE setContentLength #-}
src/Snap/Internal/Routing.hs view
@@ -44,20 +44,32 @@ instance Monoid (Route a) where mempty = NoRoute - -- Unions two routes, favoring the right-hand side mappend NoRoute r = r - mappend l@(Action _) r = case r of- (Action _) -> r+ mappend l@(Action a) r = case r of+ (Action a') -> Action (a <|> a') (Capture p r' fb) -> Capture p r' (mappend fb l) (Dir _ _) -> mappend (Dir Map.empty l) r NoRoute -> l + -- Whenever we're unioning two Captures and their capture variables+ -- differ, we have an ambiguity. We resolve this in the following order:+ -- 1. Prefer whichever route is longer+ -- 2. Else, prefer whichever has the earliest non-capture+ -- 3. Else, prefer the right-hand side mappend l@(Capture p r' fb) r = case r of (Action _) -> Capture p r' (mappend fb r) (Capture p' r'' fb')- | p == p' -> Capture p (mappend r' r'') (mappend fb fb')- | otherwise -> r+ | p == p' -> Capture p (mappend r' r'') (mappend fb fb')+ | rh' > rh'' -> Capture p r' (mappend fb r)+ | rh' < rh'' -> Capture p' r'' (mappend fb' l)+ | en' < en'' -> Capture p r' (mappend fb r)+ | otherwise -> Capture p' r'' (mappend fb' l)+ where+ rh' = routeHeight r'+ rh'' = routeHeight r''+ en' = routeEarliestNC r' 1+ en'' = routeEarliestNC r'' 1 (Dir rm fb') -> Dir rm (mappend fb' l) NoRoute -> l @@ -69,6 +81,22 @@ ------------------------------------------------------------------------------+routeHeight :: Route a -> Int+routeHeight r = case r of+ NoRoute -> 1+ (Action _) -> 1+ (Capture _ r' _) -> 1+routeHeight r'+ (Dir rm _) -> 1+foldl max 1 (map routeHeight $ Map.elems rm)++routeEarliestNC :: Route a -> Int -> Int+routeEarliestNC r n = case r of+ NoRoute -> n+ (Action _) -> n+ (Capture _ r' _) -> routeEarliestNC r' n+1+ (Dir _ _) -> n+++------------------------------------------------------------------------------ -- | A web handler which, given a mapping from URL entry points to web -- handlers, efficiently routes requests to the correct handler. --@@ -118,30 +146,36 @@ -- > , ("login", method POST doLogin) ] -- route :: [(ByteString, Snap a)] -> Snap a-route rts = route' (return ()) rts' []+route rts = do+ p <- getRequest >>= return . rqPathInfo+ route' (return ()) ([], splitPath p) Map.empty rts' where rts' = mconcat (map pRoute rts) --------------------------------------------------------------------------------- | The 'routeLocal' function is the same as 'route', except it doesn't change+-- | The 'routeLocal' function is the same as 'route'', except it doesn't change -- the request's context path. This is useful if you want to route to a -- particular handler but you want that handler to receive the 'rqPathInfo' as -- it is. routeLocal :: [(ByteString, Snap a)] -> Snap a-routeLocal rts' = do+routeLocal rts = do req <- getRequest let ctx = rqContextPath req let p = rqPathInfo req let md = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p} - route' md rts [] <|> (md >> pass)+ (route' md ([], splitPath p) Map.empty rts') <|> (md >> pass) where- rts = mconcat (map pRoute rts')+ rts' = mconcat (map pRoute rts) - ------------------------------------------------------------------------------+splitPath :: ByteString -> [ByteString]+splitPath = B.splitWith (== (c2w '/'))+++------------------------------------------------------------------------------ pRoute :: (ByteString, Snap a) -> Route a pRoute (r, a) = foldr f (Action a) hier where@@ -152,30 +186,33 @@ -------------------------------------------------------------------------------route' :: Snap () -- ^ an action to be run before any user- -- handler- -> Route a -- ^ currently active routing table- -> [Route a] -- ^ list of fallback routing tables in case- -- the current table fails+route' :: Snap ()+ -> ([ByteString], [ByteString])+ -> Params+ -> Route a -> Snap a-route' pre (Action action) _ = pre >> action+route' pre (ctx, _) params (Action action) =+ localRequest (updateContextPath (B.length ctx') . updateParams)+ (pre >> action)+ where+ ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx)+ updateParams req = req+ { rqParams = Map.unionWith (++) params (rqParams req) } -route' pre (Capture param rt fb) fbs = do- cwd <- getRequest >>= return . B.takeWhile (/= (c2w '/')) . rqPathInfo- if B.null cwd- then route' pre fb fbs- else do localRequest (updateContextPath (B.length cwd) . (f cwd)) $- route' pre rt (fb:fbs)+route' pre (ctx, []) params (Capture _ _ fb) =+ route' pre (ctx, []) params fb+route' pre (ctx, cwd:rest) params (Capture p rt fb) =+ (route' pre (cwd:ctx, rest) params' rt) <|>+ (route' pre (ctx, cwd:rest) params fb) where- f v req = req { rqParams = Map.insertWith (++) param [v] (rqParams req) }+ params' = Map.insertWith (++) p [cwd] params -route' pre (Dir rtm fb) fbs = do- cwd <- getRequest >>= return . B.takeWhile (/= (c2w '/')) . rqPathInfo+route' pre (ctx, []) params (Dir _ fb) =+ route' pre (ctx, []) params fb+route' pre (ctx, cwd:rest) params (Dir rtm fb) = case Map.lookup cwd rtm of- Just rt -> do- localRequest (updateContextPath (B.length cwd)) $- route' pre rt (fb:fbs)- Nothing -> route' pre fb fbs+ Just rt -> (route' pre (cwd:ctx, rest) params rt) <|>+ (route' pre (ctx, cwd:rest) params fb)+ Nothing -> route' pre (ctx, cwd:rest) params fb -route' _ NoRoute [] = pass-route' pre NoRoute (fb:fbs) = route' pre fb fbs+route' _ _ _ NoRoute = pass
src/Snap/Internal/Types.hs view
@@ -13,6 +13,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.CIByteString as CIB import Data.IORef import qualified Data.Iteratee as Iter import Data.Maybe@@ -84,7 +85,7 @@ ------------------------------------------------------------------------------ newtype Snap a = Snap { unSnap :: StateT SnapState (Iteratee IO) (Maybe (Either Response a))-} deriving Typeable+} ------------------------------------------------------------------------------@@ -151,7 +152,17 @@ empty = mzero (<|>) = mplus +------------------------------------------------------------------------------+-- | The Typeable instance is here so Snap can be dynamically executed with+-- Hint.+snapTyCon :: TyCon+snapTyCon = mkTyCon "Snap.Types.Snap"+{-# NOINLINE snapTyCon #-} +instance Typeable1 Snap where+ typeOf1 _ = mkTyConApp snapTyCon []++ ------------------------------------------------------------------------------ liftIter :: Iteratee IO a -> Snap a liftIter i = Snap (lift i >>= return . Just . Right)@@ -192,7 +203,7 @@ -- returns it. You would want to use this if you needed to send the -- HTTP request body (transformed or otherwise) through to the output -- in O(1) space. (Examples: transcoding, \"echo\", etc)--- +-- -- Normally Snap is careful to ensure that the request body is fully -- consumed after your web handler runs; this function is marked -- \"unsafe\" because it breaks this guarantee and leaves the@@ -352,7 +363,7 @@ ------------------------------------------------------------------------------ -- | Modifes the 'Response' object stored in a 'Snap' monad.-modifyResponse :: (Response -> Response) -> Snap () +modifyResponse :: (Response -> Response) -> Snap () modifyResponse f = smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss } {-# INLINE modifyResponse #-} @@ -449,6 +460,49 @@ ------------------------------------------------------------------------------+-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'+-- field to the value in the X-Forwarded-For header. If the header is+-- not present, this action has no effect.+--+-- This action should be used only when working behind a reverse http+-- proxy that sets the X-Forwarded-For header. This is the only way to+-- ensure the value in the X-Forwarded-For header can be trusted.+--+-- This is provided as a filter so actions that require the remote+-- address can get it in a uniform manner. It has specifically limited+-- functionality to ensure that its transformation can be trusted,+-- when used correctly.+ipHeaderFilter :: Snap ()+ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"+++------------------------------------------------------------------------------+-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'+-- field to the value from the header specified. If the header+-- specified is not present, this action has no effect.+--+-- This action should be used only when working behind a reverse http+-- proxy that sets the header being looked at. This is the only way to+-- ensure the value in the header can be trusted.+--+-- This is provided as a filter so actions that require the remote+-- address can get it in a uniform manner. It has specifically limited+-- functionality to ensure that its transformation can be trusted,+-- when used correctly.+ipHeaderFilter' :: CIB.CIByteString -> Snap ()+ipHeaderFilter' header = do+ headerContents <- getHeader header <$> getRequest++ let whitespace = " \t\r\n"+ ipChrs = ".0123456789"+ trim f s = f (`elem` s)++ clean = trim S.takeWhile ipChrs . trim S.dropWhile whitespace+ setIP ip = modifyRequest $ \rq -> rq { rqRemoteAddr = clean ip }+ maybe (return ()) setIP headerContents+++------------------------------------------------------------------------------ -- | This exception is thrown if the handler you supply to 'runSnap' fails. data NoHandlerException = NoHandlerException deriving (Eq, Typeable)@@ -477,7 +531,7 @@ r -- is this a case of early termination?- let resp = case e of + let resp = case e of Left x -> x Right _ -> _snapResponse ss' @@ -508,7 +562,7 @@ r -- is this a case of early termination?- case e of + case e of Left _ -> liftIO $ throwIO $ ErrorCall "no value" Right x -> return x where
src/Snap/Iteratee.hs view
@@ -33,6 +33,7 @@ , toWrap -- ** Iteratee utilities+ , drop' , takeExactly , takeNoMoreThan , countBytes@@ -49,6 +50,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Lazy as L+import Data.Int import Data.IORef import Data.Iteratee #ifdef PORTABLE@@ -56,6 +58,7 @@ #endif import qualified Data.Iteratee.Base.StreamChunk as SC import Data.Iteratee.WrappedByteString+import qualified Data.ListLike as LL import Data.Monoid (mappend) import Foreign import Foreign.C.Types@@ -96,7 +99,7 @@ ------------------------------------------------------------------------------ -- | Wraps an 'Iteratee', counting the number of bytes consumed by it.-countBytes :: (Monad m) => Iteratee m a -> Iteratee m (a, Int)+countBytes :: (Monad m) => Iteratee m a -> Iteratee m (a, Int64) countBytes = go 0 where go !n iter = IterateeG $ f n iter@@ -108,10 +111,10 @@ in return $! Done (x, n') rest Cont i err -> return $ Cont ((go $! n + m) i) err where- m = S.length $ unWrap ws+ m = fromIntegral $ S.length (unWrap ws) - len (EOF _) = 0- len (Chunk s) = S.length $ unWrap s+ len (EOF _) = 0+ len (Chunk s) = fromIntegral $ S.length (unWrap s) f !n !iter stream = do iterv <- runIter iter stream@@ -126,6 +129,11 @@ -- Our enumerators produce a lot of little strings; rather than spending all -- our time doing kernel context switches for 4-byte write() calls, we buffer -- the iteratee to send 8KB at a time.+--+-- The IORef returned can be set to True to "cancel" buffering. We added this+-- so that transfer-encoding: chunked (which needs its own buffer and therefore+-- doesn't need /its/ output buffered) can switch the outer buffer off.+-- bufferIteratee :: Iteratee IO a -> IO (Iteratee IO a, IORef Bool) bufferIteratee iteratee = do esc <- newIORef False@@ -146,18 +154,18 @@ go (!dl,!n) iter = IterateeG $! f (dl,n) iter --f :: (DList ByteString, Int) -> Iteratee m a -> Stream -> m (IterV m a)- f _ !iter ch@(EOF (Just _)) = runIter iter ch- f (!dl,_) !iter ch@(EOF Nothing) = do- iterv <- runIter iter $ Chunk big- case iterv of- Done x rest -> return $ Done x rest- Cont i (Just e) -> return $ Cont i (Just e)- Cont i Nothing -> runIter i ch+ f _ !iter ch@(EOF (Just _)) = runIter iter ch+ f (!dl,_) !iter ch@(EOF Nothing) = do+ iter' <- if S.null str+ then return iter+ else liftM liftI $ runIter iter $ Chunk big+ runIter iter' ch where- big = toWrap $ L.fromChunks [S.concat $ D.toList dl]+ str = S.concat $ D.toList dl+ big = WrapBS str f (!dl,!n) iter (Chunk (WrapBS s)) =- if n' > blocksize+ if n' >= blocksize then do iterv <- runIter iter (Chunk big) case iterv of@@ -169,7 +177,7 @@ m = S.length s n' = n+m dl' = D.snoc dl s- big = toWrap $ L.fromChunks [S.concat $ D.toList dl']+ big = WrapBS $ S.concat $ D.toList dl' bUFSIZ :: Int@@ -244,11 +252,8 @@ if n == 0 then runIter iter ch else do- iterv <- sendBuf n iter- case iterv of- Done x rest -> return $ Done x $ copy rest- Cont i (Just e) -> return $ Cont i (Just e)- Cont i Nothing -> runIter i ch+ iter' <- liftM liftI $ sendBuf n iter+ runIter iter' ch f !n iter (Chunk (WrapBS s)) = do let m = S.length s@@ -330,12 +335,29 @@ ------------------------------------------------------------------------------+-- | Skip n elements of the stream, if there are that many+-- This is the Int64 version of the drop function in the iteratee library+drop' :: (SC.StreamChunk s el, Monad m)+ => Int64+ -> IterateeG s el m ()+drop' 0 = return ()+drop' n = IterateeG step+ where+ step (Chunk str)+ | strlen <= n = return $ Cont (drop' (n - strlen)) Nothing+ where+ strlen = fromIntegral $ SC.length str+ step (Chunk str) = return $ Done () (Chunk (LL.drop (fromIntegral n) str))+ step stream = return $ Done () stream+++------------------------------------------------------------------------------ -- | Reads n elements from a stream and applies the given iteratee to -- the stream of the read elements. Reads exactly n elements, and if -- the stream is short propagates an error.-takeExactly :: (SC.StreamChunk s el, Monad m) =>- Int ->- EnumeratorN s el s el m a+takeExactly :: (SC.StreamChunk s el, Monad m)+ => Int64+ -> EnumeratorN s el s el m a takeExactly 0 iter = return iter takeExactly n' iter = if n' < 0@@ -344,15 +366,17 @@ where step n chk@(Chunk str) | SC.null str = return $ Cont (takeExactly n iter) Nothing- | SC.length str < n = liftM (flip Cont Nothing) inner- where inner = liftM (check (n - SC.length str)) (runIter iter chk)- step n (Chunk str) = done (Chunk s1) (Chunk s2)- where (s1, s2) = SC.splitAt n str+ | strlen < n = liftM (flip Cont Nothing) inner+ | otherwise = done (Chunk s1) (Chunk s2)+ where+ strlen = fromIntegral $ SC.length str+ inner = liftM (check (n - strlen)) (runIter iter chk)+ (s1, s2) = SC.splitAt (fromIntegral n) str step _n (EOF (Just e)) = return $ Cont undefined (Just e) step _n (EOF Nothing) = return $ Cont undefined (Just (Err "short write"))- check n (Done x _) = drop n >> return (return x)+ check n (Done x _) = drop' n >> return (return x) check n (Cont x Nothing) = takeExactly n x- check n (Cont _ (Just e)) = drop n >> throwErr e+ check n (Cont _ (Just e)) = drop' n >> throwErr e done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return) @@ -360,9 +384,9 @@ -- | Reads up to n elements from a stream and applies the given iteratee to the -- stream of the read elements. If more than n elements are read, propagates an -- error.-takeNoMoreThan :: (SC.StreamChunk s el, Monad m) =>- Int ->- EnumeratorN s el s el m a+takeNoMoreThan :: (SC.StreamChunk s el, Monad m)+ => Int64+ -> EnumeratorN s el s el m a takeNoMoreThan n' iter = if n' < 0 then takeNoMoreThan 0 iter@@ -370,10 +394,12 @@ where step n chk@(Chunk str) | SC.null str = return $ Cont (takeNoMoreThan n iter) Nothing- | SC.length str < n = liftM (flip Cont Nothing) inner- | otherwise = done (Chunk s1) (Chunk s2)- where inner = liftM (check (n - SC.length str)) (runIter iter chk)- (s1, s2) = SC.splitAt n str+ | strlen < n = liftM (flip Cont Nothing) inner+ | otherwise = done (Chunk s1) (Chunk s2)+ where+ strlen = fromIntegral $ SC.length str+ inner = liftM (check (n - strlen)) (runIter iter chk)+ (s1, s2) = SC.splitAt (fromIntegral n) str step _n (EOF (Just e)) = return $ Cont undefined (Just e) step _n chk@(EOF Nothing) = do
src/Snap/Types.hs view
@@ -5,7 +5,7 @@ -} module Snap.Types- ( + ( -- * The Snap Monad Snap , runSnap@@ -57,6 +57,8 @@ , addHeader , setHeader , getHeader+ , ipHeaderFilter+ , ipHeaderFilter' -- ** Requests , rqServerName@@ -105,7 +107,7 @@ -- * HTTP utilities , formatHttpTime- , parseHttpTime + , parseHttpTime , urlEncode , urlDecode ) where
src/Snap/Util/FileServe.hs view
@@ -229,7 +229,7 @@ let mt = modificationTime filestat maybe (return ()) (chkModificationTime mt) mbIfModified - let sz = fromEnum $ fileSize filestat+ let sz = fromIntegral $ fileSize filestat lm <- liftIO $ formatHttpTime mt modifyResponse $ setHeader "Last-Modified" lm
test/snap-core-testsuite.cabal view
@@ -47,6 +47,7 @@ filepath, HUnit >= 1.2 && < 2, iteratee >= 0.3.1 && < 0.4,+ ListLike >= 1 && < 2, MonadCatchIO-transformers >= 0.2 && < 0.3, monads-fd, old-locale,
test/suite/Snap/Internal/Routing/Tests.hs view
@@ -48,6 +48,9 @@ , testRouting23 , testRouting24 , testRouting25+ , testRouting26+ , testRouting27+ , testRouting28 , testRouteLocal ] expectException :: IO a -> IO ()@@ -95,8 +98,10 @@ , ("" , topTop ) ] routes4 :: Snap ByteString-routes4 = route [ (":foo" , pass )- , (":foo" , topCapture ) ]+routes4 = route [ (":foo" , pass )+ , (":foo" , topCapture )+ , (":qqq/:id" , fooCapture )+ , (":id2/baz" , fooCapture2 ) ] routes5 :: Snap ByteString routes5 = route [ ("" , pass )@@ -148,12 +153,13 @@ barQuux = return "barQuux" bar = return "bar" +-- TODO more useful test names+ testRouting1 :: Test testRouting1 = testCase "routing1" $ do r1 <- go routes "foo" assertEqual "/foo" "topFoo" r1 - testRouting2 :: Test testRouting2 = testCase "routing2" $ do r2 <- go routes "foo/baz"@@ -272,6 +278,21 @@ testRouting25 = testCase "routing25" $ do r1 <- go routes7 "foooo/bar/baz" assertEqual "/foooo/bar/baz" "bar" r1++testRouting26 :: Test+testRouting26 = testCase "routing26" $ do+ r1 <- go routes4 "foo/bar"+ assertEqual "capture union" "bar" r1++testRouting27 :: Test+testRouting27 = testCase "routing27" $ do+ r1 <- go routes4 "foo"+ assertEqual "capture union" "foo" r1++testRouting28 :: Test+testRouting28 = testCase "routing28" $ do+ r1 <- go routes4 "quux/baz"+ assertEqual "capture union" "quux" r1 testRouteLocal :: Test testRouteLocal = testCase "routeLocal" $ do
test/suite/Snap/Iteratee/Tests.hs view
@@ -12,6 +12,8 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Monoid+import Data.Int+import Data.IORef import Data.Iteratee.WrappedByteString import Data.Word import Prelude hiding (drop, take)@@ -27,6 +29,10 @@ import Snap.Iteratee import Snap.Test.Common () +instance Arbitrary Int64 where+ arbitrary = arbitraryBoundedIntegral+ shrink = shrinkIntegral+ liftQ :: forall a m . (Monad m) => m a -> PropertyM m a liftQ = QC.run @@ -45,6 +51,8 @@ , testBuffer2 , testBuffer3 , testBuffer4+ , testBufferChain+ , testBufferChainEscape , testUnsafeBuffer , testUnsafeBuffer2 , testUnsafeBuffer3@@ -136,6 +144,43 @@ expectException $ run k +testBufferChain :: Test+testBufferChain = testProperty "testBufferChain" $+ monadicIO $ forAllM arbitrary prop+ where+ prop s = do+ pre (s /= L.empty)++ (j,_) <- liftQ $ bufferIteratee stream2stream+ (i,_) <- liftQ $ bufferIteratee j+ iter <- liftQ $ enumLBS s' i+ x <- liftQ $ run iter++ QC.assert $ fromWrap x == s'+ where+ s' = L.take 20000 $ L.cycle s+++testBufferChainEscape :: Test+testBufferChainEscape = testProperty "testBufferChainEscape" $+ monadicIO $ forAllM arbitrary prop+ where+ prop s = do+ pre (s /= L.empty)++ (j,esc) <- liftQ $ bufferIteratee stream2stream+ (i,_) <- liftQ $ bufferIteratee j++ liftQ $ writeIORef esc True++ iter <- liftQ $ enumLBS s' i+ x <- liftQ $ run iter++ QC.assert $ fromWrap x == s'+ where+ s' = L.take 20000 $ L.cycle s++ copyingStream2stream :: Iteratee IO (WrappedByteString Word8) copyingStream2stream = IterateeG (step mempty) where@@ -302,7 +347,7 @@ testTakeNoMoreThan3 = testProperty "takeNoMoreLong" $ monadicIO $ forAllM arbitrary prop where- prop :: (Int,L.ByteString) -> PropertyM IO ()+ prop :: (Int64,L.ByteString) -> PropertyM IO () prop (m,s) = do v <- liftQ $ enumLBS "" (joinI (takeNoMoreThan 0 stream2stream)) >>= run assert $ fromWrap v == ""@@ -316,7 +361,7 @@ where doIter = enumLBS s (joinI (takeNoMoreThan (n-abs m) stream2stream))- n = fromIntegral $ L.length s+ n = L.length s testCountBytes :: Test@@ -339,7 +384,7 @@ erriter = countBytes $ throwErr $ Err "foo" g iter = enumLBS s iter >>= run f = liftQ . g- n = fromEnum $ L.length s+ n = L.length s testCountBytes2 :: Test