SafeSpec.hs

{-# 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"