diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +* 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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,7 +46,7 @@ index :: IO (Maybe Response) index = okText "This is the index page! Try /foo/bar/baz?id=10" -handler :: Ctxt -> Text -> Int -> IO (Maybe Response) -handler _ fragment i = okText (fragment <> " - " <> T.pack (show i)) +handler :: Text -> Int -> Ctxt -> IO (Maybe Response) +handler fragment i _ = okText (fragment <> " - " <> T.pack (show i)) ``` diff --git a/fn.cabal b/fn.cabal --- a/fn.cabal +++ b/fn.cabal @@ -1,5 +1,5 @@ name: fn -version: 0.1.2.0 +version: 0.1.3.0 synopsis: A functional web framework. description: Please see README. homepage: http://github.com/dbp/fn#readme diff --git a/src/Web/Fn.hs b/src/Web/Fn.hs --- a/src/Web/Fn.hs +++ b/src/Web/Fn.hs @@ -33,9 +33,12 @@ , (/?) , path , end + , anything , segment , FromParam(..) + , ParamError(..) , param + , paramMany , paramOpt -- * Responses , okText @@ -49,11 +52,9 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as B import Data.ByteString (ByteString) -import Data.List (find) +import Data.Either (rights) import Data.Maybe (fromJust) -import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Text.Read (decimal, double) import Network.HTTP.Types @@ -137,15 +138,15 @@ -- patterns with varying numbers (and types) of parts with functions -- of the corresponding number of arguments and types. (==>) :: RequestContext ctxt => - (Req -> k -> Maybe (Req, a)) -> - (ctxt -> k) -> + (Req -> k -> Maybe (Req, ctxt -> a)) -> + k -> ctxt -> Maybe a (match ==> handle) ctxt = let r = getRequest ctxt x = (pathInfo r, queryString r) - in case match x (handle ctxt) of + in case match x handle of Nothing -> Nothing - Just (_, action) -> Just action + Just ((pathInfo',_), action) -> Just (action (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 @@ -184,6 +185,10 @@ [] -> Just (req, k) _ -> Nothing +-- | Matches anything. +anything :: Req -> a -> Maybe (Req, a) +anything req k = Just (req, k) + -- | 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. @@ -195,53 +200,68 @@ Right p -> Just ((xs, snd req), k p) _ -> 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 Text a + fromParam :: Text -> Either ParamError a instance FromParam Text where fromParam = Right instance FromParam Int where fromParam t = case decimal t of - Left msg -> Left (T.pack msg) + Left _ -> Left ParamUnparsable Right m | snd m /= "" -> - Left ("Incomplete match: " <> T.pack (show m)) + Left ParamUnparsable Right (v, _) -> Right v instance FromParam Double where fromParam t = case double t of - Left msg -> Left (T.pack msg) + Left _ -> Left ParamUnparsable Right m | snd m /= "" -> - Left ("Incomplete match: " <> T.pack (show m)) + Left ParamUnparsable Right (v, _) -> Right v --- | Matches on a query parameter of the given name. If there is no --- parameter, or it cannot be parsed into the type needed by the +-- | 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 -> (p -> a) -> Maybe (Req, a) param n req k = - let match = find ((== T.encodeUtf8 n) . fst) (snd req) - in case (maybe "" T.decodeUtf8 . snd) <$> match of - Nothing -> Nothing - Just p -> case fromParam p of - Left _ -> Nothing - Right p' -> Just (req, k p') + let match = filter ((== T.encodeUtf8 n) . fst) (snd req) + in case rights (map (fromParam . maybe "" T.decodeUtf8 . snd) match) of + [x] -> Just (req, k x) + _ -> Nothing --- | If the specified parameter is present, it will be parsed into the --- type needed by the handler, but if it isn't present or cannot be --- parsed, the handler will still be called (just with the 'Left' --- variant). +-- | 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 -> ([p] -> a) -> Maybe (Req, a) +paramMany n req k = + let match = filter ((== T.encodeUtf8 n) . fst) (snd req) + 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 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 -> - (Either Text p -> a) -> + (Either ParamError [p] -> a) -> Maybe (Req, a) paramOpt n req k = - let match = find ((== T.encodeUtf8 n) . fst) (snd req) - p = ((maybe "" T.decodeUtf8 . snd) <$> match) - in case p of - Nothing -> Just (req, k (Left "param missing")) - Just p' -> Just (req, k (fromParam p')) + let match = filter ((== T.encodeUtf8 n) . fst) (snd req) + + in case map (maybe "" T.decodeUtf8 . snd) match of + [] -> Just (req, k (Left ParamMissing)) + ps -> Just (req, 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 = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -18,7 +18,7 @@ main :: IO () main = hspec $ do - describe "routing" $ do + describe "matching" $ do it "should match first segment with path" $ do path "foo" (["foo", "bar"], []) () `shouldSatisfy` isJust path "foo" ([], []) () `shouldSatisfy` isNothing @@ -97,23 +97,23 @@ do (path "a" ==> const ()) (R (["a"], [])) `shouldSatisfy` isJust - (segment ==> \_ (_ :: Text) -> ()) + (segment ==> \(_ :: Text) _ -> ()) (R (["a"], [])) `shouldSatisfy` isJust - (segment // path "b" ==> \_ x -> x == ("a" :: Text)) + (segment // path "b" ==> \x _ -> x == ("a" :: Text)) (R (["a", "b"], [])) `shouldSatisfy` fromJust - (segment // path "b" ==> \_ x -> x == ("a" :: Text)) + (segment // path "b" ==> \x _ -> x == ("a" :: Text)) (R (["a", "a"], [])) `shouldSatisfy` isNothing - (segment // path "b" ==> \_ x -> x == ("a" :: Text)) + (segment // path "b" ==> \x _ -> x == ("a" :: Text)) (R (["a"], [])) `shouldSatisfy` isNothing it "should always pass a value with paramOpt" $ - do paramOpt "id" ([], []) (isLeft :: Either Text Text -> Bool) + do paramOpt "id" ([], []) (isLeft :: Either ParamError [Text] -> Bool) `shouldSatisfy` (snd . fromJust) paramOpt "id" ([], [("id", Just "foo")]) - (== Right ("foo" :: Text)) + (== Right (["foo"] :: [Text])) `shouldSatisfy` (snd . fromJust) it "should match end against no further path segments" $ do end ([],[]) () `shouldSatisfy` isJust @@ -123,7 +123,16 @@ do (path "a" // end) (["a"],[]) () `shouldSatisfy` isJust (segment // end) (["a"],[]) (== ("a" :: Text)) `shouldSatisfy` isJust + it "should match anything" $ + anything ([],[]) () `shouldSatisfy` isJust + 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" $ @@ -132,13 +141,13 @@ do fromParam "1" `shouldBe` Right (1 :: Int) fromParam "2011" `shouldBe` Right (2011 :: Int) fromParam "aaa" `shouldSatisfy` - (isLeft :: Either Text Int -> Bool) + (isLeft :: Either ParamError Int -> Bool) fromParam "10a" `shouldSatisfy` - (isLeft :: Either Text Int -> Bool) + (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 Text Double -> Bool) + (isLeft :: Either ParamError Double -> Bool) fromParam "100o" `shouldSatisfy` - (isLeft :: Either Text Double -> Bool) + (isLeft :: Either ParamError Double -> Bool)