diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,33 +1,3 @@ -* 0.1.4.0 Daniel Pattersion 2015-11-4 - - - Move `ctxt` back to first parameter passed to handlers, via more - continuations. - -* 0.1.3.1 Daniel Pattersion 2015-10-31 - - - Add `method` matcher to match against HTTP method. - -* 0.1.3.0 Daniel Patterson 2015-10-30 - - - Allow nested calls to `route`, by changing `Request` in - `ctxt`. This necesitated changing it so that the `ctxt` is passed - to handlers _last_, instead of first, because we need to have - completed matching before we can change the request. - - Add `anything` route matcher that matches anything. - - Add `paramMany` matcher that returns a list of values for the - given query param. - - Change `param` to fail if more than one value is in query string. - -* 0.1.2.0 Daniel Pattersion 2015-10-27 - - Rename `paramOptional` to `paramOpt`, to match `fn-extra`'s `Heist` - naming of `attr` and `attrOpt`. Remove `paramPresent`, because you - can get that behavior by parsing to `Text`. - -* 0.1.1.0 Daniel Patterson 2015-10-26 - - Rename `Param` class to `FromParam`. - * 0.1.0.0 Daniel Patterson 2015-10-25 Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,7 +46,52 @@ index :: IO (Maybe Response) index = okText "This is the index page! Try /foo/bar/baz?id=10" -handler :: Text -> Int -> Ctxt -> IO (Maybe Response) -handler fragment i _ = okText (fragment <> " - " <> T.pack (show i)) +handler :: Ctxt -> Text -> Int -> IO (Maybe Response) +handler _ fragment i = okText (fragment <> " - " <> T.pack (show i)) ``` + +## Recommended Pairings + +Part of the design of `Fn` is that you won't need a suite of `fn-foo` +libraries that generally serve to adapt the functions from `foo` to +the monad transformer stack of the web framework of choice (we may add +an `fn-extra` package with a few helpers in it in the future, but it'll +be small). Still, it's helpful to know what are common tools that are +well designed and tested, so here are a list (those marked with `[*]` +are used in the example application included in the repository): + +- [warp](http://hackage.haskell.org/package/warp)`[*]`: perhaps obvious, + but you will need to choose an HTTP server to use with your `Fn` + application, and `warp` is the defacto standard for applications that + use the `WAI` interface that `Fn` does. +- [heist](http://hackage.haskell.org/package/heist)`[*]`: a wonderful + templating system that is both really simple (the templates are just + html) and powerful (any html tag can be bound to run haskell + code). This may be the one place where we may add some adaptors, as + it would be wonderful to have splices (those haskell-bound html + tags) that were normal functions, rather than monadic. +- [postgresql-simple](https://hackage.haskell.org/package/postgresql-simple)`[*]`: + a well designed interface to PostgreSQL; ofter the lower level way + to interact with the database (setting up connections, etc), if you + use a higher level, safer abstraction like `opaleye` (below) for actual + queries. Use it with + [resource-pool](https://hackage.haskell.org/package/resource-pool)`[*]` + to have it manage many connections. +- [opaleye](https://hackage.haskell.org/package/opaleye): a type-safe + composable way to write database queries against PostgreSQL. +- [hedis](https://hackage.haskell.org/package/hedis)`[*]`: a full-featured + client for the key-value store Redis. +- [logging](https://hackage.haskell.org/package/logging)`[*]`: a simple + library for writing log messages, which allow you to change the + logging level and suppress some subset of messages. +- [hspec](https://hackage.haskell.org/package/hspec)`[*]`: a + full-featured testing framework. Use with + [hspec-wai](https://hackage.haskell.org/package/hspec-wai)`[*]` - + though the latter could use some work to make it do everything it + needs to! +- [wai-session](https://hackage.haskell.org/package/wai-session)`[*]`: + Combine with something like + [wai-session-clientsession](https://hackage.haskell.org/package/wai-session-clientsession)`[*]` + to store session data in encrypted cookies (like, who a user is + logged in as). diff --git a/fn.cabal b/fn.cabal --- a/fn.cabal +++ b/fn.cabal @@ -1,57 +1,7 @@ name: fn -version: 0.0.0.0 +version: 0.1.0.0 synopsis: A functional web framework. -description: - A Haskell web framework where web handlers are functions with parameters - that are typed arguments. - . - > {-# LANGUAGE OverloadedStrings #-} - > . - > import Data.Monoid ((<>)) - > import Network.Wai (Request, defaultRequest) - > import Network.Wai.Handler.Warp (run) - > import Web.Fn - > . - > data Ctxt = Ctxt { req :: Request } - > instance RequestContext Ctxt where - > getRequest = req - > setRequest c r = c { req = r } - > . - > main :: IO () - > main = do - > run 3000 $ toWAI (Ctxt defaultRequest) $ route - > [ end ==> indexH - > , path "echo" // param "msg" ==> echoH - > , path "echo" // segment ==> echoH - > ] - > . - > indexH :: Ctxt -> IO (Maybe Response) - > indexH _ = okText "Try visiting /echo?msg='hello' or /echo/hello" - > . - > echoH :: Ctxt -> Text -> IO (Maybe Response) - > echoH _ msg = okText $ "Echoing \"" <> msg <> "\"." - . - Fn is a simple way to write web applications in Haskell where the code - handling web requests looks just like any Haskell code. - . - * An application has some "context", which must contain a @Request@, - but can contain other data as well, like database connection pools, etc. - . - * Routes are declared, which allow you to capture parameters and parts - of the url and match them against handler functions of the appropriate - type. - . - * All handlers take the context and the specified number and type of - parameters. - . - * Is a thin wrapper around the WAI interface, so anything you can do - with WAI, you can do with Fn. - . - The name comes from the fact that Fn emphasizes functions, and has no Fn - monad (necessary context, as well as parameters, are passed as arguments, - and the return value, which is plain-old IO, specifies whether routing - should continue on). - +description: Please see README. homepage: http://github.com/dbp/fn#readme license: ISC license-file: LICENSE @@ -68,8 +18,7 @@ hs-source-dirs: src exposed-modules: Web.Fn build-depends: base >= 4.7 && < 5 - , wai >= 3 - , wai-extra >= 3 + , wai , http-types , text , blaze-builder @@ -87,7 +36,6 @@ , text , http-types , wai - , wai-extra ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/src/Web/Fn.hs b/src/Web/Fn.hs --- a/src/Web/Fn.hs +++ b/src/Web/Fn.hs @@ -33,14 +33,11 @@ , (/?) , path , end - , anything , segment - , method - , FromParam(..) - , ParamError(..) + , Param(..) , param - , paramMany - , paramOpt + , paramOptional + , paramPresent -- * Responses , okText , okHtml @@ -53,14 +50,15 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as B import Data.ByteString (ByteString) -import Data.Either (rights) +import Data.List (find) import Data.Maybe (fromJust) +import Data.Monoid ((<>)) import Data.Text (Text) +import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Text.Read (decimal, double) import Network.HTTP.Types import Network.Wai -import Network.Wai.Parse (File, Param) data Store b a = Store b (b -> a) instance Functor (Store b) where @@ -132,7 +130,7 @@ Just response -> return (Just response) -- | The parts of the path, when split on /, and the query. -type Req = ([Text], Query, StdMethod, Maybe ([Param], [File ByteString])) +type Req = ([Text], Query) -- | The connective between route patterns and the handler that will -- be called if the pattern matches. The type is not particularly @@ -140,138 +138,125 @@ -- patterns with varying numbers (and types) of parts with functions -- of the corresponding number of arguments and types. (==>) :: RequestContext ctxt => - (Req -> Maybe (Req, k -> a)) -> + (Req -> k -> Maybe (Req, a)) -> (ctxt -> k) -> - ctxt -> - Maybe a + ctxt -> Maybe a (match ==> handle) ctxt = let r = getRequest ctxt - m = either (const GET) id (parseMethod (requestMethod r)) - x = (pathInfo r, queryString r, m, Nothing) - in case match x of + x = (pathInfo r, queryString r) + in case match x (handle ctxt) of Nothing -> Nothing - Just ((pathInfo',_,_,_), k) -> Just (k $ handle (setRequest ctxt ((getRequest ctxt) { pathInfo = pathInfo' }))) + Just (_, action) -> Just action -- | Connects two path segments. Note that when normally used, the -- type parameter r is 'Req'. It is more general here to facilitate -- testing. -(//) :: (r -> Maybe (r, k -> k')) -> - (r -> Maybe (r, k' -> a)) -> - r -> Maybe (r, k -> a) -(match1 // match2) req = - case match1 req of +(//) :: (r -> k -> Maybe (r, k')) -> + (r -> k' -> Maybe (r, a)) -> + r -> + k -> Maybe (r, a) +(match1 // match2) req k = + case match1 req k of Nothing -> Nothing - Just (req', k) -> case match2 req' of - Nothing -> Nothing - Just (req'', k') -> Just (req'', k' . k) + Just (req', k') -> match2 req' k' -- | Identical to '(//)', provided simply because it serves as a -- nice visual difference when switching from 'path'/'segment' to -- 'param' and friends. -(/?) :: (r -> Maybe (r, k -> k')) -> - (r -> Maybe (r, k' -> a)) -> - r -> Maybe (r, k -> a) +(/?) :: (r -> k -> Maybe (r, k')) -> + (r -> k' -> Maybe (r, a)) -> + r -> + k -> Maybe (r, a) (/?) = (//) -- | Matches a literal part of the path. If there is no path part -- left, or the next part does not match, the whole match fails. -path :: Text -> Req -> Maybe (Req, a -> a) -path s req = - case req of - (y:ys,q,m,x) | y == s -> Just ((ys, q, m, x), id) +path :: Text -> Req -> a -> Maybe (Req, a) +path s req k = + case fst req of + (x:xs) | x == s -> Just ((xs, snd req), k) _ -> Nothing -- | Matches there being no parts of the path left. This is useful when -- matching index routes. -end :: Req -> Maybe (Req, a -> a) -end req = - case req of - ([],_,_,_) -> Just (req, id) +end :: Req -> a -> Maybe (Req, a) +end req k = + case fst req of + [] -> Just (req, k) _ -> Nothing --- | Matches anything. -anything :: Req -> Maybe (Req, a -> a) -anything req = Just (req, id) - -- | Captures a part of the path. It will parse the part into the type -- specified by the handler it is matched to. If there is no segment, or -- if the segment cannot be parsed as such, it won't match. -segment :: FromParam p => Req -> Maybe (Req, (p -> a) -> a) -segment req = - case req of - (y:ys,q,m,x) -> case fromParam y of - Left _ -> Nothing - Right p -> Just ((ys, q, m, x), \k -> k p) +segment :: Param p => Req -> (p -> a) -> Maybe (Req, a) +segment req k = + case fst req of + (x:xs) -> case fromParam x of + Left _ -> Nothing + Right p -> Just ((xs, snd req), k p) _ -> Nothing --- | Matches on a particular HTTP method. -method :: StdMethod -> Req -> Maybe (Req, a -> a) -method m r@(_,_,m',_) | m == m' = Just (r, id) -method _ _ = Nothing - -data ParamError = ParamMissing | ParamUnparsable | ParamOtherError Text deriving (Eq, Show) - --- | A class that is used for parsing for 'param', 'paramOpt', and --- 'segment'. -class FromParam a where - fromParam :: Text -> Either ParamError a +-- | A class that is used for parsing for 'param', 'paramOptional', +-- 'paramPresent', and 'segment'. +class Param a where + fromParam :: Text -> Either Text a -instance FromParam Text where +instance Param Text where fromParam = Right -instance FromParam Int where +instance Param Int where fromParam t = case decimal t of - Left _ -> Left ParamUnparsable + Left msg -> Left (T.pack msg) Right m | snd m /= "" -> - Left ParamUnparsable + Left ("Incomplete match: " <> T.pack (show m)) Right (v, _) -> Right v -instance FromParam Double where +instance Param Double where fromParam t = case double t of - Left _ -> Left ParamUnparsable + Left msg -> Left (T.pack msg) Right m | snd m /= "" -> - Left ParamUnparsable + Left ("Incomplete match: " <> T.pack (show m)) Right (v, _) -> Right v --- | Matches on a single query parameter of the given name. If there is no --- parameters, or it cannot be parsed into the type needed by the +-- | Matches on a query parameter of the given name. If there is no +-- parameter, or it cannot be parsed into the type needed by the -- handler, it won't match. -param :: FromParam p => Text -> Req -> Maybe (Req, (p -> a) -> a) -param n req = - let (_,q,_,_) = req - match = filter ((== T.encodeUtf8 n) . fst) q - in case rights (map (fromParam . maybe "" T.decodeUtf8 . snd) match) of - [x] -> Just (req, \k -> k x) - _ -> Nothing +param :: Param p => Text -> Req -> (p -> a) -> Maybe (Req, a) +param n req k = + let match = find ((== T.encodeUtf8 n) . fst) (snd req) + in case (maybe "" T.decodeUtf8 . snd) <$> match of + Nothing -> Nothing + Just p -> case fromParam p of + Left _ -> Nothing + Right p' -> Just (req, k p') --- | Matches on query parameters of the given name. If there are no --- parameters, or it cannot be parsed into the type needed by the --- handler, it won't match. -paramMany :: FromParam p => Text -> Req -> Maybe (Req, ([p] -> a) -> a) -paramMany n req = - let (_,q,_,_) = req - match = filter ((== T.encodeUtf8 n) . fst) q - in case map (maybe "" T.decodeUtf8 . snd) match of - [] -> Nothing - xs -> let ps = rights $ map fromParam xs in - if length ps == length xs - then Just (req, \k -> k ps) - else Nothing +-- | If the specified parameter is present, it will be parsed into the +-- type needed by the handler, but if it isn't present or cannot be +-- parsed, the handler will still be called (just with the 'Left' +-- variant). +paramOptional :: Param p => + Text -> + Req -> + (Either Text p -> a) -> + Maybe (Req, a) +paramOptional n req k = + let match = find ((== T.encodeUtf8 n) . fst) (snd req) + p = ((maybe "" T.decodeUtf8 . snd) <$> match) + in case p of + Nothing -> Just (req, k (Left "param missing")) + Just p' -> Just (req, k (fromParam p')) --- | If the specified parameters are present, they will be parsed into the --- type needed by the handler, but if they aren't present or cannot be --- parsed, the handler will still be called. -paramOpt :: FromParam p => - Text -> - Req -> - Maybe (Req, (Either ParamError [p] -> a) -> a) -paramOpt n req = - let (_,q,_,_) = req - match = filter ((== T.encodeUtf8 n) . fst) q - in case map (maybe "" T.decodeUtf8 . snd) match of - [] -> Just (req, \k -> k (Left ParamMissing)) - ps -> Just (req, \k -> k (foldLefts [] (map fromParam ps))) - where foldLefts acc [] = Right (reverse acc) - foldLefts _ (Left x : _) = Left x - foldLefts acc (Right x : xs) = foldLefts (x : acc) xs +-- | Matches a query parameter, which must be present, but can fail to parse. +paramPresent :: Param p => + Text -> + Req -> + (Either Text p -> a) -> + Maybe (Req, a) +paramPresent n req k = + let match = find ((== T.encodeUtf8 n) . fst) (snd req) + p = ((maybe "" T.decodeUtf8 . snd) <$> match) + in case p of + Nothing -> Nothing + Just p' -> Just (req, k (fromParam p')) + returnText :: Text -> Status -> ByteString -> IO (Maybe Response) returnText text status content = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,92 +12,87 @@ newtype R = R ([Text], Query) instance RequestContext R where - getRequest (R (p',q')) = defaultRequest { pathInfo = p', queryString = q' } + getRequest (R (p,q)) = defaultRequest { pathInfo = p, queryString = q } setRequest (R _) r = R (pathInfo r, queryString r) -p :: [Text] -> Req -p y = (y,[],GET,Nothing) -_p :: [Text] -> Req -> Req -_p y (_,q',m',x') = (y,q',m',x') -q :: Query -> Req -q y = ([],y,GET,Nothing) -_q :: Query -> Req -> Req -_q y (p',_,m',x') = (p',y,m',x') -m :: StdMethod -> Req -m y = ([],[],y,Nothing) -_m :: StdMethod -> Req -> Req -_m y (p',q',_,x') = (p',q',y,x') - -j :: Show a => Maybe (a,b) -> Expectation -j mv = fst <$> mv `shouldSatisfy` isJust -n :: Show a => Maybe (a,b) -> Expectation -n mv = fst <$> mv `shouldSatisfy` isNothing - -v :: Maybe (a, t -> Bool) -> t -> Expectation -v mv f = snd (fromJust mv) f `shouldBe` True -vn :: Maybe (a, t -> Bool) -> t -> Expectation -vn mv f = case mv of - Nothing -> (1 :: Int) `shouldBe` 1 - Just (_,k) -> k f `shouldBe` False - -t1 :: Text -> Text -> Bool -t1 = (==) -t2 :: Text -> Text -> Text -> Text -> Bool -t2 a b a' b' = a == a' && b == b' -t3 :: Text -> Text -> Text -> Text -> Text -> Text -> Bool -t3 a b c a' b' c' = a == a' && b == b' && c == c' - -t1u :: Text -> Bool -t1u _ = undefined -t2u :: Text -> Text -> Bool -t2u _ _ = undefined -t3u :: Text -> Text -> Text -> Bool -t3u _ _ _ = undefined - main :: IO () main = hspec $ do - describe "matching" $ do + describe "routing" $ do it "should match first segment with path" $ - do j (path "foo" (p ["foo", "bar"])) - n (path "foo" (p [])) - n (path "foo" (p ["bar", "foo"])) + do path "foo" (["foo", "bar"], []) () `shouldSatisfy` isJust + path "foo" ([], []) () `shouldSatisfy` isNothing + path "foo" (["bar", "foo"], []) () `shouldSatisfy` isNothing it "should match two paths combined with //" $ - do j ((path "a" // path "b") (p ["a", "b"])) - n ((path "b" // path "a") (p ["a", "b"])) - n ((path "b" // path "a") (p ["b"])) + do (path "a" // path "b") (["a", "b"], []) () `shouldSatisfy` isJust + (path "b" // path "a") (["a", "b"], []) () `shouldSatisfy` isNothing + (path "b" // path "a") (["b"], []) () `shouldSatisfy` isNothing it "should pass url segment to segment" $ - do v (segment (p ["a"])) (t1 "a") - vn (segment (p [])) t1u - v (segment (p ["a", "b"])) (t1 "a") + do segment (["a"], []) (== ("a" :: Text)) + `shouldSatisfy` (snd . fromJust) + segment ([], []) (id :: Text -> Text) `shouldSatisfy` isNothing + segment (["a", "b"], []) (== ("a" :: Text)) + `shouldSatisfy` (snd . fromJust) it "should match two segments combined with //" $ - do v ((segment // segment) (p ["a", "b"])) (t2 "a" "b") - vn ((segment // segment) (p [])) t2u - v ((segment // segment) (p ["a", "b", "c"])) (t2 "a" "b") + do (segment // segment) (["a", "b"],[]) (\a b -> a == ("a" :: Text) && + b == ("b" :: Text)) + `shouldSatisfy` (snd . fromJust) + (segment // segment) ([], []) (\(_ :: Text) (_ :: Text) -> ()) + `shouldSatisfy` isNothing + (segment // segment) (["a", "b", "c"], []) + (\a b -> a == ("a" :: Text) && + b == ("b" :: Text)) + `shouldSatisfy` (snd . fromJust) it "should match path and segment combined with //" $ - do v ((path "a" // segment) (p ["a", "b"])) (t1 "b") - vn ((path "a" // segment) (p ["b", "b"])) t1u - v ((segment // path "b") (p ["a", "b"])) (t1 "a") + do (path "a" // segment) (["a", "b"], []) (== ("b" :: Text)) + `shouldSatisfy` (snd . fromJust) + (path "a" // segment) (["b", "b"], []) (== ("b" :: Text)) + `shouldSatisfy` isNothing + (segment // path "b") (["a", "b"], []) (== ("a" :: Text)) + `shouldSatisfy` (snd . fromJust) it "should match many segments and paths together" $ - do v ((path "a" // segment // path "c" // path "d") - (p ["a","b","c", "d"])) (t1 "b") - v ((segment // path "b" // segment // segment) - (p ["a","b","c", "d", "e"])) (t3 "a" "c" "d") - vn ((segment // path "b" // segment) (p ["a", "b"])) t2u - vn ((segment // path "a" // segment) (p ["a", "b"])) t2u + do (path "a" // segment // path "c" // path "d") + (["a","b","c", "d"], []) + (== ("b" :: Text)) + `shouldSatisfy` (snd . fromJust) + (segment // path "b" // segment // segment) + (["a","b","c", "d", "e"], []) + (\a c d -> a == ("a" :: Text) && + c == ("c" :: Text) && + d == ("d" :: Text)) + `shouldSatisfy` (snd . fromJust) + (segment // path "b" // segment) + (["a", "b"], []) (\(_ :: Text) (_ :: Text) -> True) + `shouldSatisfy` isNothing + (segment // path "a" // segment) + (["a", "b"], []) (\(_ :: Text) (_ :: Text) -> True) + `shouldSatisfy` isNothing it "should match query parameters with param" $ - do v (param "foo" (q [("foo", Nothing)])) (t1 "") - vn (param "foo" (q [])) t1u + do param "foo" ([], [("foo", Nothing)]) (== ("" :: Text)) + `shouldSatisfy` (snd . fromJust) + param "foo" ([], []) (\(_ :: Text) -> True) `shouldSatisfy` isNothing it "should match combined param and paths with /?" $ - do v ((path "a" /? param "id") (_p ["a"] $ q [("id", Just "x")])) (t1 "x") - vn ((path "a" /? param "id") (_p ["b"] $ q [("id", Just "x")])) t1u - vn ((path "a" /? param "id") (_p [] $ q [("id", Just "x")])) t1u - vn ((path "a" /? param "id") (_p ["a"] $ q [("di", Just "x")])) t1u + do (path "a" /? param "id") (["a"], [("id", Just "x")]) + (== ("x" :: Text)) + `shouldSatisfy` (snd . fromJust) + (path "a" /? param "id") (["b"], [("id", Just "x")]) + (== ("x" :: Text)) + `shouldSatisfy` isNothing + (path "a" /? param "id") ([], [("id", Just "x")]) + (== ("x" :: Text)) + `shouldSatisfy` isNothing + (path "a" /? param "id") (["a"], [("di", Just "x")]) + (== ("x" :: Text)) + `shouldSatisfy` isNothing it "should match combining param, path, segment" $ - do v ((path "a" // segment /? param "id") - (_p ["a", "b"] $ q [("id", Just "x")])) (t2 "b" "x") - vn ((path "a" // segment // segment /? param "id") - (_p ["a", "b"] $ q [("id", Just "x")])) t3u + do (path "a" // segment /? param "id") + (["a", "b"], [("id", Just "x")]) + (\b x -> b == ("b" :: Text) && x == ("x" :: Text)) + `shouldSatisfy` (snd . fromJust) + (path "a" // segment // segment /? param "id") + (["a", "b"], [("id", Just "x")]) + (\(_ :: Text) (_ :: Text) (_ :: Text) -> True) + `shouldSatisfy` isNothing it "should apply matchers with ==>" $ do (path "a" ==> const ()) (R (["a"], [])) @@ -114,36 +109,31 @@ (segment // path "b" ==> \_ x -> x == ("a" :: Text)) (R (["a"], [])) `shouldSatisfy` isNothing - it "should always pass a value with paramOpt" $ - do snd (fromJust (paramOpt "id" (q []))) - (isLeft :: Either ParamError [Text] -> Bool) - `shouldBe` True - snd (fromJust (paramOpt "id" (q [("id", Just "foo")]))) - (== Right (["foo"] :: [Text])) - `shouldBe` True + it "should always pass a value with paramOptional" $ + do paramOptional "id" ([], []) (isLeft :: Either Text Text -> Bool) + `shouldSatisfy` (snd . fromJust) + paramOptional "id" ([], [("id", Just "foo")]) + (== Right ("foo" :: Text)) + `shouldSatisfy` (snd . fromJust) + it "should succeed if present, even if unparsable, w/ paramPresent" $ + do paramPresent "id" ([], []) (isLeft :: Either Text Text -> Bool) + `shouldSatisfy` isNothing + paramPresent "id" ([], [("id", Just "foo")]) + (== Right ("foo" :: Text)) + `shouldSatisfy` (snd . fromJust) + paramPresent "id" ([], [("id", Just "foo")]) + (isLeft :: Either Text Int -> Bool) + `shouldSatisfy` (snd . fromJust) it "should match end against no further path segments" $ - do j (end (p [])) - j (end (_p [] $ q [("foo", Nothing)])) - n (end (p ["a"])) + do end ([],[]) () `shouldSatisfy` isJust + end ([],[("foo", Nothing)]) () `shouldSatisfy` isJust + end (["a"],[]) () `shouldSatisfy` isNothing it "should match end after path and segments" $ - do j ((path "a" // end) (p ["a"])) - v ((segment // end) (p ["a"])) (t1 "a") - it "should match anything" $ - do j (anything (p [])) - j (anything (p ["f","b"])) + do (path "a" // end) (["a"],[]) () `shouldSatisfy` isJust + (segment // end) (["a"],[]) (== ("a" :: Text)) + `shouldSatisfy` isJust - it "should match against method" $ - do j (method GET (m GET)) - n (method GET (m POST)) - describe "route" $ do - it "should match route to parameter" $ - do r <- route (R (["a"], [])) [segment ==> (\_ a -> if a == ("a"::Text) then okText "" else return Nothing)] - (responseStatus <$> r) `shouldSatisfy` isJust - it "should match nested routes" $ - do r <- route (R (["a", "b"], [])) [path "a" ==> (\c -> route c [path "b" ==> const (okText "")])] - (responseStatus <$> r) `shouldSatisfy` isJust - describe "parameter parsing" $ do it "should parse Text" $ fromParam "hello" `shouldBe` Right ("hello" :: Text) @@ -151,13 +141,13 @@ do fromParam "1" `shouldBe` Right (1 :: Int) fromParam "2011" `shouldBe` Right (2011 :: Int) fromParam "aaa" `shouldSatisfy` - (isLeft :: Either ParamError Int -> Bool) + (isLeft :: Either Text Int -> Bool) fromParam "10a" `shouldSatisfy` - (isLeft :: Either ParamError Int -> Bool) + (isLeft :: Either Text Int -> Bool) it "should be able to parse Double" $ do fromParam "1" `shouldBe` Right (1 :: Double) fromParam "1.02" `shouldBe` Right (1.02 :: Double) fromParam "thr" `shouldSatisfy` - (isLeft :: Either ParamError Double -> Bool) + (isLeft :: Either Text Double -> Bool) fromParam "100o" `shouldSatisfy` - (isLeft :: Either ParamError Double -> Bool) + (isLeft :: Either Text Double -> Bool)