diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,24 @@ +* 0.3.0.0 Daniel Patterson 2016-3-2 + + - Don't parse request body by default, to make `Fn` play well with + others (that want to parse the body themself). + - Add `!=>` connective that is like `==>`, but parses the request + body. If you don't use `!=>`, patterns with `file` and `files` + will fail. Also, `param` will only get query parameters. + - Add `Route` type alias for the type of `pattern ==> handler`. This + is partly for convenience and partly to make upgrades easier (in + the event that the types change). + - Change `FromParam` class to take a list of all parameters matching + a given name, which allows us to implement a `Maybe` instance, a + list instance, and make `paramMany` redundant (though currently + left in, for compatibility). This also makes the ergonomics of + using optional parameters better. + - Fix bug where `staticServe` would allow you to break out of + directory specified with `..`. + * 0.2.0.2 Daniel Patterson 2016-1-20 - - Fixe for GHC 7.8, which cabal file said would work, but didn't. + - Fix for GHC 7.8, which cabal file said would work, but didn't. * 0.2.0.1 Daniel Patterson 2015-12-4 diff --git a/fn.cabal b/fn.cabal --- a/fn.cabal +++ b/fn.cabal @@ -1,14 +1,14 @@ name: fn -version: 0.2.0.2 +version: 0.3.0.0 synopsis: A functional web framework. description: A Haskell web framework where you write plain old functions. . - /Provided you have/ /installed, you can run this example like a shell script:/ + /Provided you have/ /installed, you can run this example like a shell script (it'll listen on port 3000):/ . @ #!\/usr\/bin\/env stack - \-\- stack --resolver lts-3.10 --install-ghc runghc --package fn + \-\- stack --resolver lts-5.5 --install-ghc runghc --package fn --package warp {-# LANGUAGE OverloadedStrings #-} import Data.Monoid ((<>)) import Data.Text (Text) @@ -30,7 +30,7 @@ . site :: Ctxt -> IO Response site ctxt = route ctxt [ end ==> indexH - , path "echo" \/? param "msg" ==> echoH + , path "echo" \/\/ param "msg" ==> echoH , path "echo" \/\/ segment ==> echoH ] \`fallthrough\` notFoundText "Page not found." @@ -72,7 +72,7 @@ license-file: LICENSE author: Daniel Patterson maintainer: dbp@dbpmail.net -copyright: 2015 Daniel Patterson +copyright: 2016 Daniel Patterson category: Web build-type: Simple extra-source-files: CHANGELOG.md diff --git a/src/Web/Fn.hs b/src/Web/Fn.hs --- a/src/Web/Fn.hs +++ b/src/Web/Fn.hs @@ -28,9 +28,11 @@ , toWAI -- * Routing , Req + , Route , route , fallthrough , (==>) + , (!=>) , (//) , (/?) , path @@ -48,6 +50,7 @@ , files -- * Responses , staticServe + , sendFile , okText , okHtml , errText @@ -55,14 +58,16 @@ , notFoundText , notFoundHtml , redirect + , redirectReferer ) where import qualified Blaze.ByteString.Builder.Char.Utf8 as B import Control.Applicative ((<$>)) import Control.Arrow (second) +import Control.Concurrent.MVar import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB -import Data.Either (rights) +import Data.Either (lefts, rights) import qualified Data.HashMap.Strict as HM import Data.Maybe (fromJust) import Data.Text (Text) @@ -82,15 +87,25 @@ instance Functor (Store b) where fmap f (Store b h) = Store b (f . h) +-- | The type of a route, constructed with 'pattern ==> handler'. +type Route ctxt = ctxt -> Req -> IO (Maybe (IO (Maybe Response))) +type PostMVar = Maybe (MVar (Maybe ([Param], [Parse.File LB.ByteString]))) + -- | A normal WAI 'Request' and the parsed post body (if present). We can -- only parse the body once, so we need to have our request (which we -- pass around) to be able to have the parsed body. -type FnRequest = (Request, ([Param], [Parse.File LB.ByteString])) +type FnRequest = (Request, PostMVar) --- | A default request, which is a WAI defaultRequest and no post info +-- | A default request, which is a WAI defaultRequest and a place for +-- an MVar where post info will be placed (if you parse the post +-- body). +-- +-- Warning: If you try to parse the post body (with '!=>') without +-- replacing the Nothing placeholder with an actual MVar, it will blow +-- up! defaultFnRequest :: FnRequest -defaultFnRequest = (defaultRequest, ([],[])) +defaultFnRequest = (defaultRequest, Nothing) -- | Specify the way that Fn can get the 'FnRequest' out of your context. -- @@ -120,9 +135,8 @@ -- value for each call). toWAI :: RequestContext ctxt => ctxt -> (ctxt -> IO Response) -> Application toWAI ctxt f req cont = - do post <- parseRequestBody lbsBackEnd req - let ctxt' = setRequest ctxt (req, post) - f ctxt' >>= cont + do mv <- newMVar Nothing + f (setRequest ctxt (req, Just mv)) >>= cont -- | 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 @@ -139,7 +153,7 @@ -- @ route :: RequestContext ctxt => ctxt -> - [ctxt -> Req -> Maybe (IO (Maybe Response))] -> + [Route ctxt] -> IO (Maybe Response) route ctxt pths = do let (r,post) = getRequest ctxt @@ -148,13 +162,14 @@ route' req pths where route' _ [] = return Nothing route' req (x:xs) = - case x ctxt req of - Nothing -> route' req xs - Just action -> - do resp <- action - case resp of - Nothing -> route' req xs - Just response -> return (Just response) + do mact <- x ctxt req + case mact of + Nothing -> route' req xs + Just action -> + do resp <- action + case resp of + Nothing -> route' req xs + Just response -> return (Just response) -- | The 'route' function (and all your handlers) return -- 'IO (Maybe Response)', because each can elect to not respond (in @@ -244,173 +259,232 @@ -- -- > anything ==> staticServe "static" -- --- If no file is found, this will continue routing. +-- If no file is found, or if the path has @..@ or starts with @/@, +-- this will continue routing. staticServe :: RequestContext ctxt => Text -> ctxt -> IO (Maybe Response) staticServe d ctxt = do - let pth = T.unpack $ T.intercalate "/" $ d : pathInfo (fst . getRequest $ ctxt) - exists <- doesFileExist pth - if exists - then do let ext = takeExtension pth - contentType = case HM.lookup ext mimeMap of - Nothing -> [] - Just t -> [(hContentType, t)] - return $ Just $ responseFile status200 - contentType - pth - Nothing - else return Nothing + let pth = T.intercalate "/" $ d : pathInfo (fst . getRequest $ ctxt) + if "/" `T.isPrefixOf` pth || ".." `T.isInfixOf` pth + then return Nothing + else sendFile (T.unpack pth) +-- | Sends a specific file specified by path. It will specify the +-- content-type if it can figure it out by the file extension. +-- +-- If no file exists at the given path, it will keep routing. +sendFile :: FilePath -> IO (Maybe Response) +sendFile pth = + do exists <- doesFileExist pth + if exists + then do let ext = takeExtension pth + contentType = case HM.lookup ext mimeMap of + Nothing -> [] + Just t -> [(hContentType, t)] + return $ Just $ responseFile status200 + contentType + pth + Nothing + else return Nothing + -- | The parts of the path, when split on /, and the query. -type Req = ([Text], Query, StdMethod, ([Param], [Parse.File LB.ByteString])) +type Req = ([Text], Query, StdMethod, PostMVar) --- | 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. +-- | The non-body parsing 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)) -> + (Req -> IO (Maybe (Req, k -> a))) -> (ctxt -> k) -> ctxt -> Req -> - Maybe a + IO (Maybe a) (match ==> handle) ctxt req = - case match req of - Nothing -> Nothing - Just ((pathInfo',_,_,_), k) -> - let (request, post) = getRequest ctxt in - Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, post))) + do rsp <- match req + case rsp of + Nothing -> return Nothing + Just ((pathInfo',_,_,_), k) -> + let (request, mv) = getRequest ctxt in + return $ Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, mv))) +-- | The connective between route patterns and the handler that parses +-- the body, which allows post params to be extracted with 'param' and +-- allows 'file' to work (otherwise, it will trigger a runtime error). +(!=>) :: RequestContext ctxt => + (Req -> IO (Maybe (Req, k -> a))) -> + (ctxt -> k) -> + ctxt -> + Req -> + IO (Maybe a) +(match !=> handle) ctxt req = + do let (request, Just mv) = getRequest ctxt + modifyMVar_ mv (\r -> case r of + Nothing -> Just <$> parseRequestBody lbsBackEnd request + Just _ -> return r) + rsp <- match req + case rsp of + Nothing -> return Nothing + Just ((pathInfo',_,_,_), k) -> + do return $ Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, Just mv))) + -- | 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) +(//) :: (r -> IO (Maybe (r, k -> k'))) -> + (r -> IO (Maybe (r, k' -> a))) -> + r -> IO (Maybe (r, k -> a)) +(match1 // match2) req = do + r1 <- match1 req + case r1 of + Nothing -> return Nothing + Just (req', k) -> + do r2 <- match2 req' + return $ case r2 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) +{-# DEPRECATED (/?) "Use the identical '//' instead." #-} +-- | A synonym for '//'. To be removed +(/?) :: (r -> IO (Maybe (r, k -> k'))) -> + (r -> IO (Maybe (r, k' -> a))) -> + r -> IO (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 :: Text -> Req -> IO (Maybe (Req, a -> a)) path s req = - case req of - (y:ys,q,m,x) | y == s -> Just ((ys, q, m, x), id) - _ -> Nothing + return $ 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 -> IO (Maybe (Req, a -> a)) end req = - case req of - ([],_,_,_) -> Just (req, id) - _ -> Nothing + return $ case req of + ([],_,_,_) -> Just (req, id) + _ -> Nothing -- | Matches anything. -anything :: Req -> Maybe (Req, a -> a) -anything req = Just (req, id) +anything :: Req -> IO (Maybe (Req, a -> a)) +anything req = return $ 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 :: FromParam p => Req -> IO (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 + return $ 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 +method :: StdMethod -> Req -> IO (Maybe (Req, a -> a)) +method m r@(_,_,m',_) | m == m' = return $ Just (r, id) +method _ _ = return Nothing -data ParamError = ParamMissing | ParamUnparsable | ParamOtherError Text deriving (Eq, Show) +data ParamError = ParamMissing | ParamTooMany | ParamUnparsable | ParamOtherError Text deriving (Eq, Show) --- | A class that is used for parsing for 'param', 'paramOpt', 'paramMany' +-- | A class that is used for parsing for 'param' and 'paramOpt'. -- and 'segment'. class FromParam a where - fromParam :: Text -> Either ParamError a + fromParam :: [Text] -> Either ParamError a instance FromParam Text where - fromParam = Right + fromParam [x] = Right x + fromParam [] = Left ParamMissing + fromParam _ = Left ParamTooMany instance FromParam Int where - fromParam t = case decimal t of - Left _ -> Left ParamUnparsable - Right m | snd m /= "" -> - Left ParamUnparsable - Right (v, _) -> Right v + fromParam [t] = case decimal t of + Left _ -> Left ParamUnparsable + Right m | snd m /= "" -> + Left ParamUnparsable + Right (v, _) -> Right v + fromParam [] = Left ParamMissing + fromParam _ = Left ParamTooMany instance FromParam Double where - fromParam t = case double t of - Left _ -> Left ParamUnparsable - Right m | snd m /= "" -> - Left ParamUnparsable - Right (v, _) -> Right v - + fromParam [t] = case double t of + Left _ -> Left ParamUnparsable + Right m | snd m /= "" -> + Left ParamUnparsable + Right (v, _) -> Right v + fromParam [] = Left ParamMissing + fromParam _ = Left ParamTooMany +instance FromParam a => FromParam [a] where + fromParam ps = let res = map (fromParam . (:[])) ps in + case lefts res of + [] -> Right $ rights res + _ -> Left $ ParamOtherError "Couldn't parse all parameters." +instance FromParam a => FromParam (Maybe a) where + fromParam [x] = Just <$> fromParam [x] + fromParam [] = Right Nothing + fromParam _ = Left ParamTooMany -findParamMatches :: FromParam p => Text -> [(ByteString, Maybe ByteString)] -> [Either ParamError p] -findParamMatches n ps = map (fromParam . maybe "" T.decodeUtf8 . snd) . +findParamMatches :: FromParam p => Text -> [(ByteString, Maybe ByteString)] -> Either ParamError p +findParamMatches n ps = fromParam . + map (maybe "" T.decodeUtf8 . snd) . filter ((== T.encodeUtf8 n) . fst) $ ps --- | 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) +getMVarParams mv = case mv of + Just mv' -> do v <- readMVar mv' + return $ case v of + Nothing -> [] + Just (ps',_) -> ps' + Nothing -> return [] + +-- | Matches on a query parameter of the given name. It is parsed into +-- the type needed by the handler, which can be a 'Maybe' type if the +-- parameter is optional, or a list type if there can be many. If the +-- parameters cannot be parsed into the type needed by the handler, it +-- won't match. +-- +-- Note: If you have used the '!=>' connective, so that the request +-- body has been parsed, this will also match post parameters (and +-- will combine the two together). If you haven't used that connective +-- (so the pattern is matched to handler with '==>'), it will only +-- match query parameters. +param :: FromParam p => Text -> Req -> IO (Maybe (Req, (p -> a) -> a)) param n req = - let (_,q,_,(ps, _)) = req - in case rights $ findParamMatches n q of - [y] -> Just (req, \k -> k y) - [] -> case rights $ findParamMatches n (map (second Just) ps) of - [y] -> Just (req, \k -> k y) - -- TODO(dbp 2015-11-05): It's too bad that the - -- request body parsing will possibly be - -- duplicated, in case nothing matches. Perhaps - -- both branches should thread... - _ -> Nothing - _ -> Nothing + do let (_,q,_,mv) = req + ps <- getMVarParams mv + return $ case findParamMatches n (q ++ map (second Just) ps) of + Right y -> Just (req, \k -> k y) + Left _ -> Nothing +{-# DEPRECATED paramMany "Use 'param' with a list type, or define param parsing for non-empty list." #-} -- | Matches on query parameters of the given name. If there are no -- parameters, or they 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 :: FromParam p => Text -> Req -> IO (Maybe (Req, ([p] -> a) -> a)) paramMany n req = - let (_,q,_,(ps,_)) = req - in case findParamMatches n (q ++ map (second Just) ps) of - [] -> Nothing - xs -> let ys = rights xs in - if length ys == length xs - then Just (req, \k -> k ys) - else Nothing + do let (_,q,_,mv) = req + ps <- getMVarParams mv + return $ case findParamMatches n (q ++ map (second Just) ps) of + Left _ -> Nothing + Right ys -> Just (req, \k -> k ys) -- | 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. +-- +-- Note: If you have used the '!=>' connective, so that the request +-- body has been parsed, this will also match post parameters (and +-- will combine the two together). If you haven't used that connective +-- (so the pattern is matched to handler with '==>'), it will only +-- match query parameters. paramOpt :: FromParam p => Text -> Req -> - Maybe (Req, (Either ParamError [p] -> a) -> a) + IO (Maybe (Req, (Either ParamError p -> a) -> a)) paramOpt n req = - let (_,q,_,(ps, _)) = req - in case findParamMatches n (q ++ map (second Just) ps) of - [] -> Just (req, \k -> k (Left ParamMissing)) - ys -> Just (req, \k -> k (foldLefts [] ys)) - where foldLefts acc [] = Right (reverse acc) - foldLefts _ (Left x : _) = Left x - foldLefts acc (Right x : xs) = foldLefts (x : acc) xs + do let (_,q,_,mv) = req + ps <- getMVarParams mv + return $ Just (req, \k -> k (findParamMatches n (q ++ map (second Just) ps))) -- | An uploaded file. @@ -419,27 +493,48 @@ , fileContent :: LB.ByteString } +getMVarFiles mv = case mv of + Nothing -> error $ "Fn: tried to read a 'file' or 'files', but FnRequest wasn't initialized with MVar." + Just mv' -> do + v <- readMVar mv' + case v of + Nothing -> error $ "Fn: tried to read a 'file' or 'files' from the request without parsing the body with '!=>'" + Just (_,fs') -> return fs' + -- | Matches an uploaded file with the given parameter name. -file :: Text -> Req -> Maybe (Req, (File -> a) -> a) +-- +-- Note: You must use the '!=>' connective between the pattern and the +-- handler, or else the request body will not have been parsed and +-- this will fail. +file :: Text -> Req -> IO (Maybe (Req, (File -> a) -> a)) file n req = - let (_,_,_,(_, fs)) = req - in case filter ((== T.encodeUtf8 n) . fst) fs of - [(_, FileInfo nm ct c)] -> Just (req, \k -> k (File (T.decodeUtf8 nm) - (T.decodeUtf8 ct) - c)) - _ -> Nothing + do let (_,_,_,mv) = req + fs <- getMVarFiles mv + return $ case filter ((== T.encodeUtf8 n) . fst) fs of + [(_, FileInfo nm ct c)] -> Just (req, \k -> k (File (T.decodeUtf8 nm) + (T.decodeUtf8 ct) + c)) + _ -> Nothing -- | Matches all uploaded files, passing their parameter names and -- contents. -files :: Req -> Maybe (Req, ([(Text, File)] -> a) -> a) +-- +-- Note: You must use the '!=>' connective between the pattern and the +-- handler, or else the request body will not have been parsed and +-- this will fail. +files :: Req -> IO (Maybe (Req, ([(Text, File)] -> a) -> a)) files req = - let (_,_,_,(_, fs')) = req - fs = map (\(n, FileInfo nm ct c) -> - (T.decodeUtf8 n, File (T.decodeUtf8 nm) - (T.decodeUtf8 ct) - c)) - fs' - in Just (req, \k -> k fs) + do let (_,_,_,Just mv) = req + v <- readMVar mv + let fs' = case v of + Nothing -> error $ "Fn: tried to read a 'file' from the request without parsing the body with '!=>'" + Just (_,fs) -> fs + let fs = map (\(n, FileInfo nm ct c) -> + (T.decodeUtf8 n, File (T.decodeUtf8 nm) + (T.decodeUtf8 ct) + c)) + fs' + return $ Just (req, \k -> k fs) returnText :: Text -> Status -> ByteString -> IO (Maybe Response) returnText text status content = @@ -458,6 +553,7 @@ 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 @@ -490,3 +586,11 @@ responseBuilder status303 [(hLocation, T.encodeUtf8 target)] (B.fromText "") + +-- | Redirects to the referrer, if present in headers, else to "/". +redirectReferer :: RequestContext ctxt => ctxt -> IO (Maybe Response) +redirectReferer ctxt = + let rs = requestHeaders $ fst $ getRequest ctxt in + case lookup hReferer rs of + Nothing -> redirect "/" + Just r -> redirect (T.decodeUtf8 r) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,46 +2,60 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar import Data.Either import Data.Maybe -import Data.Text (Text) +import Data.Text (Text) import Network.HTTP.Types import Network.Wai +import System.IO.Unsafe import Test.Hspec import Web.Fn +emv = unsafePerformIO (newMVar Nothing) + +instance Show (MVar a) where + show _ = "" + 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' }, Just emv) setRequest (R _) (r,_) = R (pathInfo r, queryString r) + rr :: R rr = R ([], []) p :: [Text] -> Req -p y = (y,[],GET,([],[])) +p y = (y,[],GET,Just emv) _p :: [Text] -> Req -> Req _p y (_,q',m',x') = (y,q',m',x') q :: Query -> Req -q y = ([],y,GET,([],[])) +q y = ([],y,GET,Just emv) _q :: Query -> Req -> Req _q y (p',_,m',x') = (p',y,m',x') m :: StdMethod -> Req -m y = ([],[],y,([],[])) +m y = ([],[],y,Just emv) _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 +j :: Show a => IO (Maybe (a,b)) -> Expectation +j mv = do x <- mv + fst <$> x `shouldSatisfy` isJust +n :: Show a => IO (Maybe (a,b)) -> Expectation +n mv = do x <- mv + fst <$> x `shouldSatisfy` isNothing +v :: IO (Maybe (a, t -> Bool)) -> t -> Expectation +v mv f = do x <- mv + snd (fromJust x) f `shouldBe` True +vn :: IO (Maybe (a, t -> Bool)) -> t -> Expectation +vn mv f = do v <- mv + case v of + Nothing -> (1 :: Int) `shouldBe` 1 + Just (_,k) -> k f `shouldBe` False -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 +shouldSatisfyIO a b = do x <- a + x `shouldSatisfy` b t1 :: Text -> Text -> Bool t1 = (==) @@ -103,25 +117,27 @@ (_p ["a", "b"] $ q [("id", Just "x")])) t3u it "should apply matchers with ==>" $ do (path "a" ==> const ()) rr (p ["a"]) - `shouldSatisfy` isJust + `shouldSatisfyIO` isJust (segment ==> \_ (_ :: Text) -> ()) rr (p ["1"]) - `shouldSatisfy` isJust + `shouldSatisfyIO` isJust (segment // path "b" ==> \_ x -> x == ("a" :: Text)) rr (p ["a", "b"]) - `shouldSatisfy` fromJust + `shouldSatisfyIO` fromJust (segment // path "b" ==> \_ x -> x == ("a" :: Text)) rr (p ["a", "a"]) - `shouldSatisfy` isNothing + `shouldSatisfyIO` isNothing (segment // path "b" ==> \_ x -> x == ("a" :: Text)) rr (p ["a"]) - `shouldSatisfy` isNothing + `shouldSatisfyIO` isNothing it "should always pass a value with paramOpt" $ - do snd (fromJust (paramOpt "id" (q []))) - (isLeft :: Either ParamError [Text] -> Bool) + do x <- paramOpt "id" (q []) + snd (fromJust x) + (isLeft :: Either ParamError Text -> Bool) `shouldBe` True - snd (fromJust (paramOpt "id" (q [("id", Just "foo")]))) - (== Right (["foo"] :: [Text])) - `shouldBe` True + y <- paramOpt "id" (q [("id", Just "foo")]) + snd (fromJust y) + (== Right ("foo" :: Text)) + `shouldBe` True it "should match end against no further path segments" $ do j (end (p [])) j (end (_p [] $ q [("foo", Nothing)])) @@ -147,18 +163,18 @@ describe "parameter parsing" $ do it "should parse Text" $ - fromParam "hello" `shouldBe` Right ("hello" :: 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` + do fromParam ["1"] `shouldBe` Right (1 :: Int) + fromParam ["2011"] `shouldBe` Right (2011 :: Int) + fromParam ["aaa"] `shouldSatisfy` (isLeft :: Either ParamError Int -> Bool) - fromParam "10a" `shouldSatisfy` + 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` + 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` + fromParam ["100o"] `shouldSatisfy` (isLeft :: Either ParamError Double -> Bool)