iterio-server 0.2 → 0.3

raw patch · 8 files changed

+377/−137 lines, 8 filesdep +filepathdep +unixdep ~iterIOPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, unix

Dependency ranges changed: iterIO

API changes (from Hackage documentation)

Files

• Data/IterIO/Http/Support.hs +6/−0
• Data/IterIO/Http/Support/Action.hs +55/−80
• Data/IterIO/Http/Support/Responses.hs +29/−16
• Data/IterIO/Http/Support/RestController.hs +22/−17
• Data/IterIO/Http/Support/Routing.hs +215/−11
• Data/IterIO/Http/Support/Utils.hs +31/−0
• Examples/BasicSite.hs +14/−11
• iterio-server.cabal +5/−2

@@ -1,10 +1,16 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif module Data.IterIO.Http.Support ( module Data.IterIO.Http.Support.Action                                 , module Data.IterIO.Http.Support.Responses                                 , module Data.IterIO.Http.Support.RestController                                 , module Data.IterIO.Http.Support.Routing+                                , module Data.IterIO.Http.Support.Utils                                 )where  import Data.IterIO.Http.Support.Action import Data.IterIO.Http.Support.Responses import Data.IterIO.Http.Support.RestController import Data.IterIO.Http.Support.Routing+import Data.IterIO.Http.Support.Utils

@@ -1,125 +1,100 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif -- |Defines the 'Action' monad which abstracts some of the details of handling -- HTTP requests with IterIO. module Data.IterIO.Http.Support.Action (     Action+  , ActionState(..)   , Param(..)-  , routeAction-  , routeActionPattern-  , params-  , param+  , params, param, paramVal, paramValM+  , setParams+  , getBody   , getHttpReq-  , setSession-  , destroySession+  , setSession, destroySession   , requestHeader ) where -import Control.Monad.Trans+import Control.Monad import Control.Monad.Trans.State import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L-import Data.List-import Data.List.Split-import Data.IterIO import Data.IterIO.Http-import Data.IterIO.HttpRoute+import Data.List (find)  -- | A request parameter from a form field in the HTTP body data Param = Param {     paramKey :: S.ByteString   , paramValue :: L.ByteString   , paramHeaders :: [(S.ByteString, S.ByteString)] -- ^ Header of a @multipart/form-data@ post+} deriving (Show)++data ActionState t b m = ActionState {+    actionReq  :: HttpReq t+  , actionResp :: HttpResp m+  , actionParams   :: [Param]+  , actionBody :: b }  -- | A 'StateT' monad in which requests can be handled. It keeps track of the -- 'HttpReq', the form parameters from the request body and an 'HttpResp' used -- to reply to the client.-type Action t m a = StateT (HttpReq t, HttpResp m, [Param]) m a---- | Routes an 'Action'-routeAction :: Monad m => Action t m () -> HttpRoute m t-routeAction action = routeFn $ runAction action---- | Routes an 'Action' to the given URL pattern. Patterns can include--- directories as well as variable patterns (prefixed with @:@) to be passed--- into the 'Action' as extra 'Param's. Some examples of URL patters:------  * \/posts\/:id------  * \/posts\/:id\/new------  * \/:date\/posts\/:category\/new----routeActionPattern :: Monad m => String -> Action t m () -> HttpRoute m t-routeActionPattern pattern action = foldl' addVar (routeFn $ runActionWithRouteNames patternList action) patternList-  where patternList = reverse $ filter ((/= 0) . length) $ splitOn "/" pattern-        addVar rt (':':_) = routeVar rt-        addVar rt name = routeName name rt+type Action t b m a = StateT (ActionState t b m) m a  -- |Sets a the value for \"_sess\" in the cookie to the given string.-setSession :: Monad m => String -> Action t m ()-setSession cookie = StateT $ \(req, resp, prm) ->-  let cookieHeader = S.pack $ "Set-Cookie: _sess=" ++ cookie ++ "; path=/;"-  in return $ ((), (req, resp { respHeaders = cookieHeader:(respHeaders resp)}, prm))+setSession :: Monad m => String -> Action t b m ()+setSession cookie = modify $ \s ->+  let cookieHeader = (S.pack "Set-Cookie", S.pack $ "_sess=" ++ cookie ++ "; path=/;")+  in s { actionResp = respAddHeader cookieHeader (actionResp s)}  -- |Removes the \"_sess\" key-value pair from the cookie.-destroySession :: Monad m => Action t m ()-destroySession = StateT $ \(req, resp, prm) ->-  let cookieHeader = S.pack $ "Set-Cookie: _sess=; path=/; expires=Thu, Jan 01 1970 00:00:00 UTC;"-  in return $ ((), (req, resp { respHeaders = cookieHeader:(respHeaders resp)}, prm))+destroySession :: Monad m => Action t b m ()+destroySession = modify $ \s ->+  let cookieHeader = (S.pack "Set-Cookie", S.pack "_sess=; path=/; expires=Thu, Jan 01 1970 00:00:00 UTC;")+  in s { actionResp = respAddHeader cookieHeader (actionResp s)}  -- |Returns the value of an Http Header from the request if it exists otherwise -- 'Nothing'-requestHeader :: Monad m => S.ByteString -> Action t m (Maybe S.ByteString)+requestHeader :: Monad m => S.ByteString -> Action t b m (Maybe S.ByteString) requestHeader name = do   httpReq <- getHttpReq   return $ lookup name (reqHeaders httpReq)  -- |Returns the 'HttpReq' for the current request.-getHttpReq :: Monad m => Action t m (HttpReq t)-getHttpReq = StateT $ \(req, resp, prm) -> return $ (req, (req, resp, prm))+getHttpReq :: Monad m => Action t b m (HttpReq t)+getHttpReq = gets actionReq +-- |Returns the body of the current request.+getBody :: Monad m => Action t b m b+getBody = gets actionBody++-- | Set the list of 'Param's.+setParams :: Monad m => [Param] -> Action t b m [Param]+setParams prms = do+  modify $ \s -> s { actionParams = prms }+  return prms+ -- | Returns a list of all 'Param's.-params :: Monad m => Action t m ([Param])-params = StateT $ \s@(_, _, prm) -> return (prm, s)+params :: Monad m => Action t b m [Param]+params = do+  gets actionParams  -- | Returns the 'Param' corresponding to the specified key or 'Nothing' -- if one is not present in the request.-param :: Monad m => S.ByteString -> Action t m (Maybe Param)-param key = do-  prms <- params-  return $ foldl go Nothing prms-  where go Nothing p = if paramKey p == key then Just p else Nothing-        go a _ = a---runAction :: Monad m-              => Action s m ()-              -> HttpReq s-              -> Iter L.ByteString m (HttpResp m)-runAction = runActionWithRouteNames []--runActionWithRouteNames :: Monad m-              => [String]-              -> Action s m ()-              -> HttpReq s-              -> Iter L.ByteString m (HttpResp m)-runActionWithRouteNames routeNames action req = do-  prms <- paramList req-  let pathLstParams = pathLstToParams req routeNames-  (_, (_, response, _)) <- lift $ (runStateT action) (req, mkHttpHead stat200, pathLstParams ++ prms)-  return $ response+param :: Monad m => S.ByteString -> Action t b m (Maybe Param)+param key = find ((== key) . paramKey) `liftM` params +-- | Force get parameter value+paramVal :: Monad m => S.ByteString -> Action t b m (L.ByteString)+paramVal n = param n >>=+  maybe (fail "No such parameter") (return . paramValue) -pathLstToParams :: HttpReq s -> [String] -> [Param]-pathLstToParams req routeNames = result-  where (result, _) = foldl go ([], reqPathParams req) routeNames-        go (prms, plst) (':':var) = ((transform var $ head plst):prms, tail plst)-        go s _ = s-        transform k v = Param (S.pack k) (L.fromChunks [v]) []+-- | Get (maybe) paramater value and transform it with @f@+paramValM :: Monad m+          => (L.ByteString -> a)+          -> S.ByteString+          -> Action t b m (Maybe a)+paramValM f n = fmap (f . paramValue) `liftM` param n -paramList :: Monad m => HttpReq s -> Iter L.ByteString m [Param]-paramList req = foldForm req handle []-  where handle accm field = do-          val <- pureI-          return $ (Param (ffName field) val (ffHeaders field)):accm 

@@ -1,7 +1,12 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif -- |Utility functions for responding to HTTP requests from within an 'Action'. module Data.IterIO.Http.Support.Responses (     render   , redirectTo+  , redirectBack   , respond404   , respondStat ) where@@ -10,36 +15,44 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.IterIO-import Data.IterIO.Http.Support.Action (Action)+import Data.IterIO.Http.Support.Action (Action, ActionState(..), requestHeader) import Data.IterIO.Http  -- | Responds to the client with an empty @404@ (Not Found) response.-respond404 :: Monad m => Action t m ()-respond404 = StateT $-  \(req, _, params) -> return $ ((), (req, resp404 req, params))+respond404 :: Monad m => Action t b m ()+respond404 = modify $+  \s -> s { actionResp = resp404 $ actionReq s }  -- | Replaces the HTTP status in the current 'HttpResp' with the given -- 'HttpStatus'.-respondStat :: Monad m => HttpStatus -> Action t m ()-respondStat status = StateT $-  \(req, resp, params) -> return $ ((), (req, resp { respStatus = status }, params))+respondStat :: Monad m => HttpStatus -> Action t b m ()+respondStat status = modify $+  \s -> s { actionResp = (actionResp s) { respStatus = status} }  -- | Responds to the client with a @303@ (Temporary Redirect) response to the given -- path. redirectTo :: Monad m            => String -- ^ The path to redirect to-           -> Action t m ()-redirectTo path = StateT $-  \(req, _, params) -> return $ ((), (req, resp303 path, params))+           -> Action t b m ()+redirectTo path = modify $+  \s -> s { actionResp = resp303 path } +-- | Redirect \"back\" according to the \"referer\" header.+redirectBack :: Monad m => Action t b m ()+redirectBack = do+  mhdr <- requestHeader (S.pack "referer")+  maybe (fail "Referer header not set") (redirectTo . S.unpack) mhdr+  + -- | Responds to the client with a @200@ (Success) response with the given body -- and mime-type. render :: Monad m        => String -- ^ The mime-type of the response (commonly \"text\/html\")        -> L.ByteString -- ^ The response body-       -> Action t m ()-render ctype text = StateT $ \(req, resp, prm) -> return $ ((), (req, mkResp resp, prm))-  where len = S.pack $ "Content-Length: " ++ show (L.length text)-        ctypeHeader = S.pack $ "Content-Type: " ++ ctype-        mkResp resp = resp { respHeaders = respHeaders resp ++ [ctypeHeader, len],-                        respBody = inumPure text }+       -> Action t b m ()+render ctype text = modify $ \s -> s { actionResp = mkResp $ actionResp s }+  where len = (S.pack "Content-Length", S.pack . show . L.length $ text)+        ctypeHeader = (S.pack "Content-Type", S.pack ctype)+        mkResp resp = resp { respHeaders = ctypeHeader : (len : respHeaders resp)+                           , respBody = inumPure text }+

@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif {-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-} -- | This module defines the 'RestController' class  @@ -8,36 +12,36 @@  import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import Data.IterIO.HttpRoute import Data.IterIO.Http.Support.Action+import Data.IterIO.Http.Support.Routing import Data.IterIO.Http.Support.Responses import Data.Monoid  -- |The class @RestController@ allows a set of actions to be routed using -- RESTful HTTP verbs.-class Monad m => RestController m a where+class Monad m => RestController t b m a where   -- |GET \/-  restIndex :: a -> Action t m ()+  restIndex :: a -> Action t b m ()   restIndex _ = respond404    -- |GET \/:id   --   -- @id@ is passed in as the second parameter.-  restShow :: a -> L.ByteString -> Action t m ()+  restShow :: a -> L.ByteString -> Action t b m ()   restShow _ _ = respond404    -- |GET \/new-  restNew :: a -> Action t m ()+  restNew :: a -> Action t b m ()   restNew _ = respond404    -- |POST \/-  restCreate :: a -> Action t m ()+  restCreate :: a -> Action t b m ()   restCreate _ = respond404    -- |GET \/:id\/edit   --   -- @id@ is passed in as the second parameter.-  restEdit :: a -> L.ByteString -> Action t m ()+  restEdit :: a -> L.ByteString -> Action t b m ()   restEdit _ _ = respond404    -- |PUT \/:id@@ -47,7 +51,7 @@   -- Since @PUT@ is not supported by many browsers, this action also responds to   -- requests containing the HTTP header "X-HTTP-Method-Override: PUT"   -- regardless of the actual HTTP method (@GET@ or @POST@)-  restUpdate :: a -> L.ByteString -> Action t m ()+  restUpdate :: a -> L.ByteString -> Action t b m ()   restUpdate _ _ = respond404    -- |DELETE \/:id@@ -57,11 +61,11 @@   -- Since @DELETE@ is not supported by many browsers, this action also responds to   -- requests containing the HTTP header "X-HTTP-Method-Override: DELETE"   -- regardless of the actual HTTP method (@GET@ or @POST@)-  restDestroy :: a -> L.ByteString -> Action t m ()+  restDestroy :: a -> L.ByteString -> Action t b m ()   restDestroy _ _ = respond404  -- |Runs an action, passing in named parameter.-runWithVar :: Monad m => S.ByteString -> (L.ByteString -> Action t m ()) -> Action t m ()+runWithVar :: Monad m => S.ByteString -> (L.ByteString -> Action t b m ()) -> Action t b m () runWithVar varName controller = do   (Just var) <- param varName   controller $ paramValue var@@ -89,14 +93,15 @@ -- --    * PUT \/posts\/:id => myRestController#restUpdate ---routeRestController :: RestController m a => String -> a -> HttpRoute m t-routeRestController prefix controller = routeName prefix $ mconcat [+routeRestController :: RestController t b m a => String -> a -> ActionRoute b m t+routeRestController prefix controller = routePattern prefix $ mconcat [     routeTop $ routeMethod "GET" $ routeAction $ restIndex controller   , routeTop $ routeMethod "POST" $ routeAction $ restCreate controller-  , routeMethod "GET" $ routeActionPattern "/:id/edit" $ runWithVar "id" $ restEdit controller-  , routeMethod "GET" $ routeActionPattern "/new" $ restNew controller-  , routeMethod "GET" $ routeActionPattern "/:id" $ runWithVar "id" $ restShow controller-  , routeMethod "DELETE" $ routeActionPattern "/:id" $ runWithVar "id" $ restDestroy controller-  , routeMethod "PUT" $ routeActionPattern "/:id" $ runWithVar "id" $ restUpdate controller+  , routeMethod "GET" $ routePattern "/new" $ routeAction $ restNew controller+  , routeMethod "GET" $ routePattern "/:id/edit" $ routeAction $ runWithVar "id" $ restEdit controller+  , routeMethod "GET" $ routePattern "/:id" $ routeAction $ runWithVar "id" $ restShow controller+  , routeMethod "DELETE" $ routePattern "/:id" $ routeAction $ runWithVar "id" $ restDestroy controller+  , routeMethod "PUT" $ routePattern "/:id" $ routeAction $ runWithVar "id" $ restUpdate controller+  , routeMethod "POST" $ routePattern "/:id" $ routeAction $ runWithVar "id" $ restUpdate controller   ] 

@@ -1,35 +1,239 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif {-# LANGUAGE OverloadedStrings #-} -- |Utility functions for routing. module Data.IterIO.Http.Support.Routing (-    runLHttpRoute+    ActionRoute(..)+  , runActionRoute, runIterAction, runAction+  , routeAction, routePattern+  , routeName, routeVar+  , routeTop, routeMethod, routeFileSys     ) where +import Control.Monad.Trans+import Control.Monad.Trans.State import Data.Char import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S+import Data.List+import Data.List.Split import Data.Maybe+import Data.Monoid+import Data.IterIO import Data.IterIO.Http-import Data.IterIO.HttpRoute-import Data.IterIO.Iter+import Data.IterIO.Http.Support.Action+import Data.IterIO.Http.Support.Responses +import System.FilePath.Posix+import System.Posix.Files+ -- |Converts a 'ByteString' to upper-case upcase :: S.ByteString -> S.ByteString upcase = S.map toUpper --- |Like 'runHttpRoute' but replaces @GET@ and @POST@ request headers with the--- value of the @X-HTTP-Method-Override@ HTTP header if it is present. This--- allows applicaitons to respond to @DELETE@ and @PUT@ methods even though--- many browsers do not support those methods.-runLHttpRoute :: Monad m-              => HttpRoute m s+-- | Like 'runAction' but consumes the rest of the request for the+-- body+runIterAction :: Monad m+              => Action s L.ByteString m a               -> HttpReq s               -> Iter L.ByteString m (HttpResp m)-runLHttpRoute route req = runHttpRoute route $ transformedReq+runIterAction act req = do+  body <- inumHttpBody req .| pureI+  lift $ runAction act req body++-- | Runs an 'ActionRoute'. If it satisfies the request, the+-- underlying 'Action' is returned, otherwise an 'Action' responding+-- with HTTP 404 (Not Found) is returned instead. Can be used at the+-- top of a request handler, for example:+-- +-- > httpHandler :: Action b m ()+-- > httpHandler = runActionRoute $ mconcat [+-- >     routeTop $ routeAction homeAction+-- >   , routeMethod "POST" $ routeAction handleForm+-- >   , routeMethod "GET" $ routeAction showForm+-- >   ]+-- +-- But also can be nested inside of another action to created nested+-- routes, or state dependant routes:+-- +-- > httpHandler :: Action b m ()+-- > httpHandler = runActionRoute $ mconcat [+-- >     routeTop $ routeAction homeAction+-- >   , routeName "foo" $ routeAction $ runActionRoute $ mconcat [+-- >         routeMethod "GET" $ runAction showForm+-- >       , routeMethod "POST" $ runAction handleForm+-- >       ]+-- >   ]+--+-- or+--+-- > handleForm = do+-- >   day <- lift $ getDayOfWeek+-- >   case mod day 2 of+-- >     0 -> runActionRoute $ routeName "stts" $ routeAction doRes+-- >     1 -> runActionRoute $ routeName "mwf" $ routeAction doRes+--+runActionRoute :: Monad m+              => ActionRoute b m s+              -> Action s b m ()+runActionRoute (ActionRoute route) = do+  req <- gets actionReq+  res <- lift $ route req+  fromMaybe respond404 res++-- | An @ActionRoute@ either matches an 'HttpReq' and returns a+-- corresponding 'Action' that responds to it, or 'Nothing'+-- signifying, no approriate 'Action' was found. @ActionRoute@s can+-- be strung together with, e.g., 'mappend' such that each will be+-- searched in turn until an 'Action' responding to the 'HttpReq' is+-- found.+newtype ActionRoute b m s = ActionRoute (HttpReq s -> m (Maybe (Action s b m ())))+-- TODO(alevy): Implement ActionRoute in terms of Reader++instance Monad m => Monoid (ActionRoute b m s) where+  mempty = ActionRoute $ const $ return Nothing+  mappend (ActionRoute a) (ActionRoute b) =+    ActionRoute $ \req -> do+      f <- a req+      case f of+        Just _ -> return f+        Nothing -> b req++popPath :: Bool -> HttpReq s -> HttpReq s+popPath isParm req =+    case reqPathLst req of+      h:t -> req { reqPathLst = t+                 , reqPathCtx = reqPathCtx req ++ [h]+                 , reqPathParams = if isParm then h : reqPathParams req+                                             else reqPathParams req+                 }+      _   -> error "empty path"++-- | Routes a specific directory name, like 'routeMap' for a singleton+-- map.+routeName :: Monad m => String -> ActionRoute b m s -> ActionRoute b m s+routeName name (ActionRoute route) = ActionRoute check+    where sname = S.pack name+          headok (h:_) | h == sname = True+          headok _                  = False+          check req | headok (reqPathLst req) = route $ popPath False req+          check _                             = return Nothing++-- | Matches any directory name, but additionally pushes it onto the+-- front of the 'reqPathParams' list in the 'HttpReq' structure.  This+-- allows the name to serve as a variable argument to the eventual+-- handling function.+routeVar :: Monad m => ActionRoute b m s -> ActionRoute b m s+routeVar (ActionRoute route) = ActionRoute check+    where check req = case reqPathLst req of+                        _:_ -> route $ popPath True req+                        _   -> return Nothing++-- | Match request with path \"/\".+routeTop :: Monad m => ActionRoute b m s -> ActionRoute b m s+routeTop (ActionRoute route) = ActionRoute $ \req ->+                               if null $ reqPathLst req then route req+                               else return Nothing++-- | Match requests with the given method (\"GET\", \"POST\", etc).+routeMethod :: Monad m => String -> ActionRoute b m s -> ActionRoute b m s+routeMethod method (ActionRoute route) = ActionRoute check+  where smethod = S.pack method+        check req | reqMethod req /= smethod = return Nothing+                  | otherwise = route req++-- | Routes an 'Action'+routeAction :: Monad m => Action t b m () -> ActionRoute b m t+routeAction action = ActionRoute $ const . return . Just $ action++-- | Routes an 'Action' to the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be passed+-- into the 'Action' as extra 'Param's. Some examples of URL patters:+--+--  * \/posts\/:id+--+--  * \/posts\/:id\/new+--+--  * \/:date\/posts\/:category\/new+--+routePattern :: Monad m => String -> ActionRoute b m t -> ActionRoute b m t+routePattern pattern action = foldl' addVar (routeActionWithRouteNames patternList action) patternList+  where patternList = reverse $ filter (not . null) $ splitOn "/" pattern+        addVar rt (':':_) = routeVar rt+        addVar rt name = routeName name rt++routeActionWithRouteNames :: Monad m+          => [String]+          -> ActionRoute b m s+          -> ActionRoute b m s+routeActionWithRouteNames routeNames (ActionRoute route) = ActionRoute $ \req -> do+  mact <- route req+  case mact of+    Just act -> return . Just $ do+      prms <- params+      _ <- setParams (prms ++ pathLstToParams req routeNames)+      act+    Nothing -> return Nothing++-- | Runs an 'Action' given an 'HttpReq' and body. Returns the 'HttpResp'+-- generated by the 'Action'.+runAction :: Monad m+          => Action s b m a+          -> HttpReq s+          -> b+          -> m (HttpResp m)+runAction action req body = do+  let s = ActionState transformedReq (mkHttpHead stat200) [] body+  (_, result) <- runStateT action s+  return $ actionResp result   where method = upcase $ reqMethod req-        overrideHeader = lookup "X-HTTP-Method-Override" (reqHeaders req)+        overrideHeader = lookup "x-http-method-override" (reqHeaders req)         transformedReq           | method /= "GET" && method /= "POST" = req           | isJust overrideHeader =               req{reqMethod = (upcase . fromJust $ overrideHeader)}           | otherwise = req++pathLstToParams :: HttpReq s -> [String] -> [Param]+pathLstToParams req routeNames = result+  where (result, _) = foldl go ([], reqPathParams req) routeNames+        go (prms, plst@(_:_)) (':':var) = ((transform var $ head plst):prms, tail plst)+        go s _ = s+        transform k v = Param (S.pack k) (L.fromChunks [v]) []++routeFileSys :: (String -> S.ByteString)+             -> FilePath+             -> ActionRoute b IO t+routeFileSys mimeMap root = ActionRoute $ \req -> do+  mresp <- check req+  case mresp of+    Just resp -> return $ Just $ modify $ \s -> s { actionResp = resp }+    _ -> return Nothing+  where check req = do +          let path = foldl (</>) root (map S.unpack $ reqPathLst req)+          exist <- liftIO $ fileExist path+          if exist then do+            st <- liftIO $ getFileStatus path+            case () of+              _ | isRegularFile st -> doFile req path st+                | otherwise -> return Nothing+            else return Nothing+        doFile req path st+            | reqMethod req == "HEAD" =+                return $ Just $ resp { respStatus = stat200 }+            | reqMethod req == "GET" = do+                return $ Just $+                  resp { respBody = enumFile' path }+            | otherwise = return Nothing+          where resp = defaultHttpResp { respChunk = False+                                       , respHeaders = mkHeaders req st }+        mkHeaders req st = +          [ ("Content-Length", S.pack . show $ fileSize st)+          , ("Content-Type", mimeMap $ fileExt req) ]+        fileExt req =+          drop 1 $ takeExtension $ case reqPathLst req of+                                     [] -> "."+                                     l  -> S.unpack $ last l 

@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif++module Data.IterIO.Http.Support.Utils where++import Data.ByteString.Lazy.Char8+import Data.IterIO+import Data.IterIO.Http+import Data.IterIO.Http.Support.Action++-- | For 'Action's where the body type is a 'ByteString', parse the+-- body with 'parseParams\'' and prepend the result to the 'Action''s+-- 'Param's+parseParams :: Monad m => Action t ByteString m [Param]+parseParams = do+  req <- getHttpReq+  body <- getBody+  prms0 <- params+  prms1 <- parseParams' req body+  setParams $ prms1 ++ prms0++-- | Parse url encoded or form encoded paramters from an HTTP+-- body.+parseParams' :: Monad m => HttpReq a -> ByteString -> m [Param]+parseParams' req body = inumPure body |$ foldForm req handle []+  where handle accm field = do+          val <- pureI+          return $ (Param (ffName field) val (ffHeaders field)):accm+

@@ -1,19 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}  import Control.Monad.Trans-import qualified Data.ByteString.Lazy.Char8 as L-import Data.IterIO.HttpRoute+import qualified Data.ByteString.Lazy.Char8 as L8 import Data.IterIO.Server.TCPServer import Data.Monoid+import Data.Maybe import System.Random  import Text.Blaze.Renderer.Utf8 (renderHtml) import Text.Blaze.Html5 hiding (param)-import Text.Blaze.Html5.Attributes+import Text.Blaze.Html5.Attributes hiding (id, min, max) -import Data.IterIO.Http.Support.Action-import Data.IterIO.Http.Support.Responses+import Data.IterIO.Http.Support +type L = L8.ByteString+ main :: IO () main = runTCPServer httpServer @@ -31,13 +32,13 @@           , "Has, like, a ton of Facebook friends."           , "Always chooses the write homophone."] -httpServer = simpleHttpServer 8080 $ runHttpRoute $ mconcat [+httpServer = simpleHttpServer 8080 $ runIterActionRoute $ mconcat [     routeTop $ routeAction welcomeAction   , routeActionPattern "/factoid/:index" quoteAction   , routeActionPattern "/factoid" indexAction   ] -welcomeAction :: Action t IO ()+welcomeAction :: Action t L IO () welcomeAction = do   render "text/html" $ renderHtml $ docTypeHtml $ do     body $ do@@ -45,7 +46,7 @@       p $ do         "Click "; a ! href "/factoid" $ "here"; " to learn somethine about me." -indexAction :: Action t IO ()+indexAction :: Action t L IO () indexAction = do   idx <- lift $ getStdRandom (randomR (0,length quotes - 1))    let quote = quotes !! idx@@ -56,11 +57,13 @@         "Johnny Carson "         a ! href (toValue $ "/factoid/" ++ (show idx)) $ toHtml quote -quoteAction :: Action t IO ()+quoteAction :: Action t L IO () quoteAction = do-  (Just idx) <- param "index" -  let quote = quotes !! (read $ (L.unpack . paramValue) idx)+  (Just idx') <- param "index" +  let idx   = maybe 0 id $ maybeRead $ (L8.unpack . paramValue) idx'+      quote = quotes !! (max 0 (min idx (length quotes -1)))   render "text/html" $ renderHtml $ docTypeHtml $ do     body $ do       h1 $ do "Johnny Carson "; toHtml quote       p $ a ! href "/factoid" $ "Another random quote..."+    where maybeRead = fmap fst . listToMaybe . reads

@@ -1,5 +1,5 @@ Name:           iterio-server-Version:        0.2+Version:        0.3 build-type:     Simple License:        BSD3 License-File:   LICENSE@@ -27,9 +27,11 @@                  ListLike >= 3 && < 4,                  monadIO >= 0.10 && < 0.20,                  mtl >= 2.0 && < 2.1,-                 iterIO >= 0.2 && < 0.3,+                 iterIO >= 0.2.2 && < 0.3,                  network >= 2.3 && < 2.4,                  split >= 0.1 && < 0.2,+                 unix >= 2.5 && < 2.6,+                 filepath >= 1.3 && < 1.4,                  transformers >= 0.2 && < 0.3    ghc-options: -Wall@@ -40,5 +42,6 @@     Data.IterIO.Http.Support.Responses     Data.IterIO.Http.Support.RestController     Data.IterIO.Http.Support.Routing+    Data.IterIO.Http.Support.Utils     Data.IterIO.Server.TCPServer