packages feed

simple 0.8.0.0 → 0.8.0.1

raw patch · 6 files changed

+85/−84 lines, 6 files

Files

simple.cabal view
@@ -1,5 +1,5 @@ name:                simple-version:             0.8.0.0+version:             0.8.0.1 synopsis: A minimalist web framework for the WAI server interface description:
src/Web/Frank.hs view
@@ -36,26 +36,26 @@  -- | Helper method frankMethod :: Monad m-            => StdMethod -> S.ByteString -> ControllerT m r a-            -> ControllerT m r ()+            => StdMethod -> S.ByteString -> ControllerT s m a+            -> ControllerT s m () frankMethod method pattern = routeMethod method . routePattern pattern . routeTop  -- | Matches the GET method on the given URL pattern-get :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+get :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () get = frankMethod GET  -- | Matches the POST method on the given URL pattern-post :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+post :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () post = frankMethod POST  -- | Matches the PUT method on the given URL pattern-put :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+put :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () put = frankMethod PUT  -- | Matches the DELETE method on the given URL pattern-delete :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+delete :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () delete = frankMethod DELETE  -- | Matches the OPTIONS method on the given URL pattern-options :: Monad m => S.ByteString -> ControllerT m r a -> ControllerT m r ()+options :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () options = frankMethod OPTIONS
src/Web/REST.hs view
@@ -20,18 +20,18 @@ import Network.HTTP.Types  -- | 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 ()+data REST m s = REST+  { restIndex   :: ControllerT s m ()+  , restShow    :: ControllerT s m ()+  , restCreate  :: ControllerT s m ()+  , restUpdate  :: ControllerT s m ()+  , restDelete  :: ControllerT s m ()+  , restEdit    :: ControllerT s m ()+  , restNew     :: ControllerT s m ()   }  -- | Default state, returns @404@ for all verbs.-defaultREST :: Monad m => REST m r+defaultREST :: Monad m => REST m s defaultREST = REST   { restIndex   = respond $ notFound   , restShow    = respond $ notFound@@ -48,7 +48,7 @@ rest :: Monad m => RESTControllerM m r a -> REST m r rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST -routeREST :: Monad m => REST m r -> ControllerT m r ()+routeREST :: Monad m => REST m s -> ControllerT s m () routeREST rst = do   routeMethod GET $ do     routeTop $ restIndex rst@@ -66,37 +66,37 @@ type RESTController m r = RESTControllerM m r ()  -- | GET \/-index :: ControllerT m r () -> RESTController m r+index :: ControllerT s m () -> RESTController m s index route = modify $ \controller ->   controller { restIndex = route }  -- | POST \/-create :: ControllerT m r () -> RESTController m r+create :: ControllerT s m () -> RESTController m s create route = modify $ \controller ->   controller { restCreate = route }  -- | GET \/:id\/edit-edit :: ControllerT m r () -> RESTController m r+edit :: ControllerT s m () -> RESTController m s edit route = modify $ \controller ->   controller { restEdit = route }  -- | GET \/new-new :: ControllerT m r () -> RESTController m r+new :: ControllerT s m () -> RESTController m s new route = modify $ \controller ->   controller { restNew = route }  -- | GET \/:id-show :: ControllerT m r () -> RESTController m r+show :: ControllerT s m () -> RESTController m s show route = modify $ \controller ->   controller { restShow = route }  -- | PUT \/:id-update :: ControllerT m r () -> RESTController m r+update :: ControllerT s m () -> RESTController m s update route = modify $ \controller ->   controller { restUpdate = route }  -- | DELETE \/:id-delete :: ControllerT m r () -> RESTController m r+delete :: ControllerT s m () -> RESTController m s delete route = modify $ \controller ->   controller { restDelete = route }
src/Web/Simple/Controller.hs view
@@ -69,7 +69,7 @@ -- | 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'.-type Controller = ControllerT IO+type Controller s = ControllerT s IO  hoistEither :: Either Response a -> Controller r a hoistEither = T.hoistEither@@ -242,13 +242,13 @@  -- | Redirect back to the referer. If the referer header is not present -- redirect to root (i.e., @\/@).-redirectBack :: Controller r ()+redirectBack :: Controller r a redirectBack = redirectBackOr (redirectTo "/")  -- | Redirect back to the referer. If the referer header is not present -- fallback on the given 'Response'. redirectBackOr :: Response -- ^ Fallback response-               -> Controller r ()+               -> Controller r a redirectBackOr def = do   mrefr <- requestHeader "referer"   case mrefr of
src/Web/Simple/Controller/Trans.hs view
@@ -24,6 +24,7 @@  import           Control.Monad.IO.Class import           Control.Monad.IO.Peel+import           Control.Monad.Trans.Class import           Control.Applicative import           Control.Exception.Peel import           Control.Monad hiding (guard)@@ -45,22 +46,22 @@ -- | 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) }+newtype ControllerT s m a = ControllerT+  { runController :: ControllerState s ->+                      m (Either Response a, ControllerState s) } -instance (Monad m, Functor m) => Functor (ControllerT m r) where+instance (Monad m, Functor m) => Functor (ControllerT s m) 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+instance (Monad m, Applicative m) => Applicative (ControllerT s m) where   pure = return   (<*>) = ap -instance Monad m => Monad (ControllerT m r) where+instance Monad m => Monad (ControllerT s m) where   return a = ControllerT $ \st -> return $ (Right a, st)   (ControllerT act) >>= fn = ControllerT $ \st0 -> do     (eres, st) <- act st0@@ -70,10 +71,13 @@         let (ControllerT fres) = fn result         fres st -instance MonadIO m => MonadIO (ControllerT m r) where-  liftIO = liftC . liftIO+instance MonadTrans (ControllerT s) where+  lift act = ControllerT $ \st -> act >>= \r -> return (Right r, st) -instance MonadPeelIO (ControllerT IO r) where+instance MonadIO m => MonadIO (ControllerT s m) where+  liftIO = lift . liftIO++instance MonadPeelIO (ControllerT s IO) where   peelIO = do     r <- controllerState     req <- request@@ -81,39 +85,36 @@       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 :: Monad m => Either Response a -> ControllerT s m a hoistEither eith = ControllerT $ \st -> return (eith, st) -ask :: Monad m => ControllerT m r (r, Request)+ask :: Monad m => ControllerT s m (s, Request) ask = ControllerT $ \rd -> return (Right rd, rd)  -- | Extract the request-request :: Monad m => ControllerT m r Request+request :: Monad m => ControllerT s m Request request = liftM snd ask  local :: Monad m-      => ((r, Request) -> (r, Request)) -> ControllerT m r a -> ControllerT m r a+      => ((s, Request) -> (s, Request)) -> ControllerT s m a -> ControllerT s m 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+             => (Request -> Request) -> ControllerT s m a -> ControllerT s m a localRequest f = local (\(r,req) -> (r, f req))  -- | Extract the application-specific state-controllerState :: Monad m => ControllerT m r r+controllerState :: Monad m => ControllerT s m s controllerState = liftM fst ask -putState :: Monad m => r -> ControllerT m r ()+putState :: Monad m => s -> ControllerT s m () 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 :: Monad m => s -> ControllerT s m a -> SimpleApplication m controllerApp r ctrl req =   runController ctrl (r, req) >>=     either return (const $ return notFound) . fst@@ -122,26 +123,26 @@ -- -- @pass >> c === c@ -- @c >> pass === c@-pass :: Monad m => ControllerT m r ()+pass :: Monad m => ControllerT s m () pass = ControllerT $ \st -> return (Right (), st)  -- | Provide a response -- -- @respond r >>= f === respond r@-respond :: Monad m => Response -> ControllerT m r a+respond :: Monad m => Response -> ControllerT s m a respond resp = hoistEither $ Left resp   -- | Lift an application to a controller-fromApp :: Monad m => (Request -> m Response) -> ControllerT m r ()+fromApp :: Monad m => (Request -> m Response) -> ControllerT s m () fromApp app = do   req <- request-  resp <- liftC $ app req+  resp <- lift $ 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 :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () routeHost host = guardReq $ \req ->   host == (fromMaybe "" $ requestHeaderHost req) @@ -150,16 +151,16 @@ -- 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 :: Monad m => ControllerT s m a -> ControllerT s m () 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 :: Monad m => StdMethod -> ControllerT s m a -> ControllerT s m () 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 :: Monad m => S8.ByteString -> ControllerT s m a -> ControllerT s m () routeAccept contentType = guardReq (isJust . find matching . requestHeaders)  where matching hdr = fst hdr == hAccept && snd hdr == contentType @@ -174,7 +175,7 @@ --  * \/:date\/posts\/:category\/new -- routePattern :: Monad m-             => S.ByteString -> ControllerT m r a -> ControllerT m r ()+             => S.ByteString -> ControllerT s m a -> ControllerT s m () routePattern pattern route =   let patternParts = map T.unpack $ decodePathSegments pattern   in foldr mkRoute (route >> return ()) patternParts@@ -182,7 +183,7 @@         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 :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () routeName name next = do   req <- request   if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req@@ -193,7 +194,7 @@ -- | 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 :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () routeVar varName next = do   req <- request   case pathInfo req of@@ -219,7 +220,7 @@ -- would return @Nothing@. queryParam :: (Monad m, Parseable a)            => S8.ByteString -- ^ Parameter name-           -> ControllerT m r (Maybe a)+           -> ControllerT s m (Maybe a) queryParam varName = do   qr <- liftM queryString request   return $ case lookup varName qr of@@ -228,13 +229,13 @@  -- | Like 'queryParam', but throws an exception if the parameter is not present. queryParam' :: (Monad m, Parseable a)-            => S.ByteString -> ControllerT m r a+            => S.ByteString -> ControllerT s m 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]+            => S.ByteString -> ControllerT s m [a] queryParams varName = request >>= return .                                   map (parse . fromMaybe S.empty . snd) .                                   filter ((== varName) . fst) .@@ -255,14 +256,14 @@ -- If that conversion fails, an exception is thrown. readQueryParam :: (Monad m, Read a)                => S8.ByteString -- ^ Parameter name-               -> ControllerT m r (Maybe a)+               -> ControllerT s m (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+                -> ControllerT s m a readQueryParam' varName =   queryParam' varName >>= readParamValue varName @@ -270,12 +271,12 @@ -- If any read-conversion fails, an exception is thrown. readQueryParams :: (Monad m, Read a)                 => S8.ByteString -- ^ Parameter name-                -> ControllerT m r [a]+                -> ControllerT s m [a] readQueryParams varName =   queryParams varName >>= mapM (readParamValue varName)  readParamValue :: (Monad m, Read a)-               => S8.ByteString -> Text -> ControllerT m r a+               => S8.ByteString -> Text -> ControllerT s m a readParamValue varName =   maybe (err $ "cannot read parameter: " ++ show varName) return .     readMay . T.unpack@@ -285,19 +286,19 @@  -- | 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 :: Monad m => HeaderName -> ControllerT s m (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 :: Monad m => ControllerT s m () 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 ()+               -> ControllerT s m () redirectBackOr def = do   mrefr <- requestHeader "referer"   case mrefr of@@ -312,15 +313,15 @@  -- guard -guard :: Monad m => Bool -> ControllerT m r a -> ControllerT m r ()+guard :: Monad m => Bool -> ControllerT s m a -> ControllerT s m () guard b c = if b then c >> return () else pass  guardM :: Monad m-       => ControllerT m r Bool -> ControllerT m r a -> ControllerT m r ()+       => ControllerT s m Bool -> ControllerT s m a -> ControllerT s m () guardM b c = b >>= flip guard c  guardReq :: Monad m-         => (Request -> Bool) -> ControllerT m r a -> ControllerT m r ()+         => (Request -> Bool) -> ControllerT s m a -> ControllerT s m () guardReq f = guardM (liftM f request)  data ControllerException = ControllerException String@@ -331,7 +332,7 @@  instance Exception ControllerException -err :: String -> ControllerT m r a+err :: String -> ControllerT s m a err = throw . ControllerException  {- $Example
src/Web/Simple/Templates.hs view
@@ -27,7 +27,7 @@   -- 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 :: ControllerT m hs (Maybe Template)+  defaultLayout :: ControllerT hs m (Maybe Template)   defaultLayout = return Nothing    -- | The directory to look for views passed to 'render'. This defaults to@@ -38,29 +38,29 @@   -- @   --   -- will look for a view template in \"views/index.html.tmpl\".-  viewDirectory :: ControllerT m hs FilePath+  viewDirectory :: ControllerT hs m FilePath   viewDirectory = return "views"    -- | A map of pure functions that can be called from within a template. See   -- 'FunctionMap' and 'Function' for details.-  functionMap :: ControllerT m hs FunctionMap+  functionMap :: ControllerT hs m 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 -> ControllerT m hs Template-  default getTemplate :: MonadIO m => FilePath -> ControllerT m hs Template+  getTemplate :: FilePath -> ControllerT hs m Template+  default getTemplate :: MonadIO m => FilePath -> ControllerT hs m 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 -> ControllerT m hs ()+  render :: ToJSON a => FilePath -> a -> ControllerT hs m ()   render = defaultRender    -- | Same as 'render' but without a template.-  renderPlain :: ToJSON a => FilePath -> a -> ControllerT m hs ()+  renderPlain :: ToJSON a => FilePath -> a -> ControllerT hs m ()   renderPlain fp val = do     fm <- functionMap     dir <- viewDirectory@@ -72,13 +72,13 @@     respond $ ok mime pageContent    -- | Render a view using the layout named by the first argument.-  renderLayout :: ToJSON a => FilePath -> FilePath -> a -> ControllerT m hs ()+  renderLayout :: ToJSON a => FilePath -> FilePath -> a -> ControllerT hs m ()   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 -> ControllerT m hs ()+  renderLayout' :: ToJSON a => Template -> FilePath -> a -> ControllerT hs m ()   renderLayout' layout fp val = do     fm <- functionMap     dir <- viewDirectory@@ -89,7 +89,7 @@       renderTemplate layout fm $ object ["yield" .= pageContent, "page" .= val]  defaultGetTemplate :: (HasTemplates m hs, MonadIO m)-                   => FilePath -> ControllerT m hs Template+                   => FilePath -> ControllerT hs m Template defaultGetTemplate fp = do   contents <- liftIO $ S.readFile fp   case compileTemplate . decodeUtf8 $ contents of@@ -97,7 +97,7 @@     Right tmpl -> return tmpl  defaultRender :: (HasTemplates m hs , Monad m, ToJSON a)-              => FilePath -> a -> ControllerT m hs ()+              => FilePath -> a -> ControllerT hs m () defaultRender fp val = do   mlayout <- defaultLayout   case mlayout of