content: {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module Snap.Internal.Routing.Tests
    ( tests ) where
  
  ------------------------------------------------------------------------------
  import           Control.Applicative            ((<|>))
  import           Control.Exception              (ErrorCall (..), throwIO)
  import           Control.Monad                  (liftM, unless)
  import           Control.Monad.Trans            (liftIO)
  import           Data.ByteString                (ByteString)
  import qualified Data.ByteString                as S (append, isPrefixOf)
  import qualified Data.Map                       as Map (empty)
  import           Data.Maybe                     (fromJust)
  import           Snap.Internal.Core             (Snap, getParam, getRequest, modifyRequest, pass)
  import           Snap.Internal.Http.Types       (Request (rqContextPath, rqPathInfo), rqParam, rqSetParam)
  import           Snap.Internal.Routing          (Route (NoRoute), route, routeEarliestNC, routeHeight, routeLocal)
  import           Snap.Test                      (evalHandler, get)
  import           Snap.Test.Common               (expectExceptionH)
  import           Test.Framework                 (Test)
  import           Test.Framework.Providers.HUnit (testCase)
  import           Test.HUnit                     (assertEqual)
  #if !MIN_VERSION_base(4,8,0)
  import           Control.Applicative            ((<$>))
  #endif
  ------------------------------------------------------------------------------
  
  
  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
          , testRouteCaptureConflicts
          , testTrivials
          , testParamUnification
          , testFailedUrlDecode
          , testDirFallthrough
          ]
  
  
  ------------------------------------------------------------------------------
  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            )
                           , ("quux/zzz"     , getRqContextPath)
                           ]
  
  
  ------------------------------------------------------------------------------
  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"
  
      go routesLocal "quux/zzz" >>= assertEqual "context" "/"
  
  
  ------------------------------------------------------------------------------
  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
  
  
  ------------------------------------------------------------------------------
  testRouteCaptureConflicts :: Test
  testRouteCaptureConflicts = testCase "route/captureConflicts" $ do
      go h1 "ok/ok/ok" >>= assertEqual "earliest non-capture/1" "ok"
      go h2 "ok/ok/ok" >>= assertEqual "earliest non-capture/2" "ok"
      go h3 "foo/ok/ok/ok" >>= assertEqual "earliest non-capture/3" "ok"
      go h4 "foo/ok/ok/ok" >>= assertEqual "earliest non-capture/4" "ok"
      go h5 "zz/aa/zz" >>= assertEqual "fallback" "fb1"
      go h6 "zz" >>= assertEqual "rightmost" "fb2"
  
    where
      puke = liftIO . throwIO . ErrorCall
      ok   = return ("ok" :: String)
      fb1  = return ("fb1" :: String)
      fb2  = return ("fb2" :: String)
  
      -- rule: earliest non-capture
      h1 = route [ (":a/:b/:c", puke "h1")
                 , (":b/:c/ok", ok       )
                 ]
  
      h2 = route [ (":a/:b/ok", ok       )
                 , (":b/:c/:d", puke "h2")
                 ]
  
      -- same, with a prefix
      h3 = route [ ("foo/:a/:b/:c", puke "h1")
                 , ("foo/:b/:c/ok", ok       )
                 ]
  
      h4 = route [ ("foo/:a/:b/ok", ok       )
                 , ("foo/:b/:c/:d", puke "h2")
                 ]
  
      -- test fallback
      h5 = route [ ("", fb1)
                 , (":a/aa/bb", puke "h5-1")
                 , (":b/:c/bb", puke "h5-2")
                 ]
  
      -- all else equal, rightmost wins
      h6 = route [ (":a", fb1), (":b", fb2) ]
  
  
  ------------------------------------------------------------------------------
  testParamUnification :: Test
  testParamUnification = testCase "route/paramUnification" $ do
      go h1 "a/b" >>= assertEqual "++" ["0", "a", "b"]
    where
      h1 = do
          modifyRequest $ rqSetParam "a" ["0"]
          route [ (":a/:a", fromJust . rqParam "a" <$> getRequest) ]
  
  
  ------------------------------------------------------------------------------
  testFailedUrlDecode :: Test
  testFailedUrlDecode = testCase "route/failedUrlDecode" $ do
      expectExceptionH $ go h1 "%zz"
      expectExceptionH $ go h2 "%zz"
    where
      h1 = route [(":a", return ())]
      h2 = route [("a/", return ())]
  
  
  ------------------------------------------------------------------------------
  testDirFallthrough :: Test
  testDirFallthrough = testCase "route/dirFallthrough" $ do
      go m1 "a/a" >>= assertEqual "1" 1
    where
      m1 = route [ (""   , return (1::Int)  )
                 , ("a/a", pass             )
                 , ("a/a", pass             )
                 ]
  
  ------------------------------------------------------------------------------
  testTrivials :: Test
  testTrivials = testCase "route/trivials" $ do
      -- routeHeight and routeEarliestNC can't actually be called on NoRoute (it
      -- never appears in the children of captures or directories), so cover this
      -- case here
      assertEqual "trivials/routeHeight" 1 (routeHeight NoRoute)
      assertEqual "trivials/routeEarliestNC" 1 (routeEarliestNC NoRoute 1)
  