fn 0.2.0.2 → 0.3.0.0

raw patch · 4 files changed

+317/−179 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−1
• fn.cabal +5/−5
• src/Web/Fn.hs +242/−138
• test/Spec.hs +51/−35

@@ -1,6 +1,24 @@+* 0.3.0.0 Daniel Patterson <dbp@dbpmail.net> 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 <dbp@dbpmail.net> 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 <dbp@dbpmail.net> 2015-12-4 

@@ -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/ <https://github.com/commercialhaskell/stack#readme stack> /installed, you can run this example like a shell script:/+  /Provided you have/ <https://github.com/commercialhaskell/stack#readme stack> /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     &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125;     import Data.Monoid ((&#60;&#62;))     import Data.Text (Text)@@ -30,7 +30,7 @@     .     site :: Ctxt -> IO Response     site ctxt = route ctxt [ end                        ==> indexH-    &#32;                      , path &#34;echo&#34; \/? param &#34;msg&#34; ==> echoH+    &#32;                      , path &#34;echo&#34; \/\/ param &#34;msg&#34; ==> echoH     &#32;                      , path &#34;echo&#34; \/\/ segment     ==> echoH     &#32;                      ]     &#32;                 \`fallthrough\` notFoundText &#34;Page not found.&#34;@@ -72,7 +72,7 @@ license-file:        LICENSE author:              Daniel Patterson <dbp@dbpmail.net> maintainer:          dbp@dbpmail.net-copyright:           2015 Daniel Patterson+copyright:           2016 Daniel Patterson category:            Web build-type:          Simple extra-source-files:  CHANGELOG.md

@@ -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)

@@ -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 _ = "<MVar>"+ 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)