packages feed

simple 0.8.0.1 → 0.8.1.0

raw patch · 6 files changed

+234/−110 lines, 6 filesdep +HUnitdep +hspecdep +mtldep ~wai

Dependencies added: HUnit, hspec, mtl, simple

Dependency ranges changed: wai

Files

simple.cabal view
@@ -1,5 +1,5 @@ name:                simple-version:             0.8.0.1+version:             0.8.1.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -68,6 +68,7 @@     , filepath     , mime-types     , monad-peel+    , mtl     , simple-templates >= 0.7.0     , wai >= 2.0     , wai-extra@@ -90,6 +91,20 @@     Web.Frank,     Web.REST   default-language: Haskell2010++test-suite test-simple+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  build-depends:+      base < 6+    , hspec+    , HUnit+    , monad-peel+    , mtl+    , simple+    , transformers+    , wai  source-repository head   type: git
src/Web/Frank.hs view
@@ -32,30 +32,30 @@  import Network.HTTP.Types import Web.Simple.Controller.Trans-import qualified Data.ByteString as S+import Data.Text (Text)  -- | Helper method frankMethod :: Monad m-            => StdMethod -> S.ByteString -> ControllerT s m a+            => StdMethod -> Text -> 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 s m a -> ControllerT s m ()+get :: Monad m => Text -> 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 s m a -> ControllerT s m ()+post :: Monad m => Text -> 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 s m a -> ControllerT s m ()+put :: Monad m => Text -> 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 s m a -> ControllerT s m ()+delete :: Monad m => Text -> 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 s m a -> ControllerT s m ()+options :: Monad m => Text -> ControllerT s m a -> ControllerT s m () options = frankMethod OPTIONS
src/Web/Simple/Controller.hs view
@@ -24,7 +24,7 @@   -- * Example   -- $Example   -- * Controller Monad-    Controller, T.ControllerT(..), ControllerState+    Controller, T.ControllerT(..)   , controllerApp, controllerState, putState   , request, localRequest, respond   , requestHeader@@ -46,7 +46,7 @@   , fromApp   -- * Low-level utilities   , body-  , hoistEither, ask, local, pass+  , hoistEither   ) where  import           Control.Exception.Peel@@ -57,11 +57,12 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import           Data.Conduit import qualified Data.Conduit.List as CL+import           Data.Text (Text) import           Network.HTTP.Types import           Network.Wai import           Network.Wai.Parse import           Web.Simple.Controller.Trans-                  (ControllerT, ControllerState)+                  (ControllerT) import qualified Web.Simple.Controller.Trans as T import           Web.Simple.Responses @@ -71,55 +72,42 @@ -- of the computation can be short-circuited by 'respond'ing with a 'Response'. type Controller s = ControllerT s IO -hoistEither :: Either Response a -> Controller r a+hoistEither :: Either Response a -> Controller s a hoistEither = T.hoistEither -ask :: Controller r (r, Request)-ask = T.ask- -- | Extract the request-request :: Controller r Request+request :: Controller s Request request = T.request -local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a-local = T.local- -- | Modify the request for the given computation-localRequest :: (Request -> Request) -> Controller r a -> Controller r a+localRequest :: (Request -> Request) -> Controller s a -> Controller s a localRequest = T.localRequest  -- | Extract the application-specific state-controllerState :: Controller r r+controllerState :: Controller s s controllerState = T.controllerState -putState :: r -> Controller r ()+putState :: s -> Controller s () putState = T.putState  -- | Convert the controller into an 'Application'-controllerApp :: r -> Controller r a -> Application+controllerApp :: s -> Controller s a -> Application controllerApp = T.controllerApp --- | Decline to handle the request------ @pass >> c === c@--- @c >> pass === c@-pass :: Controller r ()-pass = T.pass- -- | Provide a response -- -- @respond r >>= f === respond r@-respond :: Response -> Controller r a+respond :: Response -> Controller s a respond = T.respond   -- | Lift an application to a controller-fromApp :: Application -> Controller r ()+fromApp :: Application -> Controller s () 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 :: S.ByteString -> Controller s a -> Controller s () routeHost = T.routeHost  -- | Matches if the path is empty.@@ -127,15 +115,15 @@ -- 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 :: Controller r a -> Controller r ()+routeTop :: Controller s a -> Controller s () routeTop = T.routeTop  -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')-routeMethod :: StdMethod -> Controller r a -> Controller r ()+routeMethod :: StdMethod -> Controller s a -> Controller s () routeMethod = T.routeMethod  -- | Matches if the request's Content-Type exactly matches the given string-routeAccept :: S8.ByteString -> Controller r a -> Controller r ()+routeAccept :: S8.ByteString -> Controller s a -> Controller s () routeAccept = T.routeAccept  -- | Routes the given URL pattern. Patterns can include@@ -148,17 +136,17 @@ -- --  * \/:date\/posts\/:category\/new ---routePattern :: S.ByteString -> Controller r a -> Controller r ()+routePattern :: Text -> Controller s a -> Controller s () routePattern = T.routePattern  -- | Matches if the first directory in the path matches the given 'ByteString'-routeName :: S.ByteString -> Controller r a -> Controller r ()+routeName :: Text -> Controller s a -> Controller s () 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 :: Text -> Controller s a -> Controller s () routeVar = T.routeVar  --@@ -175,37 +163,37 @@ -- would return @Nothing@. queryParam :: T.Parseable a            => S8.ByteString -- ^ Parameter name-           -> Controller r (Maybe a)+           -> Controller s (Maybe a) queryParam = T.queryParam  -- | Like 'queryParam', but throws an exception if the parameter is not present. queryParam' :: T.Parseable a-            => S.ByteString -> Controller r a+            => S.ByteString -> Controller s a queryParam' = T.queryParam'  -- | Selects all values with the given parameter name queryParams :: T.Parseable a-            => S.ByteString -> Controller r [a]+            => S.ByteString -> Controller s [a] 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)+               -> Controller s (Maybe a) 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+                -> Controller s a 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                 => S8.ByteString -- ^ Parameter name-                -> Controller r [a]+                -> Controller s [a] readQueryParams = T.readQueryParams  -- | Parses a HTML form from the request body. It returns a list of 'Param's as@@ -224,31 +212,31 @@ --         respond $ redirectTo \"/\" --       Nothing -> redirectBack -- @-parseForm :: Controller r ([Param], [(S.ByteString, FileInfo L.ByteString)])+parseForm :: Controller s ([Param], [(S.ByteString, FileInfo L.ByteString)]) parseForm = do   req <- request   liftIO $ parseRequestBody lbsBackEnd req  -- | Reads and returns the body of the HTTP request.-body :: Controller r L8.ByteString+body :: Controller s L8.ByteString body = do   req <- request   liftIO $ L8.fromChunks `fmap` (requestBody req $$ CL.consume)  -- | Returns the value of the given request header or 'Nothing' if it is not -- present in the HTTP request.-requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)+requestHeader :: HeaderName -> Controller s (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 :: Controller r a+redirectBack :: Controller s 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 a+               -> Controller s a redirectBackOr def = do   mrefr <- requestHeader "referer"   case mrefr of
src/Web/Simple/Controller/Trans.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}  {- | 'ControllerT' provides a convenient syntax for writting 'Application'   code as a Monadic action with access to an HTTP request as well as app@@ -22,12 +23,14 @@ -} module Web.Simple.Controller.Trans where +import           Control.Monad hiding (guard) import           Control.Monad.IO.Class import           Control.Monad.IO.Peel+import           Control.Monad.Reader.Class+import           Control.Monad.State.Class import           Control.Monad.Trans.Class 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)@@ -41,91 +44,89 @@ 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 s m a = ControllerT-  { runController :: ControllerState s ->-                      m (Either Response a, ControllerState s) }+  { runController :: s -> Request ->+                      m (Either Response a, s) } -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 Functor m => Functor (ControllerT s m) where+  fmap f (ControllerT act) = ControllerT $ \st0 req ->+    go `fmap` act st0 req+    where go (eaf, st) = case eaf of+                              Left resp -> (Left resp, st)+                              Right result -> (Right $ f result, st) -instance (Monad m, Applicative m) => Applicative (ControllerT s m) where+instance (Monad m, Functor m) => Applicative (ControllerT s m) where   pure = return   (<*>) = ap  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+  return a = ControllerT $ \st _ -> return $ (Right a, st)+  (ControllerT act) >>= fn = ControllerT $ \st0 req -> do+    (eres, st) <- act st0 req     case eres of       Left resp -> return (Left resp, st)       Right result -> do         let (ControllerT fres) = fn result-        fres st+        fres st req +instance (Functor m, Monad m) => Alternative (ControllerT s m) where+  empty = respond notFound+  (<|>) = (>>)++instance Monad m => MonadPlus (ControllerT s m) where+  mzero = respond notFound+  mplus = flip (>>)+ instance MonadTrans (ControllerT s) where-  lift act = ControllerT $ \st -> act >>= \r -> return (Right r, st)+  lift act = ControllerT $ \st _ -> act >>= \r -> return (Right r, st) +instance Monad m => MonadState s (ControllerT s m) where+  get = ControllerT $ \s _ -> return (Right s, s)+  put s = ControllerT $ \_ _ -> return (Right (), s)++instance Monad m => MonadReader Request (ControllerT s m) where+  ask = ControllerT $ \st req -> return (Right req, st)+  local f (ControllerT act) = ControllerT $ \st req -> act st (f req)+ instance MonadIO m => MonadIO (ControllerT s m) where   liftIO = lift . liftIO  instance MonadPeelIO (ControllerT s IO) where   peelIO = do-    r <- controllerState+    s <- controllerState     req <- request     return $ \ctrl -> do-      res <- fst `fmap` runController ctrl (r, req)-      return $ hoistEither res+      res <- runController ctrl s req+      return $ ControllerT $ \_ _ -> return res  hoistEither :: Monad m => Either Response a -> ControllerT s m a-hoistEither eith = ControllerT $ \st -> return (eith, st)--ask :: Monad m => ControllerT s m (s, Request)-ask = ControllerT $ \rd -> return (Right rd, rd)+hoistEither eith = ControllerT $ \st _ -> return (eith, st)  -- | Extract the request request :: Monad m => ControllerT s m Request-request = liftM snd ask--local :: Monad m-      => ((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))+request = ask  -- | Modify the request for the given computation localRequest :: Monad m              => (Request -> Request) -> ControllerT s m a -> ControllerT s m a-localRequest f = local (\(r,req) -> (r, f req))+localRequest = local  -- | Extract the application-specific state controllerState :: Monad m => ControllerT s m s-controllerState = liftM fst ask+controllerState = get  putState :: Monad m => s -> ControllerT s m ()-putState r = ControllerT $ \(_, req) -> return (Right (), (r, req))+putState = put  -- | Convert the controller into an 'Application' controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m-controllerApp r ctrl req =-  runController ctrl (r, req) >>=+controllerApp s ctrl req =+  runController ctrl s req >>=     either return (const $ return notFound) . fst --- | Decline to handle the request------ @pass >> c === c@--- @c >> pass === c@-pass :: Monad m => ControllerT s m ()-pass = ControllerT $ \st -> return (Right (), st)- -- | Provide a response -- -- @respond r >>= f === respond r@@@ -144,7 +145,7 @@ -- exact matches. routeHost :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () routeHost host = guardReq $ \req ->-  host == (fromMaybe "" $ requestHeaderHost req)+  Just host == requestHeaderHost req  -- | Matches if the path is empty. --@@ -175,36 +176,37 @@ --  * \/:date\/posts\/:category\/new -- routePattern :: Monad m-             => S.ByteString -> ControllerT s m a -> ControllerT s m ()+             => Text -> ControllerT s m a -> ControllerT s m () routePattern pattern route =-  let patternParts = map T.unpack $ decodePathSegments pattern+  let patternParts = decodePathSegments (T.encodeUtf8 pattern)   in foldr mkRoute (route >> return ()) patternParts-  where mkRoute (':':varName) = routeVar (S8.pack varName)-        mkRoute name = routeName (S8.pack name)+  where mkRoute name = case T.uncons name of+                            Just (':', varName) -> routeVar varName+                            _ -> routeName name  -- | Matches if the first directory in the path matches the given 'ByteString'-routeName :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m ()+routeName :: Monad m => Text -> 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+  if (length $ pathInfo req) > 0 && name == (head . pathInfo) req     then localRequest popHdr next >> return ()-    else pass+    else return ()   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 s m a -> ControllerT s m ()+routeVar :: Monad m => Text -> ControllerT s m a -> ControllerT s m () routeVar varName next = do   req <- request   case pathInfo req of-    [] -> pass-    x:_ | T.null x -> pass+    [] -> return ()+    x:_ | T.null x -> return ()         | 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+            , queryString = (T.encodeUtf8 varName, Just (varVal req)):(queryString req)}+        varVal req = T.encodeUtf8 . head . pathInfo $ req  -- -- query parameters@@ -314,7 +316,7 @@ -- guard  guard :: Monad m => Bool -> ControllerT s m a -> ControllerT s m ()-guard b c = if b then c >> return () else pass+guard b c = if b then c >> return () else return ()  guardM :: Monad m        => ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
src/Web/Simple/Static.hs view
@@ -16,9 +16,6 @@   let fp = foldl (</>) baseDir (map T.unpack $ pathInfo req)   exists <- liftIO $ doesFileExist fp   when exists $ do-    liftIO $ do-      modTime <- getModificationTime fp-      print modTime     respond $ responseFile status200       [(hContentType, defaultMimeLookup $ T.pack $ takeFileName fp)]       fp Nothing
+ test/Spec.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Peel+import Control.Monad.Trans+import Test.Hspec+import Test.Hspec.HUnit+import Network.Wai+import Web.Simple.Controller.Trans+import Web.Simple.Responses++main :: IO ()+main = hspec $ do+  describe "ControllerT#routeName" $ do+    it "matches route when name is correct" $ do+      let ctrl =  do+            routeName "hello" $ respond $ okHtml ""+            lift $ expectationFailure "Path should have matched"+      controllerApp () ctrl $ defaultRequest { pathInfo = ["hello"] }+      return ()+    it "doesn't match route when name is incorrect" $ do+      let ctrl =  do+            routeName "yello" $+              lift $ expectationFailure "Path should have matched"+      controllerApp () ctrl $ defaultRequest { pathInfo = ["hello"] }+      return ()+    it "doesn't match route when path is empty" $ do+      let ctrl =  do+            routeName "yello" $+              lift $ expectationFailure "Path should have matched"+      controllerApp () ctrl $ defaultRequest { pathInfo = [] }+      return ()+    it "pops one directory from pathInfo when inside block" $ do+      let ctrl =  do+            routeName "hello" $ do+              pi <- pathInfo `fmap` request+              lift $ pi `shouldBe` ["world"]+            pi <- pathInfo `fmap` request+            lift $ pi `shouldBe` ["hello", "world"]+      controllerApp () ctrl $+        defaultRequest { pathInfo = ["hello", "world"] }+      return ()+  describe "ControllerT#routeVar" $ do+    it "matches route if pathInfo not empty" $ do+      let ctrl =  do+            routeVar "hello" $ respond $ okHtml ""+            lift $ expectationFailure "Path should have matched"+      controllerApp () ctrl $ defaultRequest { pathInfo = ["blarg"] }+      return ()+    it "doesn't match route when path is empty" $ do+      let ctrl =  do+            routeVar "yello" $+              lift $ expectationFailure "Path should have matched"+      controllerApp () ctrl $ defaultRequest { pathInfo = [] }+      return ()+    it "queues value of first path directory in query param" $ do+      let ctrl =  do+            routeVar "foo" $ do+              qs <- queryParam "foo"+              lift $ qs `shouldBe` Just ("hello" :: String)+      controllerApp () ctrl $+        defaultRequest { pathInfo = ["hello", "world"] }+      return ()+    it "pops one directory from pathInfo when inside block" $ do+      let ctrl =  do+            routeVar "foo" $ do+              pi <- pathInfo `fmap` request+              lift $ pi `shouldBe` ["world"]+            pi <- pathInfo `fmap` request+            lift $ pi `shouldBe` ["hello", "world"]+      controllerApp () ctrl $+        defaultRequest { pathInfo = ["hello", "world"] }+      return ()+  describe "ControllerT#routeTop" $ do+    it "matches when path is empty" $ do+      let ctrl =  do+            routeTop $ respond $ okHtml "Yey!"+            lift $ expectationFailure "Top should have matched"+      controllerApp () ctrl $+        defaultRequest+      return ()+    it "fails when path is not empty" $ do+      let ctrl =  do+            routeTop $ lift $ expectationFailure "Top should not have matched"+      controllerApp () ctrl $+        defaultRequest { pathInfo = ["blah"] }+      return ()+  describe "ControllerT#routeHost" $ do+    it "matches when host header is the same" $ do+      let ctrl =  do+            routeHost "www.example.com" $ respond $ okHtml "Yey!"+            lift $ expectationFailure "Host should have matched"+      controllerApp () ctrl $+        defaultRequest { requestHeaderHost = Just "www.example.com" }+      return ()+    it "fails when host header is not the same" $ do+      let ctrl =  do+            routeHost "www.example2.com" $ do+              lift $ expectationFailure "Host should not have matched"+      controllerApp () ctrl $+        defaultRequest { requestHeaderHost = Just "www.example.com" }+      return ()+    it "fails when host header is not present" $ do+      let ctrl =  do+            routeHost "www.example.com" $ do+              lift $ expectationFailure "Host should not have matched"+      controllerApp () ctrl $+        defaultRequest { requestHeaderHost = Nothing }+      return ()++  describe "MonadPeelIO instance" $ do+    it "Preserves state changes in inner block" $ do+      let expected = 1234+          ctrl = do+                  k <- peelIO+                  join $ liftIO $ k $ do+                    putState expected+      s <- snd `fmap` runController ctrl 0 defaultRequest+      s `shouldBe` expected+