content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeFamilies #-}
  
  module Web.Routing.SafeRoutingSpec where
  
  import Control.Monad.Identity
  import Control.Monad.RWS.Strict
  import Data.HVect hiding (singleton)
  import qualified Data.HashMap.Strict as HM
  import Data.List
  import Data.Maybe
  import qualified Data.Text as T
  import Test.Hspec
  import Web.Routing.Combinators
  import Web.Routing.Router
  import Web.Routing.SafeRouting
  
  data ReturnVar
    = IntVar Int
    | StrVar T.Text
    | ListVar [ReturnVar]
    | EitherVar (AltVar Int T.Text)
    deriving (Show, Eq, Read, Ord)
  
  defR :: (Monad m, m ReturnVar ~ x) => Path ts ps -> HVectElim ts x -> RegistryT m ReturnVar middleware Bool m ()
  defR path action = hookRoute True (toInternalPath path) (HVectElim' action)
  
  defRAny :: (Monad m, m ReturnVar ~ x) => Path ts ps -> HVectElim ts x -> RegistryT m ReturnVar middleware Bool m ()
  defRAny path action = hookRouteAnyMethod (toInternalPath path) (HVectElim' action)
  
  -- TODO: abstract this code, move into AbstractRouter
  defSubComponent ::
    ( Monad m,
  #if __GLASGOW_HASKELL__ <= 708
      , Functor m
  #endif
      m ([T.Text] -> ReturnVar) ~ x
    ) =>
    Path ts ps ->
    HVectElim ts x ->
    RegistryT m ReturnVar middleware Bool m ()
  defSubComponent path comp =
    do
      let reqType = True
      basePath <- ask
      modify $ \rs ->
        rs
          { rs_registry =
              let (reg, fb) = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))
                  reg' = insertSubComponent (RouteHandle (basePath </!> toInternalPath path) comp) reg
               in HM.insert reqType (reg', fb) (rs_registry rs)
          }
  
  spec :: Spec
  spec =
    describe "SafeRouting Spec" $
      do
        it "should match known routes" $
          do
            checkRoute "" [StrVar "root"]
            checkRoute "/" [StrVar "root"]
            checkRoute "/bar" [StrVar "bar"]
        it "should match any routes" $
          do
            checkRoute' "/any" True [StrVar "any", StrVar "any"] -- two due to hookAny
            checkRoute' "/any" False [StrVar "any"]
        it "should capture variables in routes" $
          do
            checkRoute "/bar/23/baz" [IntVar 23]
            checkRoute "/bar/23/baz/" [IntVar 23]
            checkRoute "/bar/23/baz/100" [ListVar [IntVar 23, IntVar 100]]
            checkRoute "/bar/23/100" [ListVar [IntVar 23, IntVar 100]]
            checkRoute "/entry/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]]
            checkRoute "/entry/bytags/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]]
            checkRoute "/entry/2/rel/3" [ListVar [IntVar 2, IntVar 3]]
        it "should handle multiple possible matches correctly" $
          do
            checkRoute "/bar/5" [IntVar 5, StrVar "5"]
            checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"]
            checkRoute "/entry/1/audit" [IntVar 1, ListVar [IntVar 1, StrVar "audit"]]
        it "should have a catch all route" $
          do
            checkRoute "/aslkdjk/asdaskl/aslkjd" [StrVar "aslkdjk/asdaskl/aslkjd"]
            checkRoute "/zuiasf/zuiasf" [StrVar "zuiasf/zuiasf"]
        it "should hand over remaining path pieces to subcomponents" $
          do checkRoute "/subcomponent/blog/foo/bar/nanana" [StrVar "blog:foo?bar?nanana"]
        it "should handle wildcard routes" $
          do
            checkRoute "/wildcard/" [StrVar ""]
            checkRoute "/wildcard/some/additional/data" [StrVar "some/additional/data"]
        it "correctly handles alternatives" $
          do
            checkRoute "/either/1" [EitherVar (AvLeft 1)]
            checkRoute "/either/aaa" [EitherVar (AvRight "aaa")]
    where
      pieces :: T.Text -> [T.Text]
      pieces = filter (not . T.null) . T.splitOn "/"
  
      checkRoute' :: T.Text -> Bool -> [ReturnVar] -> Expectation
      checkRoute' r b x =
        let matches = handleFun b (pieces r)
         in sort (map runIdentity matches) `shouldBe` sort x
  
      checkRoute :: T.Text -> [ReturnVar] -> Expectation
      checkRoute = flip checkRoute' True
  
      handleFun :: Bool -> [T.Text] -> [Identity ReturnVar]
      handleFun = handleFun'
  
      (_, handleFun', _) = runIdentity (runRegistry handleDefs)
  
      handleDefs =
        do
          defR root $ return (StrVar "root")
          defRAny "any" $ pure (StrVar "any")
          defR "bar" $ return (StrVar "bar")
          defR ("bar" </> var) (return . IntVar)
          defR ("bar" </> var </> "baz") (return . IntVar)
          defR ("bar" </> var </> "baz" </> var) $ \i i2 ->
            return (ListVar [IntVar i, IntVar i2])
          defR ("bar" </> var </> var) $ \i i2 ->
            return (ListVar [IntVar i, IntVar i2])
          defR ("entry" </> var </> var) $ \i st ->
            return (ListVar [IntVar i, StrVar st])
          defR ("entry/bytags" </> var </> var) $ \i st ->
            return (ListVar [IntVar i, StrVar st])
          defR ("entry" </> var </> "rel" </> var) $ \i i2 ->
            return (ListVar [IntVar i, IntVar i2])
          defR ("bar" </> "bingo") $ return (StrVar "bar/bingo")
          defR ("bar" </> var) (return . StrVar)
          defR ("either" </> var) (return . EitherVar)
          defR ("entry" </> var </> "audit") (return . IntVar)
          defSubComponent ("subcomponent" </> var) $ \name ->
            return $ \ps -> StrVar $ name <> ":" <> T.intercalate "?" ps
          defR ("wildcard" </> wildcard) $ \rest ->
            return $ StrVar rest
          hookAny True (return . StrVar . T.intercalate "/")
  