diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,33 @@ +* 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,5 @@ +Copyright (c) 2015, Daniel Patterson + +Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,52 @@ +## Fn (eff-enn) - a functional web framework. + +> Or, how to do away with the monad transformers, and just use plain +> functions. + +## Example + +See the example application in the repository for a full usage, but a minimal application is the following: + +``` + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Lens +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import qualified Network.Wai.Util as W +import Web.Fn + +data Ctxt = Ctxt { _req :: Request + } + +makeLenses ''Ctxt + +instance RequestContext Ctxt where + requestLens = req + +initializer :: IO Ctxt +initializer = return (Ctxt defaultRequest) + +main :: IO () +main = do context <- initializer + run 8000 $ toWAI context app + +app :: Ctxt -> IO Response +app ctxt = + route ctxt [ end ==> index + , path "foo" // segment // path "baz" /? param "id" ==> handler] + `fallthrough` notFoundText "Page not found." + +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)) + +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fn.cabal b/fn.cabal new file mode 100644 --- /dev/null +++ b/fn.cabal @@ -0,0 +1,96 @@ +name: fn +version: 0.0.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). + +homepage: http://github.com/dbp/fn#readme +license: ISC +license-file: LICENSE +author: Daniel Patterson +maintainer: dbp@dbpmail.net +copyright: 2015 Daniel Patterson +category: Web +build-type: Simple +extra-source-files: CHANGELOG.md + README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Web.Fn + build-depends: base >= 4.7 && < 5 + , wai >= 3 + , wai-extra >= 3 + , http-types + , text + , blaze-builder + , bytestring + default-language: Haskell2010 + ghc-options: -Wall + +test-suite fn-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , fn + , hspec + , text + , http-types + , wai + , wai-extra + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/dbp/fn diff --git a/src/Web/Fn.hs b/src/Web/Fn.hs new file mode 100644 --- /dev/null +++ b/src/Web/Fn.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + +This package provides a simple framework for routing and responses. The +two primary goals are: + +1. All web handler functions are just plain IO. There is no Fn +monad, or monad transformer. This has a lot of nice properties, +foremost among them is that it is easier to call handlers from other +contexts (like GHCi, when testing, in other threads, etc). As a +result, these functions take a single extra parameter that +has the context that they need (like database connection pools, the +request, etc). + +2. Web handlers are functions with typed parameters. When routing, we +specify many parameters (most commonly, numeric ids, but can be many +things), so the handlers should be functions that take those as +parameters. + +-} + +module Web.Fn ( -- * Application setup + RequestContext(..) + , toWAI + -- * Routing + , Req + , route + , fallthrough + , (==>) + , (//) + , (/?) + , path + , end + , anything + , segment + , method + , FromParam(..) + , ParamError(..) + , param + , paramMany + , paramOpt + -- * Responses + , okText + , okHtml + , errText + , errHtml + , notFoundText + , notFoundHtml + , redirect + ) where + +import qualified Blaze.ByteString.Builder.Char.Utf8 as B +import Data.ByteString (ByteString) +import Data.Either (rights) +import Data.Maybe (fromJust) +import Data.Text (Text) +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 + fmap f (Store b h) = Store b (f . h) + +-- | Specify the way that Fn can get the Request out of your context. +-- +-- The easiest way to instantiate this is to use the lens, but if you +-- don't want to use lenses, define 'getRequest' and 'setRequest'. +-- +-- Note that 'requestLens' is defined in terms of 'getRequest' and +-- 'setRequest' and vice-versa, so you need to define _one_ of these. +class RequestContext ctxt where + requestLens :: Functor f => (Request -> f Request) -> ctxt -> f ctxt + requestLens f c = setRequest c <$> f (getRequest c) + getRequest :: ctxt -> Request + getRequest c = + let (Store r _) = requestLens (`Store` id) c + in r + setRequest :: ctxt -> Request -> ctxt + setRequest c r = + let (Store _ b) = requestLens (`Store` id) c + in b r + +-- | Convert an Fn application (provide a context, a context to response +-- function and we'll create a WAI application by updating the Request +-- value for each call). +toWAI :: RequestContext ctxt => ctxt -> (ctxt -> IO Response) -> Application +toWAI ctxt f req cont = let ctxt' = setRequest ctxt req + in f ctxt' >>= cont + +-- | The 'route' function (and all your handlers) return +-- 'IO (Maybe Response)', because each can elect to not respond (in +-- which case we will continue to match on routes). But to construct +-- an application, we need a response in the case that nothing matched +-- - this is what 'fallthrough' does. +fallthrough :: IO (Maybe Response) -> IO Response -> IO Response +fallthrough a ft = + do response <- a + case response of + Nothing -> ft + Just r -> return r + +-- | The main construct for Fn, 'route' takes a context (which it will pass +-- to all handlers) and a list of potential matches (which, once they +-- match, may still end up deciding not to handle the request - hence +-- the double 'Maybe'). It can be nested. +-- +-- @ +-- app c = route c [ end ==> index +-- , path "foo" // path "bar" // segment /? param "id ==> h] +-- where index :: IO (Maybe Response) +-- index = okText "This is the index." +-- h :: Text -> Text -> IO (Maybe Response) +-- h s i = okText ("got path /foo/" <> s <> ", with id=" <> i) +-- @ +route :: RequestContext ctxt => + ctxt -> + [ctxt -> Maybe (IO (Maybe Response))] -> + IO (Maybe Response) +route _ [] = return Nothing +route ctxt (x:xs) = + case x ctxt of + Nothing -> route ctxt xs + Just action -> + do resp <- action + case resp of + Nothing -> route ctxt xs + 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])) + +-- | The connective between route patterns and the handler that will +-- be called if the pattern matches. The type is not particularly +-- illuminating, as it uses polymorphism to be able to match route +-- 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)) -> + (ctxt -> k) -> + 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 + Nothing -> Nothing + Just ((pathInfo',_,_,_), k) -> Just (k $ handle (setRequest ctxt ((getRequest ctxt) { pathInfo = pathInfo' }))) + +-- | 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 + Nothing -> Nothing + Just (req', k) -> case match2 req' of + Nothing -> Nothing + Just (req'', k') -> Just (req'', k' . 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) +(/?) = (//) + +-- | 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) + _ -> 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) + _ -> 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) + _ -> 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 + +instance FromParam Text where + fromParam = Right +instance FromParam Int where + fromParam t = case decimal t of + Left _ -> Left ParamUnparsable + Right m | snd m /= "" -> + Left ParamUnparsable + Right (v, _) -> Right v +instance FromParam Double where + fromParam t = case double t of + Left _ -> Left ParamUnparsable + Right m | snd m /= "" -> + Left ParamUnparsable + 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 +-- 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 + +-- | 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 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 + +returnText :: Text -> Status -> ByteString -> IO (Maybe Response) +returnText text status content = + return $ Just $ + responseBuilder status + [(hContentType, content)] + (B.fromText text) + +plainText :: ByteString +plainText = "text/plain; charset=utf-8" + +html :: ByteString +html = "text/html; charset=utf-8" + +-- | Returns 'Text' as a response. +okText :: Text -> IO (Maybe Response) +okText t = returnText t status200 plainText + +-- | Returns Html (in 'Text') as a response. +okHtml :: Text -> IO (Maybe Response) +okHtml t = returnText t status200 html + +-- | Returns 'Text' as a response with a 500 status code. +errText :: Text -> IO (Maybe Response) +errText t = returnText t status500 plainText + +-- | Returns Html (in 'Text') as a response with a 500 status code. +errHtml :: Text -> IO (Maybe Response) +errHtml t = returnText t status500 html + +-- | Returns a 404 with the given 'Text' as a body. Note that this +-- returns a 'IO Response' not an 'IO (Maybe Response)' because the +-- expectaiton is that you are calling this with 'fallthrough'. +notFoundText :: Text -> IO Response +notFoundText t = fromJust <$> returnText t status404 plainText + +-- | Returns a 404 with the given html as a body. Note that this +-- returns a 'IO Response' not an 'IO (Maybe Response)' because the +-- expectaiton is that you are calling this with 'fallthrough'. +notFoundHtml :: Text -> IO Response +notFoundHtml t = fromJust <$> returnText t status404 html + +-- | Redirects to the given url. Note that the target is not validated, +-- so it should be an absolute path/url. +redirect :: Text -> IO (Maybe Response) +redirect target = + return $ Just $ + responseBuilder status303 + [(hLocation, T.encodeUtf8 target)] + (B.fromText "") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Data.Either +import Data.Maybe +import Data.Text (Text) +import Network.HTTP.Types +import Network.Wai +import Test.Hspec +import Web.Fn + +newtype R = R ([Text], Query) +instance RequestContext R where + 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 + it "should match first segment with path" $ + do j (path "foo" (p ["foo", "bar"])) + n (path "foo" (p [])) + n (path "foo" (p ["bar", "foo"])) + 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"])) + 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") + 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") + 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") + 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 + it "should match query parameters with param" $ + do v (param "foo" (q [("foo", Nothing)])) (t1 "") + vn (param "foo" (q [])) t1u + 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 + 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 + it "should apply matchers with ==>" $ + do (path "a" ==> const ()) + (R (["a"], [])) + `shouldSatisfy` isJust + (segment ==> \_ (_ :: Text) -> ()) + (R (["a"], [])) + `shouldSatisfy` isJust + (segment // path "b" ==> \_ x -> x == ("a" :: Text)) + (R (["a", "b"], [])) + `shouldSatisfy` fromJust + (segment // path "b" ==> \_ x -> x == ("a" :: Text)) + (R (["a", "a"], [])) + `shouldSatisfy` isNothing + (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 match end against no further path segments" $ + do j (end (p [])) + j (end (_p [] $ q [("foo", Nothing)])) + n (end (p ["a"])) + 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"])) + + 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) + it "should parse Int" $ + do fromParam "1" `shouldBe` Right (1 :: Int) + fromParam "2011" `shouldBe` Right (2011 :: Int) + fromParam "aaa" `shouldSatisfy` + (isLeft :: Either ParamError Int -> Bool) + fromParam "10a" `shouldSatisfy` + (isLeft :: Either ParamError 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) + fromParam "100o" `shouldSatisfy` + (isLeft :: Either ParamError Double -> Bool)