diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +* 0.2.0.0 Daniel Pattersion 2015-11-5 + + - Changed to having our own `FnRequest` type, which is a WAI + `Request` and the results of parsing the body for contents, since + we need to be able to do that once and thread it through. + - Add `file` and `files` matchers, which match against and pass file + uploads to handlers. + - Add `staticServe` to serve static files based on path. + * 0.1.4.0 Daniel Pattersion 2015-11-4 - Move `ctxt` back to first parameter passed to handlers, via more @@ -20,14 +29,15 @@ * 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`. + - 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`. + - Rename `Param` class to `FromParam`. * 0.1.0.0 Daniel Patterson 2015-10-25 - Initial release. + - Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,48 +5,6 @@ ## 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)) - -``` +See the [example application](https://github.com/dbp/fn/tree/master/example) +in the repository for a full usage including database access, heist +templates, sessions, etc. diff --git a/fn.cabal b/fn.cabal --- a/fn.cabal +++ b/fn.cabal @@ -1,8 +1,73 @@ name: fn -version: 0.1.4.0 +version: 0.2.0.0 synopsis: A functional web framework. -description: Please see README. -homepage: http://github.com/dbp/fn#readme +description: + A Haskell web framework where you write plain old functions. + . + /Provided you have/ /installed, you can run this example like a shell script:/ + . + @ + #!\/usr\/bin\/env stack + \-\- stack --resolver lts-3.10 --install-ghc runghc --package fn + {-# LANGUAGE OverloadedStrings #-} + import Data.Monoid ((<>)) + import Data.Text (Text) + import Network.Wai (Response) + import Network.Wai.Handler.Warp (run) + import Web.Fn + . + data Ctxt = Ctxt { _req :: FnRequest } + instance RequestContext Ctxt where + getRequest = _req + setRequest c r = c { _req = r } + . + initializer :: IO Ctxt + initializer = return (Ctxt defaultFnRequest) + . + main :: IO () + main = do ctxt <- initializer + run 3000 $ toWAI ctxt site + . + site :: Ctxt -> IO Response + site ctxt = route ctxt [ end ==> indexH + , path "echo" \/? param "msg" ==> echoH + , path "echo" \/\/ segment ==> echoH + ] + \`fallthrough\` notFoundText "Page not found." + . + 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 lets you write web code that just looks like normal Haskell code. + . + * An application has some \"context\", which must contain a @Request@, + but can contain other data as well, like database connection pools, + etc. This context will be passed to each of your handlers, updated + with the current HTTP Request. + . + * Routes are declared to capture parameters and/or segments of the url, + and then routed to handler functions that have the appropriate number + and type of arguments. These functions return @IO (Maybe Response)@, + where @Nothing@ indicates to Fn that you want it to keep looking for + matching routes. + . + * All handlers just use plain old @IO@, which means it is easy to call + them from GHCi, @forkIO@, etc. + . + * All of this is a small wrapper around the WAI interface, so you have + the flexilibility to do anything you need to do with HTTP. + . + The name comes from the fact that Fn emphasizes functions (over monads), + where all necessary data is passed via function arguments, and control + flow is mediated by return values. + +homepage: http://github.cxom/dbp/fn#readme license: ISC license-file: LICENSE author: Daniel Patterson @@ -18,11 +83,15 @@ hs-source-dirs: src exposed-modules: Web.Fn build-depends: base >= 4.7 && < 5 - , wai + , wai >= 3 + , wai-extra >= 3 , http-types , text , blaze-builder , bytestring + , unordered-containers + , filepath + , directory default-language: Haskell2010 ghc-options: -Wall @@ -36,6 +105,10 @@ , text , http-types , wai + , wai-extra + , unordered-containers + , filepath + , directory 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 @@ -18,11 +18,13 @@ 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(..) + FnRequest + , defaultFnRequest + , RequestContext(..) , toWAI -- * Routing , Req @@ -41,7 +43,11 @@ , param , paramMany , paramOpt + , File(..) + , file + , files -- * Responses + , staticServe , okText , okHtml , errText @@ -52,20 +58,40 @@ ) where import qualified Blaze.ByteString.Builder.Char.Utf8 as B +import Control.Arrow (second) import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB import Data.Either (rights) +import qualified Data.HashMap.Strict as HM import Data.Maybe (fromJust) 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 (FileInfo (..), Param, + lbsBackEnd, + parseRequestBody) +import qualified Network.Wai.Parse as Parse +import System.Directory (doesFileExist) +import System.FilePath (takeExtension) 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. + +-- | 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])) + +-- | A default request, which is a WAI defaultRequest and no post info +defaultFnRequest :: FnRequest +defaultFnRequest = (defaultRequest, ([],[])) + +-- | Specify the way that Fn can get the 'FnRequest' 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'. @@ -73,29 +99,68 @@ -- 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 :: Functor f => (FnRequest -> f FnRequest) -> ctxt -> f ctxt requestLens f c = setRequest c <$> f (getRequest c) - getRequest :: ctxt -> Request + getRequest :: ctxt -> FnRequest getRequest c = let (Store r _) = requestLens (`Store` id) c in r - setRequest :: ctxt -> Request -> ctxt + setRequest :: ctxt -> FnRequest -> ctxt setRequest c r = let (Store _ b) = requestLens (`Store` id) c in b r +instance RequestContext FnRequest where + getRequest = id + setRequest _ = id + -- | Convert an Fn application (provide a context, a context to response --- function and we'll create a WAI application by updating the Request +-- function and we'll create a WAI application by updating the 'FnRequest' -- 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 +toWAI ctxt f req cont = + do post <- parseRequestBody lbsBackEnd req + let ctxt' = setRequest ctxt (req, post) + f ctxt' >>= 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 +-- 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 :: Ctxt -> IO (Maybe Response) +-- index _ = okText "This is the index." +-- h :: Ctxt -> Text -> Text -> IO (Maybe Response) +-- h _ s i = okText ("got path \/foo\/" <> s <> ", with id=" <> i) +-- @ +route :: RequestContext ctxt => + ctxt -> + [ctxt -> Req -> Maybe (IO (Maybe Response))] -> + IO (Maybe Response) +route ctxt pths = + do let (r,post) = getRequest ctxt + m = either (const GET) id (parseMethod (requestMethod r)) + req = (pathInfo r, queryString r, m, post) + 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) + -- | 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. +-- - this is what 'fallthrough' allows you to specify. In particular, +-- 'notFoundText' and 'notFoundHtml' may be useful. fallthrough :: IO (Maybe Response) -> IO Response -> IO Response fallthrough a ft = do response <- a @@ -103,35 +168,99 @@ 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. +-- NOTE(dbp 2015-11-05): This list taken from snap-core, BSD3 licensed. +mimeMap :: HM.HashMap String ByteString +mimeMap = HM.fromList [ + ( ".asc" , "text/plain" ), + ( ".asf" , "video/x-ms-asf" ), + ( ".asx" , "video/x-ms-asf" ), + ( ".avi" , "video/x-msvideo" ), + ( ".bz2" , "application/x-bzip" ), + ( ".c" , "text/plain" ), + ( ".class" , "application/octet-stream" ), + ( ".conf" , "text/plain" ), + ( ".cpp" , "text/plain" ), + ( ".css" , "text/css" ), + ( ".cxx" , "text/plain" ), + ( ".dtd" , "text/xml" ), + ( ".dvi" , "application/x-dvi" ), + ( ".gif" , "image/gif" ), + ( ".gz" , "application/x-gzip" ), + ( ".hs" , "text/plain" ), + ( ".htm" , "text/html" ), + ( ".html" , "text/html" ), + ( ".ico" , "image/x-icon" ), + ( ".jar" , "application/x-java-archive" ), + ( ".jpeg" , "image/jpeg" ), + ( ".jpg" , "image/jpeg" ), + ( ".js" , "text/javascript" ), + ( ".json" , "application/json" ), + ( ".log" , "text/plain" ), + ( ".m3u" , "audio/x-mpegurl" ), + ( ".mov" , "video/quicktime" ), + ( ".mp3" , "audio/mpeg" ), + ( ".mpeg" , "video/mpeg" ), + ( ".mpg" , "video/mpeg" ), + ( ".ogg" , "application/ogg" ), + ( ".pac" , "application/x-ns-proxy-autoconfig" ), + ( ".pdf" , "application/pdf" ), + ( ".png" , "image/png" ), + ( ".ps" , "application/postscript" ), + ( ".qt" , "video/quicktime" ), + ( ".sig" , "application/pgp-signature" ), + ( ".spl" , "application/futuresplash" ), + ( ".svg" , "image/svg+xml" ), + ( ".swf" , "application/x-shockwave-flash" ), + ( ".tar" , "application/x-tar" ), + ( ".tar.bz2" , "application/x-bzip-compressed-tar" ), + ( ".tar.gz" , "application/x-tgz" ), + ( ".tbz" , "application/x-bzip-compressed-tar" ), + ( ".text" , "text/plain" ), + ( ".tgz" , "application/x-tgz" ), + ( ".torrent" , "application/x-bittorrent" ), + ( ".ttf" , "application/x-font-truetype" ), + ( ".txt" , "text/plain" ), + ( ".wav" , "audio/x-wav" ), + ( ".wax" , "audio/x-ms-wax" ), + ( ".wma" , "audio/x-ms-wma" ), + ( ".wmv" , "video/x-ms-wmv" ), + ( ".xbm" , "image/x-xbitmap" ), + ( ".xml" , "text/xml" ), + ( ".xpm" , "image/x-xpixmap" ), + ( ".xwd" , "image/x-xwindowdump" ), + ( ".zip" , "application/zip" ) ] + + +-- | Serves static files out of the specified path according to the +-- request path. Note that if you have matched parts of the path, +-- those will not be included in the path used to find the static +-- file. For example, if you have a file @static\/img\/a.png@, and do: -- --- @ --- 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) +-- > path "img" ==> staticServe "static" +-- +-- It will match @img\/img\/a.png@, not @img\/a.png@. If you wanted that, +-- you could: +-- +-- > anything ==> staticServe "static" +-- +-- If no file is found, 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 -- | The parts of the path, when split on /, and the query. -type Req = ([Text], Query, StdMethod) +type Req = ([Text], Query, StdMethod, ([Param], [Parse.File LB.ByteString])) -- | The connective between route patterns and the handler that will -- be called if the pattern matches. The type is not particularly @@ -142,14 +271,14 @@ (Req -> Maybe (Req, k -> a)) -> (ctxt -> k) -> ctxt -> + Req -> Maybe a -(match ==> handle) ctxt = - let r = getRequest ctxt - m = either (const GET) id (parseMethod (requestMethod r)) - x = (pathInfo r, queryString r, m) - in case match x of - Nothing -> Nothing - Just ((pathInfo',_,_), k) -> Just (k $ handle (setRequest ctxt ((getRequest ctxt) { pathInfo = pathInfo' }))) +(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))) -- | Connects two path segments. Note that when normally used, the -- type parameter r is 'Req'. It is more general here to facilitate @@ -164,7 +293,7 @@ Nothing -> Nothing Just (req'', k') -> Just (req'', k' . k) --- | Identical to '(//)', provided simply because it serves as a +-- | 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')) -> @@ -177,7 +306,7 @@ path :: Text -> Req -> Maybe (Req, a -> a) path s req = case req of - (x:xs,q,m) | x == s -> Just ((xs, q, m), id) + (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 @@ -185,7 +314,7 @@ end :: Req -> Maybe (Req, a -> a) end req = case req of - ([],_,_) -> Just (req, id) + ([],_,_,_) -> Just (req, id) _ -> Nothing -- | Matches anything. @@ -198,20 +327,20 @@ segment :: FromParam p => Req -> Maybe (Req, (p -> a) -> a) segment req = case req of - (x:xs,q,m) -> case fromParam x of - Left _ -> Nothing - Right p -> Just ((xs, q, m), \k -> k p) + (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 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'. +-- | A class that is used for parsing for 'param', 'paramOpt', 'paramMany' +-- and 'segment'. class FromParam a where fromParam :: Text -> Either ParamError a @@ -230,29 +359,40 @@ Left ParamUnparsable Right (v, _) -> Right v + +findParamMatches :: FromParam p => Text -> [(ByteString, Maybe ByteString)] -> [Either ParamError p] +findParamMatches n ps = map (fromParam . 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) 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 + 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 -- | Matches on query parameters of the given name. If there are no --- parameters, or it cannot be parsed into the type needed by the +-- 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 n req = - let (_,q,_) = req - match = filter ((== T.encodeUtf8 n) . fst) q - in case map (maybe "" T.decodeUtf8 . snd) match of + let (_,q,_,(ps,_)) = req + in case findParamMatches n (q ++ map (second Just) ps) of [] -> Nothing - xs -> let ps = rights $ map fromParam xs in - if length ps == length xs - then Just (req, \k -> k ps) + xs -> let ys = rights xs in + if length ys == length xs + then Just (req, \k -> k ys) else Nothing -- | If the specified parameters are present, they will be parsed into the @@ -263,14 +403,42 @@ 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 + let (_,q,_,(ps, _)) = req + in case findParamMatches n (q ++ map (second Just) ps) of [] -> Just (req, \k -> k (Left ParamMissing)) - ps -> Just (req, \k -> k (foldLefts [] (map fromParam ps))) + 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 + + +-- | An uploaded file. +data File = File { fileName :: Text + , fileContentType :: Text + , fileContent :: LB.ByteString + } + +-- | Matches an uploaded file with the given parameter name. +file :: Text -> Req -> 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 + +-- | Matches all uploaded files, passing their parameter names and +-- contents. +files :: Req -> 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) 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,29 +12,36 @@ 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) + getRequest (R (p',q')) = (defaultRequest { pathInfo = p', queryString = q' }, ([],[])) + setRequest (R _) (r,_) = R (pathInfo r, queryString r) +rr :: R +rr = R ([], []) p :: [Text] -> Req -p x = (x,[],GET) +p y = (y,[],GET,([],[])) _p :: [Text] -> Req -> Req -_p x (_,q',m') = (x,q',m') +_p y (_,q',m',x') = (y,q',m',x') q :: Query -> Req -q x = ([],x,GET) +q y = ([],y,GET,([],[])) _q :: Query -> Req -> Req -_q x (p',_,m') = (p',x,m') +_q y (p',_,m',x') = (p',y,m',x') m :: StdMethod -> Req -m x = ([],[],x) +m y = ([],[],y,([],[])) _m :: StdMethod -> Req -> Req -_m x (p',q',_) = (p',q',x) +_m y (p',q',_,x') = (p',q',y,x') -j m = fst <$> m `shouldSatisfy` isJust -n m = fst <$> m `shouldSatisfy` isNothing -v m f = snd (fromJust m) f `shouldBe` True -vn m f = case m of - Nothing -> 1 `shouldBe` 1 - Just (_,k) -> k f `shouldBe` False +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 @@ -94,20 +101,18 @@ 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"], [])) + do (path "a" ==> const ()) rr (p ["a"]) `shouldSatisfy` isJust - (segment ==> \_ (_ :: Text) -> ()) - (R (["a"], [])) + (segment ==> \_ (_ :: Text) -> ()) rr (p ["1"]) `shouldSatisfy` isJust (segment // path "b" ==> \_ x -> x == ("a" :: Text)) - (R (["a", "b"], [])) + rr (p ["a", "b"]) `shouldSatisfy` fromJust (segment // path "b" ==> \_ x -> x == ("a" :: Text)) - (R (["a", "a"], [])) + rr (p ["a", "a"]) `shouldSatisfy` isNothing (segment // path "b" ==> \_ x -> x == ("a" :: Text)) - (R (["a"], [])) + rr (p ["a"]) `shouldSatisfy` isNothing it "should always pass a value with paramOpt" $ do snd (fromJust (paramOpt "id" (q []))) @@ -128,8 +133,8 @@ j (anything (p ["f","b"])) it "should match against method" $ - do j ((method GET) (m GET)) - n ((method GET) (m POST)) + do j (method GET (m GET)) + n (method GET (m POST)) describe "route" $ do it "should match route to parameter" $