content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DoAndIfThenElse #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module Web.Spock.SafeSpec (spec) where
  
  #if MIN_VERSION_base(4,11,0)
  #else
  import Data.Monoid
  #endif
  
  import qualified Control.Exception as Exception
  import Control.Exception.Base
  import Control.Monad
  import Control.Monad.Base
  import Control.Monad.Trans.Control
  import Control.Monad.Trans.Reader
  import Data.Aeson
  import qualified Data.ByteString.Lazy.Char8 as BSLC
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import GHC.Generics
  import Network.HTTP.Types.Status
  import qualified Network.Wai as Wai
  import Test.Hspec
  import qualified Test.Hspec.Wai as Test
  import Web.Spock.Core
  import Web.Spock.FrameworkSpecHelper
  
  data SampleJson = SampleJson
    { sampleJson :: T.Text
    }
    deriving (Show, Eq, Generic)
  
  instance ToJSON SampleJson
  
  instance FromJSON SampleJson
  
  app :: SpockT IO ()
  app =
    do
      get root $ text "root"
      get "verb-test" $ text "GET"
      post "verb-test" $ text "POST"
      getpost "verb-test-gp" $ text "GETPOST"
      put "verb-test" $ text "PUT"
      delete "verb-test" $ text "DELETE"
      patch "verb-test" $ text "PATCH"
      get "test-slash" $ text "ok"
      get "/test-noslash" $ text "ok"
      get ("param-test" <//> var) $ \(i :: Int) ->
        text $ "int" <> T.pack (show i)
      get ("param-test" <//> "static") $
        text "static"
      get ("cookie" <//> "single") $
        do
          setCookie "single" "test" defaultCookieSettings {cs_EOL = CookieValidFor 3600}
          text "set"
      get ("cookie" <//> "multiple") $
        do
          setCookie "multiple1" "test1" defaultCookieSettings {cs_EOL = CookieValidFor 3600}
          setCookie "multiple2" "test2" defaultCookieSettings {cs_EOL = CookieValidFor 3600}
          text "set"
      get "set-header" $
        do
          setHeader "X-FooBar" "Baz"
          text "ok"
      get "set-multi-header" $
        do
          setHeader "Content-Language" "de"
          setHeader "Content-Language" "en"
          text "ok"
      get "get-params" $
        do
          gp <- paramsGet
          text (T.pack $ show gp)
      post "post-params" $
        do
          gp <- paramsPost
          text (T.pack $ show gp)
      post "json" $
        do
          jbody <- jsonBody'
          text (sampleJson jbody)
      post "raw-body" $
        do
          b <- body
          text (T.decodeUtf8 b)
      let subcomp x =
            "subcomponent" <//> x
          subsubcomp x =
            subcomp ("subcomponent2" <//> x)
      get (subcomp "foo") $ text "foo"
      get (subsubcomp "bar") $ text "bar"
      get "preferred-format" $
        do
          fmt <- preferredFormat
          case fmt of
            PrefHTML -> text "html"
            x -> text (T.pack (show x))
      get ("auth" <//> var <//> var) $ \user pass ->
        let checker user' pass' =
              unless (user == user' && pass == pass') $
                do
                  setStatus status401
                  text "err"
         in requireBasicAuth "Foo" checker $ \() -> text "ok"
      hookRouteAll ("all" <//> "verbs") $ text "ok"
      hookRouteCustom "NOTIFY" ("notify" <//> var) $ \notification -> text notification
      hookAny GET $ text . T.intercalate "/"
      hookAnyCustom "MYVERB" $ text . T.intercalate "/"
      get ("wai" <//> wildcard) $ \_ ->
        respondApp dummyWai
  
  dummyWai :: Wai.Application
  dummyWai req respond =
    respond $ Wai.responseLBS status200 [] (BSLC.pack $ show $ Wai.pathInfo req)
  
  routeRenderingSpec :: Spec
  routeRenderingSpec =
    describe "Route Rendering" $
      do
        it "should work with argument-less routes" $
          do
            renderRoute "foo" `shouldBe` "/foo"
            renderRoute "/foo" `shouldBe` "/foo"
            renderRoute "/foo/" `shouldBe` "/foo"
            renderRoute ("foo" <//> "bar") `shouldBe` "/foo/bar"
        it "should work with routes with args" $
          do
            let r1 = var :: Var Int
            renderRoute r1 1 `shouldBe` "/1"
            let r2 = "blog" <//> (var :: Var Int)
            renderRoute r2 2 `shouldBe` "/blog/2"
            let r3 = "blog" <//> (var :: Var Int) <//> (var :: Var T.Text)
            renderRoute r3 2 "BIIM" `shouldBe` "/blog/2/BIIM"
  
  data InstancesTestException = InstancesTestException deriving (Show)
  
  instance Exception InstancesTestException
  
  instancesApp :: SpockCtxT () (ReaderT T.Text IO) ()
  instancesApp =
    do
      get ("instances" <//> "monad-base") $ text =<< liftBase (pure "ok")
      get ("instances" <//> "monad-base-control") $
        do
          res <-
            catch'
              (throwIO' InstancesTestException)
              (\(_ :: InstancesTestException) -> pure "ok")
          text res
      get ("instances" <//> "monad-trans-control") $
        do
          res <- liftWith (\run -> ask >>= run . text)
          restoreT $ pure res
    where
      -- This is 'catch' from 'Control.Exception.Lifted'.
      catch' :: (MonadBaseControl IO m, Exception e) => m a -> (e -> m a) -> m a
      catch' a handler =
        control $ \runInIO ->
          Exception.catch (runInIO a) (\e -> runInIO $ handler e)
  
      -- This is 'throwIO' from 'Control.Exception.Lifted'.
      throwIO' :: (MonadBase IO m, Exception e) => e -> m a
      throwIO' = liftBase . Exception.throwIO
  
  instancesSpec :: Spec
  instancesSpec =
    describe "Instances for ActionT are correct" $
      Test.with (spockAsApp $ spockT (flip runReaderT "ok") instancesApp) $
        do
          it "MonadBase" $
            Test.request "GET" "/instances/monad-base" [] "" `Test.shouldRespondWith` "ok"
          it "MonadBaseControl" $
            Test.request "GET" "/instances/monad-base-control" [] "" `Test.shouldRespondWith` "ok"
          it "MonadTransControl" $
            Test.request "GET" "/instances/monad-trans-control" [] "" `Test.shouldRespondWith` "ok"
  
  ctxApp :: SpockT IO ()
  ctxApp =
    prehook hook $
      do
        get "test" $ getContext >>= text
        post "test" $ getContext >>= text
    where
      hook =
        do
          sid <- header "X-ApiKey"
          case sid of
            Just s -> return s
            Nothing -> text "Missing ApiKey"
  
  ctxSpec :: Spec
  ctxSpec =
    describe "Contexts" $
      Test.with (spockAsApp $ spockT id ctxApp) $
        it "should work" $
          do
            Test.request "GET" "/test" [] "" `Test.shouldRespondWith` "Missing ApiKey"
            Test.request "GET" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"
            Test.request "POST" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"
  
  spec :: Spec
  spec =
    describe "SafeRouting" $
      do
        frameworkSpec (spockAsApp $ spockT id app)
        ctxSpec
        instancesSpec
        routeRenderingSpec
        sizeLimitSpec $ \lim ->
          spockAsApp $
            spockConfigT (defaultSpockConfig {sc_maxRequestSize = Just lim}) id $
              post "size" $ body >>= bytes
        errorHandlerSpec $
          spockAsApp $
            spockConfigT specConfig id $ do
              get ("failing" <//> "route") $
                throw Overflow
              get ("user" <//> "error") $
                do
                  setStatus status403
                  text "UNAUTHORIZED"
    where
      specConfig = defaultSpockConfig {sc_errorHandler = errorHandler}
      errorHandler status = case statusCode status of
        500 -> text "SERVER ERROR"
        404 -> text "NOT FOUND"
        _ -> text "OTHER ERROR"
  