packages feed

simple 0.7.0.1 → 0.8.0.0

raw patch · 10 files changed

+499/−236 lines, 10 files

Files

simple.cabal view
@@ -1,5 +1,5 @@ name:                simple-version:             0.7.0.1+version:             0.8.0.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -25,6 +25,7 @@   .   See "Web.Simple" for a more detailed introduction. homepage:            http://simple.cx+Bug-Reports:         http://github.com/alevy/simple/issues license:             LGPL-3 license-file:        LICENSE author:              Amit Levy, Daniel B. Giffin@@ -82,6 +83,7 @@     Web.Simple,     Web.Simple.Auth,     Web.Simple.Controller,+    Web.Simple.Controller.Trans,     Web.Simple.Responses,     Web.Simple.Static,     Web.Simple.Templates,@@ -91,5 +93,5 @@  source-repository head   type: git-  location: anonymous@gitstar.com:alevy/simple.git+  location: http://github.com/alevy/simple.git
src/Web/Frank.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {- | Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating routes. It is composable with all 'ToApplication' types, but is designed to be used@@ -30,29 +31,31 @@   ) where  import Network.HTTP.Types-import Web.Simple.Controller+import Web.Simple.Controller.Trans import qualified Data.ByteString as S  -- | Helper method-frankMethod :: StdMethod -> S.ByteString -> Controller r a -> Controller r ()+frankMethod :: Monad m+            => StdMethod -> S.ByteString -> ControllerT m r a+            -> ControllerT m r () frankMethod method pattern = routeMethod method . routePattern pattern . routeTop  -- | Matches the GET method on the given URL pattern-get :: S.ByteString -> Controller r a -> Controller r ()+get :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r () get = frankMethod GET  -- | Matches the POST method on the given URL pattern-post :: S.ByteString -> Controller r a -> Controller r ()+post :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r () post = frankMethod POST  -- | Matches the PUT method on the given URL pattern-put :: S.ByteString -> Controller r a -> Controller r ()+put :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r () put = frankMethod PUT  -- | Matches the DELETE method on the given URL pattern-delete :: S.ByteString -> Controller r a -> Controller r ()+delete :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r () delete = frankMethod DELETE  -- | Matches the OPTIONS method on the given URL pattern-options :: S.ByteString -> Controller r a -> Controller r ()+options :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r () options = frankMethod OPTIONS
src/Web/REST.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE Trustworthy, FlexibleInstances, OverloadedStrings #-}+{- |++REST is a DSL for creating routes using RESTful HTTP verbs.+See <http://en.wikipedia.org/wiki/Representational_state_transfer>++-} module Web.REST   ( REST(..), RESTController, rest, routeREST   , index, show, create, update, delete@@ -7,24 +13,25 @@  import Prelude hiding (show) -import Control.Monad import Control.Monad.Trans.State import Data.Functor.Identity import Web.Simple.Responses-import Web.Simple.Controller+import Web.Simple.Controller.Trans import Network.HTTP.Types -data REST r = REST-  { restIndex   :: Controller r ()-  , restShow    :: Controller r ()-  , restCreate  :: Controller r ()-  , restUpdate  :: Controller r ()-  , restDelete  :: Controller r ()-  , restEdit    :: Controller r ()-  , restNew     :: Controller r ()+-- | Type used to encode a REST controller.+data REST m r = REST+  { restIndex   :: ControllerT m r ()+  , restShow    :: ControllerT m r ()+  , restCreate  :: ControllerT m r ()+  , restUpdate  :: ControllerT m r ()+  , restDelete  :: ControllerT m r ()+  , restEdit    :: ControllerT m r ()+  , restNew     :: ControllerT m r ()   } -defaultREST :: REST r+-- | Default state, returns @404@ for all verbs.+defaultREST :: Monad m => REST m r defaultREST = REST   { restIndex   = respond $ notFound   , restShow    = respond $ notFound@@ -35,12 +42,13 @@   , restNew     = respond $ notFound   } -type RESTControllerM r a = StateT (REST r) Identity a+-- | Monad used to encode a REST controller incrementally.+type RESTControllerM m r a = StateT (REST m r) Identity a -rest :: RESTControllerM r a -> REST r+rest :: Monad m => RESTControllerM m r a -> REST m r rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST -routeREST :: REST r -> Controller r ()+routeREST :: Monad m => REST m r -> ControllerT m r () routeREST rst = do   routeMethod GET $ do     routeTop $ restIndex rst@@ -55,33 +63,40 @@    routeMethod PUT $ routeVar "id" $ restUpdate rst -type RESTController r = RESTControllerM r ()+type RESTController m r = RESTControllerM m r () -index :: Controller r a -> RESTController r+-- | GET \/+index :: ControllerT m r () -> RESTController m r index route = modify $ \controller ->-  controller { restIndex = void route }+  controller { restIndex = route } -create :: Controller r a -> RESTController r+-- | POST \/+create :: ControllerT m r () -> RESTController m r create route = modify $ \controller ->-  controller { restCreate = void route }+  controller { restCreate = route } -edit :: Controller r a -> RESTController r+-- | GET \/:id\/edit+edit :: ControllerT m r () -> RESTController m r edit route = modify $ \controller ->-  controller { restEdit = void route }+  controller { restEdit = route } -new :: Controller r a -> RESTController r+-- | GET \/new+new :: ControllerT m r () -> RESTController m r new route = modify $ \controller ->-  controller { restNew = void route }+  controller { restNew = route } -show :: Controller r a -> RESTController r+-- | GET \/:id+show :: ControllerT m r () -> RESTController m r show route = modify $ \controller ->-  controller { restShow = void route }+  controller { restShow = route } -update :: Controller r a -> RESTController r+-- | PUT \/:id+update :: ControllerT m r () -> RESTController m r update route = modify $ \controller ->-  controller { restUpdate = void route }+  controller { restUpdate = route } -delete :: Controller r a -> RESTController r+-- | DELETE \/:id+delete :: ControllerT m r () -> RESTController m r delete route = modify $ \controller ->-  controller { restDelete = void route }+  controller { restDelete = route }
src/Web/Simple.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {- |
src/Web/Simple/Controller.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-}  {- | 'Controller' provides a convenient syntax for writting 'Application'@@ -24,7 +24,7 @@   -- * Example   -- $Example   -- * Controller Monad-    Controller(..), runController+    Controller, T.ControllerT(..), ControllerState   , controllerApp, controllerState, putState   , request, localRequest, respond   , requestHeader@@ -32,7 +32,7 @@   , routeHost, routeTop, routeMethod, routeAccept   , routePattern, routeName, routeVar   -- * Inspecting query-  , Parseable+  , T.Parseable   , queryParam, queryParam', queryParams   , readQueryParam, readQueryParam', readQueryParams   , parseForm@@ -40,140 +40,87 @@   , redirectBack   , redirectBackOr   -- * Exception handling-  , ControllerException+  , T.ControllerException   , module Control.Exception.Peel   -- * Integrating other WAI components-  , ToApplication(..)   , fromApp   -- * Low-level utilities   , body-  -- , guard, guardM, guardReq+  , hoistEither, ask, local, pass   ) where -import           Control.Applicative import           Control.Exception.Peel-import           Control.Monad hiding (guard) import           Control.Monad.IO.Class-import           Control.Monad.IO.Peel import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import           Data.Conduit import qualified Data.Conduit.List as CL-import           Data.List (find)-import           Data.Maybe-import           Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Data.Typeable import           Network.HTTP.Types import           Network.Wai import           Network.Wai.Parse+import           Web.Simple.Controller.Trans+                  (ControllerT, ControllerState)+import qualified Web.Simple.Controller.Trans as T import           Web.Simple.Responses  -type ControllerState r = (r, Request)- -- | The Controller Monad is both a State-like monad which, when run, computes -- either a 'Response' or a result. Within the Controller Monad, the remainder -- of the computation can be short-circuited by 'respond'ing with a 'Response'.-newtype Controller r a =-  Controller (ControllerState r ->-              IO (Either Response a, ControllerState r))--instance Functor (Controller r) where-  fmap f (Controller act) = Controller $ \st0 -> do-    (eaf, st) <- act st0-    case eaf of-      Left resp -> return (Left resp, st)-      Right result -> return (Right $ f result, st)--instance Applicative (Controller r) where-  pure a = Controller $ \st -> return $ (Right a, st)-  (<*>) = ap--instance Monad (Controller r) where-  return = pure-  (Controller act) >>= fn = Controller $ \st0 -> do-    (eres, st) <- act st0-    case eres of-      Left resp -> return (Left resp, st)-      Right result -> do-        let (Controller fres) = fn result-        fres st--instance MonadIO (Controller r) where-  liftIO act = Controller $ \st -> liftIO act >>= \r -> return (Right r, st)+type Controller = ControllerT IO  hoistEither :: Either Response a -> Controller r a-hoistEither eith = Controller $ \st -> return (eith, st)--instance MonadPeelIO (Controller r) where-  peelIO = do-    r <- controllerState-    req <- request-    return $ \ctrl -> do-      res <- runController ctrl r req-      return $ hoistEither res+hoistEither = T.hoistEither  ask :: Controller r (r, Request)-ask = Controller $ \rd -> return (Right rd, rd)+ask = T.ask  -- | Extract the request request :: Controller r Request-request = liftM snd ask+request = T.request  local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a-local f (Controller act) = Controller $ \st@(_, r) -> do-  (eres, (req, _)) <- act (f st)-  return (eres, (req, r))+local = T.local  -- | Modify the request for the given computation localRequest :: (Request -> Request) -> Controller r a -> Controller r a-localRequest f = local (\(r,req) -> (r, f req))+localRequest = T.localRequest  -- | Extract the application-specific state-controllerState :: Controller r r -controllerState = liftM fst ask+controllerState :: Controller r r+controllerState = T.controllerState  putState :: r -> Controller r ()-putState r = Controller $ \(_, req) -> return (Right (), (r, req))+putState = T.putState  -- | Convert the controller into an 'Application' controllerApp :: r -> Controller r a -> Application-controllerApp r ctrl req =-  runController ctrl r req >>=-    either return (const $ return notFound) --runController :: Controller r a -> r -> Request -> IO (Either Response a)-runController (Controller fun) r req = fst `fmap` fun (r,req)+controllerApp = T.controllerApp  -- | Decline to handle the request -- -- @pass >> c === c@ -- @c >> pass === c@ pass :: Controller r ()-pass = Controller $ \st -> return (Right (), st)+pass = T.pass  -- | Provide a response -- -- @respond r >>= f === respond r@ respond :: Response -> Controller r a-respond resp = Controller $ \st -> return (Left resp, st)+respond = T.respond   -- | Lift an application to a controller-fromApp :: ToApplication a => a -> Controller r ()-fromApp app = do-  req <- request-  resp <- liftIO $ (toApp app) req-  respond resp+fromApp :: Application -> Controller r ()+fromApp = T.fromApp  -- | Matches on the hostname from the 'Request'. The route only succeeds on -- exact matches. routeHost :: S.ByteString -> Controller r a -> Controller r ()-routeHost host = guardReq $ \req -> host == (fromMaybe "" $ requestHeaderHost req)+routeHost = T.routeHost  -- | Matches if the path is empty. --@@ -181,17 +128,15 @@ -- is empty, so it works as expected in nested contexts that have -- popped components from the 'pathInfo' list. routeTop :: Controller r a -> Controller r ()-routeTop = guardReq $ \req -> null (pathInfo req) ||-                              (T.length . head $ pathInfo req) == 0+routeTop = T.routeTop  -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT') routeMethod :: StdMethod -> Controller r a -> Controller r ()-routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod+routeMethod = T.routeMethod  -- | Matches if the request's Content-Type exactly matches the given string routeAccept :: S8.ByteString -> Controller r a -> Controller r ()-routeAccept contentType = guardReq (isJust . find matching . requestHeaders)- where matching hdr = fst hdr == hAccept && snd hdr == contentType+routeAccept = T.routeAccept  -- | Routes the given URL pattern. Patterns can include -- directories as well as variable patterns (prefixed with @:@) to be added@@ -204,35 +149,17 @@ --  * \/:date\/posts\/:category\/new -- routePattern :: S.ByteString -> Controller r a -> Controller r ()-routePattern pattern route =-  let patternParts = map T.unpack $ decodePathSegments pattern-  in foldr mkRoute (route >> return ()) patternParts-  where mkRoute (':':varName) = routeVar (S8.pack varName)-        mkRoute name = routeName (S8.pack name)+routePattern = T.routePattern  -- | Matches if the first directory in the path matches the given 'ByteString' routeName :: S.ByteString -> Controller r a -> Controller r ()-routeName name next = do-  req <- request-  if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req-    then localRequest popHdr next >> return ()-    else pass-  where popHdr req = req { pathInfo = (tail . pathInfo $ req) }+routeName = T.routeName  -- | Always matches if there is at least one directory in 'pathInfo' but and -- adds a parameter to 'queryString' where the key is the first parameter and -- the value is the directory consumed from the path. routeVar :: S.ByteString -> Controller r a -> Controller r ()-routeVar varName next = do-  req <- request-  case pathInfo req of-    [] -> pass-    x:_ | T.null x -> pass-        | otherwise -> localRequest popHdr next >> return ()-  where popHdr req = req {-              pathInfo = (tail . pathInfo $ req)-            , queryString = (varName, Just (varVal req)):(queryString req)}-        varVal req = S8.pack . T.unpack . head . pathInfo $ req+routeVar = T.routeVar  -- -- query parameters@@ -246,70 +173,40 @@ -- would return @Just "bar"@, but -- @queryParam \"zap\"@ -- would return @Nothing@.-queryParam :: Parseable a+queryParam :: T.Parseable a            => S8.ByteString -- ^ Parameter name            -> Controller r (Maybe a)-queryParam varName = do-  qr <- liftM queryString request-  return $ case lookup varName qr of-    Just p -> Just $ parse $ fromMaybe S.empty p-    _ -> Nothing+queryParam = T.queryParam  -- | Like 'queryParam', but throws an exception if the parameter is not present.-queryParam' :: Parseable a+queryParam' :: T.Parseable a             => S.ByteString -> Controller r a-queryParam' varName =-  queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return+queryParam' = T.queryParam'  -- | Selects all values with the given parameter name-queryParams :: Parseable a+queryParams :: T.Parseable a             => S.ByteString -> Controller r [a]-queryParams varName = request >>= return .-                                  map (parse . fromMaybe S.empty . snd) .-                                  filter ((== varName) . fst) .-                                  queryString---- | The class of types into which query parameters may be converted-class Parseable a where-  parse :: S8.ByteString -> a--instance Parseable S8.ByteString where-  parse = id-instance Parseable String where-  parse = S8.unpack-instance Parseable Text where-  parse = T.decodeUtf8+queryParams = T.queryParams  -- | Like 'queryParam', but further processes the parameter value with @read@. -- If that conversion fails, an exception is thrown. readQueryParam :: Read a                => S8.ByteString -- ^ Parameter name                -> Controller r (Maybe a)-readQueryParam varName =-  queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)+readQueryParam = T.readQueryParam  -- | Like 'readQueryParam', but throws an exception if the parameter is not present. readQueryParam' :: Read a                 => S8.ByteString -- ^ Parameter name                 -> Controller r a-readQueryParam' varName =-  queryParam' varName >>= readParamValue varName+readQueryParam' = T.readQueryParam'  -- | Like 'queryParams', but further processes the parameter values with @read@. -- If any read-conversion fails, an exception is thrown.-readQueryParams ::  Read a+readQueryParams :: Read a                 => S8.ByteString -- ^ Parameter name                 -> Controller r [a]-readQueryParams varName =-  queryParams varName >>= mapM (readParamValue varName)--readParamValue :: Read a => S8.ByteString -> Text -> Controller r a-readParamValue varName =-  maybe (err $ "cannot read parameter: " ++ show varName) return .-    readMay . T.unpack-  where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of-                      [x] -> Just x-                      _ -> Nothing+readQueryParams = T.readQueryParams  -- | Parses a HTML form from the request body. It returns a list of 'Param's as -- well as a list of 'File's, which are pairs mapping the name of a /file/ form@@ -317,7 +214,7 @@ -- upload. -- -- @---   myController = do+--   myControllerT = do --     (prms, files) <- parseForm --     let mPicFile = lookup \"profile_pic\" files --     case mPicFile of@@ -357,38 +254,6 @@   case mrefr of     Just refr -> respond $ redirectTo refr     Nothing   -> respond def---- guard--guard :: Bool -> Controller r a -> Controller r ()-guard b c = if b then c >> return () else pass--guardM :: Controller r Bool -> Controller r a -> Controller r ()-guardM b c = b >>= flip guard c--guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()-guardReq f = guardM (liftM f request)---- | The class of types that can be converted to an 'Application'-class ToApplication r where-  toApp :: r -> Application--instance ToApplication Application where-  toApp = id--instance ToApplication Response where-  toApp = const . return--data ControllerException = ControllerException String-  deriving (Typeable)--instance Show ControllerException where-  show (ControllerException msg) = "Controller: " ++ msg--instance Exception ControllerException--err :: String -> Controller r a-err = throwIO . ControllerException  {- $Example  #example#
+ src/Web/Simple/Controller/Trans.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}++{- | 'ControllerT' provides a convenient syntax for writting 'Application'+  code as a Monadic action with access to an HTTP request as well as app+  specific data (e.g. a database connection pool, app configuration etc.)+  This module also defines some+  helper functions that leverage this feature. For example, 'redirectBack'+  reads the underlying request to extract the referer and returns a redirect+  response:++  @+    myControllerT = do+      ...+      if badLogin then+        redirectBack+        else+          ...+  @+-}+module Web.Simple.Controller.Trans where++import           Control.Monad.IO.Class+import           Control.Monad.IO.Peel+import           Control.Applicative+import           Control.Exception.Peel+import           Control.Monad hiding (guard)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import           Data.List (find)+import           Data.Maybe+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           Data.Typeable+import           Network.HTTP.Types+import           Network.Wai+import           Web.Simple.Responses+++type ControllerState r = (r, Request)++-- | The ControllerT Monad is both a State-like monad which, when run, computes+-- either a 'Response' or a result. Within the ControllerT Monad, the remainder+-- of the computation can be short-circuited by 'respond'ing with a 'Response'.+newtype ControllerT m r a = ControllerT+  { runController :: ControllerState r ->+                      m (Either Response a, ControllerState r) }++instance (Monad m, Functor m) => Functor (ControllerT m r) where+  fmap f (ControllerT act) = ControllerT $ \st0 -> do+    (eaf, st) <- act st0+    case eaf of+      Left resp -> return (Left resp, st)+      Right result -> return (Right $ f result, st)++instance (Monad m, Applicative m) => Applicative (ControllerT m r) where+  pure = return+  (<*>) = ap++instance Monad m => Monad (ControllerT m r) where+  return a = ControllerT $ \st -> return $ (Right a, st)+  (ControllerT act) >>= fn = ControllerT $ \st0 -> do+    (eres, st) <- act st0+    case eres of+      Left resp -> return (Left resp, st)+      Right result -> do+        let (ControllerT fres) = fn result+        fres st++instance MonadIO m => MonadIO (ControllerT m r) where+  liftIO = liftC . liftIO++instance MonadPeelIO (ControllerT IO r) where+  peelIO = do+    r <- controllerState+    req <- request+    return $ \ctrl -> do+      res <- fst `fmap` runController ctrl (r, req)+      return $ hoistEither res++liftC :: Monad m => m a -> ControllerT m r a+liftC act = ControllerT $ \st -> act >>= \r -> return (Right r, st)++hoistEither :: Monad m => Either Response a -> ControllerT m r a+hoistEither eith = ControllerT $ \st -> return (eith, st)++ask :: Monad m => ControllerT m r (r, Request)+ask = ControllerT $ \rd -> return (Right rd, rd)++-- | Extract the request+request :: Monad m => ControllerT m r Request+request = liftM snd ask++local :: Monad m+      => ((r, Request) -> (r, Request)) -> ControllerT m r a -> ControllerT m r a+local f (ControllerT act) = ControllerT $ \st@(_, r) -> do+  (eres, (req, _)) <- act (f st)+  return (eres, (req, r))++-- | Modify the request for the given computation+localRequest :: Monad m+             => (Request -> Request) -> ControllerT m r a -> ControllerT m r a+localRequest f = local (\(r,req) -> (r, f req))++-- | Extract the application-specific state+controllerState :: Monad m => ControllerT m r r+controllerState = liftM fst ask++putState :: Monad m => r -> ControllerT m r ()+putState r = ControllerT $ \(_, req) -> return (Right (), (r, req))++-- | Convert the controller into an 'Application'+controllerApp :: Monad m => r -> ControllerT m r a -> SimpleApplication m+controllerApp r ctrl req =+  runController ctrl (r, req) >>=+    either return (const $ return notFound) . fst++-- | Decline to handle the request+--+-- @pass >> c === c@+-- @c >> pass === c@+pass :: Monad m => ControllerT m r ()+pass = ControllerT $ \st -> return (Right (), st)++-- | Provide a response+--+-- @respond r >>= f === respond r@+respond :: Monad m => Response -> ControllerT m r a+respond resp = hoistEither $ Left resp+++-- | Lift an application to a controller+fromApp :: Monad m => (Request -> m Response) -> ControllerT m r ()+fromApp app = do+  req <- request+  resp <- liftC $ app req+  respond resp++-- | Matches on the hostname from the 'Request'. The route only succeeds on+-- exact matches.+routeHost :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+routeHost host = guardReq $ \req ->+  host == (fromMaybe "" $ requestHeaderHost req)++-- | Matches if the path is empty.+--+-- Note that this route checks that 'pathInfo'+-- is empty, so it works as expected in nested contexts that have+-- popped components from the 'pathInfo' list.+routeTop :: Monad m => ControllerT m r a -> ControllerT m r ()+routeTop = guardReq $ \req -> null (pathInfo req) ||+                              (T.length . head $ pathInfo req) == 0++-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')+routeMethod :: Monad m => StdMethod -> ControllerT m r a -> ControllerT m r ()+routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod++-- | Matches if the request's Content-Type exactly matches the given string+routeAccept :: Monad m => S8.ByteString -> ControllerT m r a -> ControllerT m r ()+routeAccept contentType = guardReq (isJust . find matching . requestHeaders)+ where matching hdr = fst hdr == hAccept && snd hdr == contentType++-- | Routes the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be added+-- to 'queryString' (see 'routeVar')+--+--  * \/posts\/:id+--+--  * \/posts\/:id\/new+--+--  * \/:date\/posts\/:category\/new+--+routePattern :: Monad m+             => S.ByteString -> ControllerT m r a -> ControllerT m r ()+routePattern pattern route =+  let patternParts = map T.unpack $ decodePathSegments pattern+  in foldr mkRoute (route >> return ()) patternParts+  where mkRoute (':':varName) = routeVar (S8.pack varName)+        mkRoute name = routeName (S8.pack name)++-- | Matches if the first directory in the path matches the given 'ByteString'+routeName :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+routeName name next = do+  req <- request+  if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req+    then localRequest popHdr next >> return ()+    else pass+  where popHdr req = req { pathInfo = (tail . pathInfo $ req) }++-- | Always matches if there is at least one directory in 'pathInfo' but and+-- adds a parameter to 'queryString' where the key is the first parameter and+-- the value is the directory consumed from the path.+routeVar :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+routeVar varName next = do+  req <- request+  case pathInfo req of+    [] -> pass+    x:_ | T.null x -> pass+        | otherwise -> localRequest popHdr next >> return ()+  where popHdr req = req {+              pathInfo = (tail . pathInfo $ req)+            , queryString = (varName, Just (varVal req)):(queryString req)}+        varVal req = S8.pack . T.unpack . head . pathInfo $ req++--+-- query parameters+--++-- | Looks up the parameter name in the request's query string and returns the+-- @Parseable@ value or 'Nothing'.+--+-- For example, for a request with query string: \"?foo=bar&baz=7\",+-- @queryParam \"foo\"@+-- would return @Just "bar"@, but+-- @queryParam \"zap\"@+-- would return @Nothing@.+queryParam :: (Monad m, Parseable a)+           => S8.ByteString -- ^ Parameter name+           -> ControllerT m r (Maybe a)+queryParam varName = do+  qr <- liftM queryString request+  return $ case lookup varName qr of+    Just p -> Just $ parse $ fromMaybe S.empty p+    _ -> Nothing++-- | Like 'queryParam', but throws an exception if the parameter is not present.+queryParam' :: (Monad m, Parseable a)+            => S.ByteString -> ControllerT m r a+queryParam' varName =+  queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return++-- | Selects all values with the given parameter name+queryParams :: (Monad m, Parseable a)+            => S.ByteString -> ControllerT m r [a]+queryParams varName = request >>= return .+                                  map (parse . fromMaybe S.empty . snd) .+                                  filter ((== varName) . fst) .+                                  queryString++-- | The class of types into which query parameters may be converted+class Parseable a where+  parse :: S8.ByteString -> a++instance Parseable S8.ByteString where+  parse = id+instance Parseable String where+  parse = S8.unpack+instance Parseable Text where+  parse = T.decodeUtf8++-- | Like 'queryParam', but further processes the parameter value with @read@.+-- If that conversion fails, an exception is thrown.+readQueryParam :: (Monad m, Read a)+               => S8.ByteString -- ^ Parameter name+               -> ControllerT m r (Maybe a)+readQueryParam varName =+  queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)++-- | Like 'readQueryParam', but throws an exception if the parameter is not present.+readQueryParam' :: (Monad m, Read a)+                => S8.ByteString -- ^ Parameter name+                -> ControllerT m r a+readQueryParam' varName =+  queryParam' varName >>= readParamValue varName++-- | Like 'queryParams', but further processes the parameter values with @read@.+-- If any read-conversion fails, an exception is thrown.+readQueryParams :: (Monad m, Read a)+                => S8.ByteString -- ^ Parameter name+                -> ControllerT m r [a]+readQueryParams varName =+  queryParams varName >>= mapM (readParamValue varName)++readParamValue :: (Monad m, Read a)+               => S8.ByteString -> Text -> ControllerT m r a+readParamValue varName =+  maybe (err $ "cannot read parameter: " ++ show varName) return .+    readMay . T.unpack+  where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of+                      [x] -> Just x+                      _ -> Nothing++-- | Returns the value of the given request header or 'Nothing' if it is not+-- present in the HTTP request.+requestHeader :: Monad m => HeaderName -> ControllerT m r (Maybe S8.ByteString)+requestHeader name = request >>= return . lookup name . requestHeaders++-- | Redirect back to the referer. If the referer header is not present+-- redirect to root (i.e., @\/@).+redirectBack :: Monad m => ControllerT m r ()+redirectBack = redirectBackOr (redirectTo "/")++-- | Redirect back to the referer. If the referer header is not present+-- fallback on the given 'Response'.+redirectBackOr :: Monad m+               => Response -- ^ Fallback response+               -> ControllerT m r ()+redirectBackOr def = do+  mrefr <- requestHeader "referer"+  case mrefr of+    Just refr -> respond $ redirectTo refr+    Nothing   -> respond def++-- | Like 'Application', but with 'm' as the underlying monad+type SimpleApplication m = Request -> m Response++-- | Like 'Application', but with 'm' as the underlying monad+type SimpleMiddleware m = SimpleApplication m -> SimpleApplication m++-- guard++guard :: Monad m => Bool -> ControllerT m r a -> ControllerT m r ()+guard b c = if b then c >> return () else pass++guardM :: Monad m+       => ControllerT m r Bool -> ControllerT m r a -> ControllerT m r ()+guardM b c = b >>= flip guard c++guardReq :: Monad m+         => (Request -> Bool) -> ControllerT m r a -> ControllerT m r ()+guardReq f = guardM (liftM f request)++data ControllerException = ControllerException String+  deriving (Typeable)++instance Show ControllerException where+  show (ControllerException msg) = "ControllerT: " ++ msg++instance Exception ControllerException++err :: String -> ControllerT m r a+err = throw . ControllerException++{- $Example+ #example#++The most basic 'Routeable' types are 'Application' and 'Response'. Reaching+either of these types marks a termination in the routing lookup. This module+exposes a monadic type 'Route' which makes it easy to create routing logic+in a DSL-like fashion.++'Route's are concatenated using the '>>' operator (or using do-notation).+In the end, any 'Routeable', including a 'Route' is converted to an+'Application' and passed to the server using 'mkRoute':++@++  mainAction :: ControllerT () ()+  mainAction = ...++  signinForm :: ControllerT () ()+  signinForm req = ...++  login :: ControllerT () ()+  login = ...++  updateProfile :: ControllerT () ()+  updateProfile = ...++  main :: IO ()+  main = run 3000 $ controllerApp () $ do+    routeTop mainAction+    routeName \"sessions\" $ do+      routeMethod GET signinForm+      routeMethod POST login+    routeMethod PUT $ routePattern \"users/:id\" updateProfile+    routeAll $ responseLBS status404 [] \"Are you in the right place?\"+@++-}
src/Web/Simple/Responses.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-}  -- | This module defines some convenience functions for creating responses.
src/Web/Simple/Templates.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}+{-# LANGUAGE DefaultSignatures #-} module Web.Simple.Templates   ( HasTemplates(..)   , defaultGetTemplate, defaultRender, defaultFunctionMap@@ -6,7 +8,6 @@   , Function(..), ToFunction(..), FunctionMap   ) where -import Control.Applicative import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString as S@@ -17,16 +18,16 @@ import qualified Data.Vector as V import Network.Mime import System.FilePath-import Web.Simple.Controller (Controller, respond)+import Web.Simple.Controller.Trans (ControllerT, respond) import Web.Simple.Responses (ok) import Web.Simple.Templates.Language -class HasTemplates hs where+class Monad m => HasTemplates m hs where   -- | The layout to use by default. Layouts are just templates that embed   -- views. They are rendered with the a global object containing the rendered   -- view in the \"yield\" field, and the object the view was rendered with in   -- the \"page\" field. By default, no template is used.-  defaultLayout :: Controller hs (Maybe Template)+  defaultLayout :: ControllerT m hs (Maybe Template)   defaultLayout = return Nothing    -- | The directory to look for views passed to 'render'. This defaults to@@ -37,28 +38,29 @@   -- @   --   -- will look for a view template in \"views/index.html.tmpl\".-  viewDirectory :: Controller hs FilePath+  viewDirectory :: ControllerT m hs FilePath   viewDirectory = return "views"    -- | A map of pure functions that can be called from within a template. See   -- 'FunctionMap' and 'Function' for details.-  functionMap :: Controller hs FunctionMap+  functionMap :: ControllerT m hs FunctionMap   functionMap = return defaultFunctionMap    -- | Function to use to get a template. By default, it looks in the   -- 'viewDirectory' for the given file name and compiles the file into a   -- template. This can be overriden to, for example, cache compiled templates   -- in memory.-  getTemplate :: FilePath -> Controller hs Template+  getTemplate :: FilePath -> ControllerT m hs Template+  default getTemplate :: MonadIO m => FilePath -> ControllerT m hs Template   getTemplate = defaultGetTemplate    -- | Renders a view template with the default layout and a global used to   -- evaluate variables in the template.-  render :: ToJSON a => FilePath -> a -> Controller hs ()+  render :: ToJSON a => FilePath -> a -> ControllerT m hs ()   render = defaultRender    -- | Same as 'render' but without a template.-  renderPlain :: ToJSON a => FilePath -> a -> Controller hs ()+  renderPlain :: ToJSON a => FilePath -> a -> ControllerT m hs ()   renderPlain fp val = do     fm <- functionMap     dir <- viewDirectory@@ -70,13 +72,13 @@     respond $ ok mime pageContent    -- | Render a view using the layout named by the first argument.-  renderLayout :: ToJSON a => FilePath -> FilePath -> a -> Controller hs ()+  renderLayout :: ToJSON a => FilePath -> FilePath -> a -> ControllerT m hs ()   renderLayout lfp fp val = do     layout <- getTemplate lfp     renderLayout' layout fp val    -- | Same as 'renderLayout' but uses an already compiled layout.-  renderLayout' :: ToJSON a => Template -> FilePath -> a -> Controller hs ()+  renderLayout' :: ToJSON a => Template -> FilePath -> a -> ControllerT m hs ()   renderLayout' layout fp val = do     fm <- functionMap     dir <- viewDirectory@@ -86,16 +88,16 @@     respond $ ok mime $ L.fromChunks . (:[]) . encodeUtf8 $       renderTemplate layout fm $ object ["yield" .= pageContent, "page" .= val] -defaultGetTemplate :: HasTemplates hs => FilePath -> Controller hs Template+defaultGetTemplate :: (HasTemplates m hs, MonadIO m)+                   => FilePath -> ControllerT m hs Template defaultGetTemplate fp = do-  eres <- compileTemplate . decodeUtf8 <$>-    liftIO (S.readFile fp)-  case eres of+  contents <- liftIO $ S.readFile fp+  case compileTemplate . decodeUtf8 $ contents of     Left str -> fail str     Right tmpl -> return tmpl -defaultRender :: (HasTemplates hs , ToJSON a)-              => FilePath -> a -> Controller hs ()+defaultRender :: (HasTemplates m hs , Monad m, ToJSON a)+              => FilePath -> a -> ControllerT m hs () defaultRender fp val = do   mlayout <- defaultLayout   case mlayout of
template/Common_hs.tmpl view
@@ -1,3 +1,4 @@+$if(include_templates)${-# LANGUAGE MultiParamTypeClasses #-}$endif$ module $module$.Common where  import Control.Applicative@@ -23,6 +24,6 @@     cs <- controllerState     putState $$ cs { appSession = Just sess } $endif$$if(include_templates)$-instance HasTemplates AppSettings where+instance HasTemplates IO AppSettings where   defaultLayout = Just <$$> getTemplate "layouts/main.html" $endif$
template/package_cabal.tmpl view
@@ -11,10 +11,10 @@   ghc-options: -threaded -O2   build-depends:     base-    , simple >= 0.7.0+    , simple >= 0.8.0     , wai     , wai-extra     , warp$if(include_sessions)$-    , simple-session >= 0.7.0$endif$$if(include_postgresql)$-    , simple-postgresql-orm >= 0.7.0$endif$+    , simple-session >= 0.8.0$endif$$if(include_postgresql)$+    , simple-postgresql-orm >= 0.8.0$endif$