fn-0.1.3.1: test/Spec.hs
{-# 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 x = (x,[],GET)
_p :: [Text] -> Req -> Req
_p x (_,q',m') = (x,q',m')
q :: Query -> Req
q x = ([],x,GET)
_q :: Query -> Req -> Req
_q x (p',_,m') = (p',x,m')
m :: StdMethod -> Req
m x = ([],[],x)
_m :: StdMethod -> Req -> Req
_m x (p',q',_) = (p',q',x)
main :: IO ()
main = hspec $ do
describe "matching" $ do
it "should match first segment with path" $
do path "foo" (p ["foo", "bar"]) () `shouldSatisfy` isJust
path "foo" (p []) () `shouldSatisfy` isNothing
path "foo" (p ["bar", "foo"]) () `shouldSatisfy` isNothing
it "should match two paths combined with //" $
do (path "a" // path "b") (p ["a", "b"]) () `shouldSatisfy` isJust
(path "b" // path "a") (p ["a", "b"]) () `shouldSatisfy` isNothing
(path "b" // path "a") (p ["b"]) () `shouldSatisfy` isNothing
it "should pass url segment to segment" $
do segment (p ["a"]) (== ("a" :: Text))
`shouldSatisfy` (snd . fromJust)
segment (p []) (id :: Text -> Text) `shouldSatisfy` isNothing
segment (p ["a", "b"]) (== ("a" :: Text))
`shouldSatisfy` (snd . fromJust)
it "should match two segments combined with //" $
do (segment // segment) (p ["a", "b"]) (\a b -> a == ("a" :: Text) &&
b == ("b" :: Text))
`shouldSatisfy` (snd . fromJust)
(segment // segment) (p []) (\(_ :: Text) (_ :: Text) -> ())
`shouldSatisfy` isNothing
(segment // segment) (p ["a", "b", "c"])
(\a b -> a == ("a" :: Text) &&
b == ("b" :: Text))
`shouldSatisfy` (snd . fromJust)
it "should match path and segment combined with //" $
do (path "a" // segment) (p ["a", "b"]) (== ("b" :: Text))
`shouldSatisfy` (snd . fromJust)
(path "a" // segment) (p ["b", "b"]) (== ("b" :: Text))
`shouldSatisfy` isNothing
(segment // path "b") (p ["a", "b"]) (== ("a" :: Text))
`shouldSatisfy` (snd . fromJust)
it "should match many segments and paths together" $
do (path "a" // segment // path "c" // path "d")
(p ["a","b","c", "d"])
(== ("b" :: Text))
`shouldSatisfy` (snd . fromJust)
(segment // path "b" // segment // segment)
(p ["a","b","c", "d", "e"])
(\a c d -> a == ("a" :: Text) &&
c == ("c" :: Text) &&
d == ("d" :: Text))
`shouldSatisfy` (snd . fromJust)
(segment // path "b" // segment)
(p ["a", "b"]) (\(_ :: Text) (_ :: Text) -> True)
`shouldSatisfy` isNothing
(segment // path "a" // segment)
(p ["a", "b"]) (\(_ :: Text) (_ :: Text) -> True)
`shouldSatisfy` isNothing
it "should match query parameters with param" $
do param "foo" (q [("foo", Nothing)]) (== ("" :: Text))
`shouldSatisfy` (snd . fromJust)
param "foo" (q []) (\(_ :: Text) -> True) `shouldSatisfy` isNothing
it "should match combined param and paths with /?" $
do (path "a" /? param "id") (_p ["a"] $ q [("id", Just "x")])
(== ("x" :: Text))
`shouldSatisfy` (snd . fromJust)
(path "a" /? param "id") (_p ["b"] $ q [("id", Just "x")])
(== ("x" :: Text))
`shouldSatisfy` isNothing
(path "a" /? param "id") (_p [] $ q [("id", Just "x")])
(== ("x" :: Text))
`shouldSatisfy` isNothing
(path "a" /? param "id") (_p ["a"] $ q [("di", Just "x")])
(== ("x" :: Text))
`shouldSatisfy` isNothing
it "should match combining param, path, segment" $
do (path "a" // segment /? param "id")
(_p ["a", "b"] $ q [("id", Just "x")])
(\b x -> b == ("b" :: Text) && x == ("x" :: Text))
`shouldSatisfy` (snd . fromJust)
(path "a" // segment // segment /? param "id")
(_p ["a", "b"] $ q [("id", Just "x")])
(\(_ :: Text) (_ :: Text) (_ :: Text) -> True)
`shouldSatisfy` isNothing
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 paramOpt "id" (q []) (isLeft :: Either ParamError [Text] -> Bool)
`shouldSatisfy` (snd . fromJust)
paramOpt "id" (q [("id", Just "foo")])
(== Right (["foo"] :: [Text]))
`shouldSatisfy` (snd . fromJust)
it "should match end against no further path segments" $
do end (p []) () `shouldSatisfy` isJust
end (_p [] $ q [("foo", Nothing)]) () `shouldSatisfy` isJust
end (p ["a"]) () `shouldSatisfy` isNothing
it "should match end after path and segments" $
do (path "a" // end) (p ["a"]) () `shouldSatisfy` isJust
(segment // end) (p ["a"]) (== ("a" :: Text))
`shouldSatisfy` isJust
it "should match anything" $
do anything (p []) () `shouldSatisfy` isJust
anything (p ["f","b"]) () `shouldSatisfy` isJust
it "should match against method" $
do (method GET) (m GET) () `shouldSatisfy` isJust
(method GET) (m POST) () `shouldSatisfy` isNothing
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)