{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Routing.Tests ( tests ) where ------------------------------------------------------------------------------ import Control.Applicative ((<|>)) import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.Map as Map import Data.Maybe import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types import Snap.Internal.Routing import Snap.Internal.Types import Snap.Test import Snap.Test.Common ------------------------------------------------------------------------------ tests :: [Test] tests = [ testRouting1 , testRouting2 , testRouting3 , testRouting4 , testRouting5 , testRouting6 , testRouting7 , testRouting8 , testRouting9 , testRouting10 , testRouting11 , testRouting12 , testRouting13 , testRouting14 , testRouting15 , testRouting16 , testRouting17 , testRouting18 , testRouting19 , testRouting20 , testRouting21 , testRouting22 , testRouting23 , testRouting24 , testRouting25 , testRouting26 , testRouting27 , testRouting28 , testRouteLocal , testRouteUrlDecode , testRouteUrlEncodedPath , testRouteEmptyCapture ] ------------------------------------------------------------------------------ go :: Snap a -> ByteString -> IO a go m s0 = evalHandler (get s Map.empty) m where s = if S.isPrefixOf "/" s0 then s0 else S.append "/" s0 ------------------------------------------------------------------------------ routes :: Snap ByteString routes = route [ ("foo" , topFoo ) , ("foo/bar" , fooBar ) , ("foo/bar/baz" , getRqPathInfo ) , ("foo/:id" , fooCapture ) , ("bar/:id" , fooCapture ) , ("herp/:derp/" , getRqPathInfo ) , ("nerp/:derp/" , getRqContextPath) , ("a b c d" , return "OK" ) , ("bar/quux" , barQuux ) , ("bar" , bar ) , ("z/:a/:b/:c/d" , zabc ) ] ------------------------------------------------------------------------------ routesLocal :: Snap ByteString routesLocal = routeLocal [ ("foo/bar/baz" , getRqPathInfo ) , ("bar" , pass ) ] ------------------------------------------------------------------------------ routes2 :: Snap ByteString routes2 = route [ ("" , topTop ) , ("foo" , topFoo ) ] ------------------------------------------------------------------------------ routes3 :: Snap ByteString routes3 = route [ (":foo" , topCapture ) , ("" , topTop ) ] ------------------------------------------------------------------------------ routes4 :: Snap ByteString routes4 = route [ (":foo" , pass ) , (":foo" , topCapture ) , (":qqq/:id" , fooCapture ) , (":id2/baz" , fooCapture2 ) ] ------------------------------------------------------------------------------ routes5 :: Snap ByteString routes5 = route [ ("" , pass ) , ("" , topTop ) ] ------------------------------------------------------------------------------ routes6 :: Snap ByteString routes6 = route [ (":a/:a" , dblA ) ] ------------------------------------------------------------------------------ routes7 :: Snap ByteString routes7 = route [ ("foo/:id" , fooCapture ) , ("foo/:id/:id2" , fooCapture2) , ("fooo/:id/:id2" , fooCapture2) , ("foooo/bar/baz" , bar ) , ("" , topTop ) ] ------------------------------------------------------------------------------ routesEmptyCapture :: Snap ByteString routesEmptyCapture = route [ ("foo/:id", fooCapture) ] ------------------------------------------------------------------------------ topTop, topFoo, fooBar, fooCapture, getRqPathInfo, bar, getRqContextPath, barQuux, dblA, zabc, topCapture, fooCapture2 :: Snap ByteString dblA = do ma <- getParam "a" unless (ma == Just "a a") pass return "ok" zabc = do ma <- getParam "a" mb <- getParam "b" mc <- getParam "c" unless ( ma == Just "a" && mb == Just "b" && mc == Just "c" ) pass return "ok" topCapture = do mp <- getParam "foo" maybe pass return mp topTop = return "topTop" topFoo = return "topFoo" fooBar = return "fooBar" fooCapture = liftM (head . fromJust . rqParam "id") getRequest fooCapture2 = liftM (head . fromJust . rqParam "id2") getRequest getRqPathInfo = liftM rqPathInfo getRequest getRqContextPath = liftM rqContextPath getRequest barQuux = return "barQuux" bar = return "bar" ----------- -- Tests -- ----------- ------------------------------------------------------------------------------ -- TODO more useful test names testRouting1 :: Test testRouting1 = testCase "route/1" $ do r1 <- go routes "foo" assertEqual "/foo" "topFoo" r1 ------------------------------------------------------------------------------ testRouting2 :: Test testRouting2 = testCase "route/2" $ do r2 <- go routes "foo/baz" assertEqual "/foo/baz" "baz" r2 ------------------------------------------------------------------------------ testRouting3 :: Test testRouting3 = testCase "route/3" $ do expectExceptionH $ go routes "/xsaxsaxsax" ------------------------------------------------------------------------------ testRouting4 :: Test testRouting4 = testCase "route/4" $ do r3 <- go routes "foo/bar" assertEqual "/foo/bar" "fooBar" r3 ------------------------------------------------------------------------------ testRouting5 :: Test testRouting5 = testCase "route/5" $ do r4 <- go routes "foo/bar/baz/quux" assertEqual "/foo/bar/baz/quux" "quux" r4 ------------------------------------------------------------------------------ testRouting6 :: Test testRouting6 = testCase "route/6" $ do r5 <- go routes "foo/bar/sproing" assertEqual "/foo/bar/sproing" "fooBar" r5 ------------------------------------------------------------------------------ testRouting7 :: Test testRouting7 = testCase "route/7" $ do r <- go routes "bar" assertEqual "/bar" "bar" r ------------------------------------------------------------------------------ testRouting8 :: Test testRouting8 = testCase "route/8" $ do r2 <- go routes "bar/quux" assertEqual "/bar/quux" "barQuux" r2 ------------------------------------------------------------------------------ testRouting9 :: Test testRouting9 = testCase "route/9" $ do r3 <- go routes "bar/whatever" assertEqual "/bar/whatever" "whatever" r3 ------------------------------------------------------------------------------ testRouting10 :: Test testRouting10 = testCase "route/10" $ do r4 <- go routes "bar/quux/whatever" assertEqual "/bar/quux/whatever" "barQuux" r4 ------------------------------------------------------------------------------ testRouting11 :: Test testRouting11 = testCase "route/11" $ do r1 <- go routes2 "" assertEqual "/" "topTop" r1 ------------------------------------------------------------------------------ testRouting12 :: Test testRouting12 = testCase "route/12" $ do r1 <- go routes2 "foo" assertEqual "/foo" "topFoo" r1 ------------------------------------------------------------------------------ testRouting13 :: Test testRouting13 = testCase "route/13" $ do r1 <- go routes3 "zzzz" assertEqual "/zzzz" "zzzz" r1 ------------------------------------------------------------------------------ testRouting14 :: Test testRouting14 = testCase "route/14" $ do r1 <- go routes3 "" assertEqual "/" "topTop" r1 ------------------------------------------------------------------------------ testRouting15 :: Test testRouting15 = testCase "route/15" $ do r1 <- go routes4 "zzzz" assertEqual "/zzzz" "zzzz" r1 ------------------------------------------------------------------------------ testRouting16 :: Test testRouting16 = testCase "route/16" $ do r1 <- go routes5 "" assertEqual "/" "topTop" r1 ------------------------------------------------------------------------------ testRouting17 :: Test testRouting17 = testCase "route/17" $ do r1 <- go routes "z/a/b/c/d" assertEqual "/z/a/b/c/d" "ok" r1 ------------------------------------------------------------------------------ testRouting18 :: Test testRouting18 = testCase "route/18" $ do r1 <- go routes6 "a/a" assertEqual "/a/a" "ok" r1 ------------------------------------------------------------------------------ testRouting19 :: Test testRouting19 = testCase "route/19" $ do r1 <- go routes7 "foo" assertEqual "/foo" "topTop" r1 ------------------------------------------------------------------------------ testRouting20 :: Test testRouting20 = testCase "route/20" $ do r1 <- go routes7 "foo/baz" assertEqual "/foo/baz" "baz" r1 ------------------------------------------------------------------------------ testRouting21 :: Test testRouting21 = testCase "route/21" $ do r1 <- go routes7 "foo/baz/quux" assertEqual "/foo/baz/quux" "quux" r1 ------------------------------------------------------------------------------ testRouting22 :: Test testRouting22 = testCase "route/22" $ do r1 <- go routes7 "fooo/baz" assertEqual "/fooo/baz" "topTop" r1 ------------------------------------------------------------------------------ testRouting23 :: Test testRouting23 = testCase "route/23" $ do r1 <- go routes7 "fooo/baz/quux" assertEqual "/fooo/baz/quux" "quux" r1 ------------------------------------------------------------------------------ testRouting24 :: Test testRouting24 = testCase "route/24" $ do r1 <- go routes7 "foooo/bar/bax" assertEqual "/foooo/bar/bax" "topTop" r1 ------------------------------------------------------------------------------ testRouting25 :: Test testRouting25 = testCase "route/25" $ do r1 <- go routes7 "foooo/bar/baz" assertEqual "/foooo/bar/baz" "bar" r1 ------------------------------------------------------------------------------ testRouting26 :: Test testRouting26 = testCase "route/26" $ do r1 <- go routes4 "foo/bar" assertEqual "capture union" "bar" r1 ------------------------------------------------------------------------------ testRouting27 :: Test testRouting27 = testCase "route/27" $ do r1 <- go routes4 "foo" assertEqual "capture union" "foo" r1 ------------------------------------------------------------------------------ testRouting28 :: Test testRouting28 = testCase "route/28" $ do r1 <- go routes4 "quux/baz" assertEqual "capture union" "quux" r1 ------------------------------------------------------------------------------ testRouteUrlDecode :: Test testRouteUrlDecode = testCase "route/urlDecode" $ do r1 <- go routes "herp/%7Bderp%7D/" assertEqual "rqPathInfo on urldecode" "" r1 r2 <- go routes "foo/%7Bderp%7D/" assertEqual "urldecoded capture" "{derp}" r2 r3 <- go routes "nerp/%7Bderp%7D/" assertEqual "rqContextPath on urldecode" "/nerp/%7Bderp%7D/" r3 ------------------------------------------------------------------------------ testRouteUrlEncodedPath :: Test testRouteUrlEncodedPath = testCase "route/urlEncodedPath" $ do -- make sure path search urlDecodes. r1 <- go routes "a+b+c+d" assertEqual "urlEncoded search works" "OK" r1 ------------------------------------------------------------------------------ testRouteLocal :: Test testRouteLocal = testCase "route/routeLocal" $ do r4 <- go routesLocal "foo/bar/baz/quux" assertEqual "/foo/bar/baz/quux" "foo/bar/baz/quux" r4 expectExceptionH $ go routesLocal "bar" ------------------------------------------------------------------------------ testRouteEmptyCapture :: Test testRouteEmptyCapture = testCase "route/emptyCapture" $ do r <- go m "foo" assertEqual "empty capture must fail" expected r r2 <- go m "foo/" assertEqual "empty capture must fail" expected r2 where expected = "ZOMG_OK" m = routesEmptyCapture <|> return expected