Error.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Hspec.Server.Error where

import Control.Monad (when)
import Data.Eq (Eq(..))
import Data.Int (Int)
import Prelude ((+))
import System.IO (IO)
import Test.Hspec.Wai (liftIO)
import Text.Show (Show(..))
import qualified Data.ByteString.Base64 as BS64
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai.Handler.Warp as Warp
import qualified Test.Hspec.Wai as Wai

import Symantic.HTTP
import Symantic.HTTP.Server
import Hspec.Utils

api =
 "good" </> "path" </> capture @Int "i"
                   <.> queryParams @Int "param"
                   <.> basicAuth @User "realm"
                   <.> body @Int @'[PlainText]
                   <.> post @Int @'[PlainText]
 <!>
 "unauthorized" </> basicAuth @UnauthorizedUser "realm"
                <.> post @Int @'[PlainText]

data User = User
instance ServerBasicAuth User where
	serverBasicAuth user pass =
		return $
			if user=="user"
			then if pass=="pass"
				then BasicAuth_Authorized User
				else BasicAuth_BadPassword
			else BasicAuth_NoSuchUser
data UnauthorizedUser = UnauthorizedUser
instance ServerBasicAuth UnauthorizedUser where
	serverBasicAuth user pass =
		return $
			if user=="user"
			then if pass=="pass"
				then BasicAuth_Unauthorized
				else BasicAuth_BadPassword
			else BasicAuth_NoSuchUser

srv = server api $
	route_good :!:
	route_unauthorized
	where
	route_good i _params User (ServerBodyArg b) = return (i+b)
	route_unauthorized UnauthorizedUser = return 0

warp :: IO ()
warp = Warp.run 8080 srv

hspec = testSpecs $ describe "Error" $ Wai.with (return srv) $ do
	describe "Path" $ do
		it "checks shorter path" $ do
			Wai.get "/good"
			 `Wai.shouldRespondWith` 404
		it "checks longer path" $ do
			Wai.get "/good/path/bad"
			 `Wai.shouldRespondWith` 404
	describe "BasicAuth" $ do
		it "can decode username and password" $ do
			Wai.request goodMethod goodURI goodHeaders goodBody
			 `Wai.shouldRespondWith` 200
		it "checks username" $ do
			Wai.request goodMethod goodURI
			 [ (HTTP.hAuthorization, "Basic "<>BS64.encode "no-such-user:pass")
			 , goodAccept
			 , goodContentType
			 ] goodBody
			 `Wai.shouldRespondWith` 401
		it "checks password" $ do
			Wai.request goodMethod goodURI
			 [ (HTTP.hAuthorization, "Basic "<>BS64.encode "user:wrong-pass")
			 , goodAccept
			 , goodContentType
			 ] goodBody
			 `Wai.shouldRespondWith` 401
		it "can deny access" $ do
			Wai.request goodMethod "/unauthorized" goodHeaders goodBody
			 `Wai.shouldRespondWith` 403
	describe "Priorities" $ do
		it "has 404 as its highest priority error (path)" $ do
			Wai.request badMethod badURI [badAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 404
		it "has 405 as its second highest priority error (method)" $ do
			Wai.request badMethod badParam [badAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 405
		it "has 401 as its third highest priority error (auth)" $ do
			Wai.request goodMethod badParam [badAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 401
		it "has 406 as its fourth highest priority error (accept)" $ do
			Wai.request goodMethod badParam [goodAuth, badAccept, badContentType] badBody
			`Wai.shouldRespondWith` 406
		it "has 415 as its fifth highest priority error (content type)" $ do
			Wai.request goodMethod badParam [goodAuth, goodAccept, badContentType] badBody
			`Wai.shouldRespondWith` 415
		it "has 400 as its sixth highest priority error (query and body)" $ do
			badParamsRes <- Wai.request goodMethod badParam goodHeaders goodBody
			badBodyRes   <- Wai.request goodMethod goodURI  goodHeaders badBody
			
			-- Both bad body and bad params result in 400
			return badParamsRes `Wai.shouldRespondWith` 400
			return badBodyRes   `Wai.shouldRespondWith` 400
			
			-- Param check should occur before body checks
			badBothRes <- Wai.request goodMethod badParam
			 [goodAuth, goodAccept, goodContentType] badBody
			when (badBothRes /= badParamsRes) $ liftIO $
				expectationFailure $ "badParam + badBody /= badParam: "
				 <> show badBothRes <> ", " <> show badParamsRes
			when (badBothRes == badBodyRes) $ liftIO $
				expectationFailure $ "badParam + badBody == badBody: "
				 <> show badBothRes

badContentType  = (HTTP.hContentType, "application/json")
badAccept       = (HTTP.hAccept, "application/json")
badMethod       = HTTP.methodGet
badURI          = "bad"
badBody         = "bad"
badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
goodAccept      = (HTTP.hAccept, "text/plain")
goodMethod      = HTTP.methodPost
goodPath        = "good/path/4"
goodURI         = goodPath<>"?param=2"
badParam        = goodPath<>"?param=foo"
goodBody        = "42" -- {-encode-} (42::Int)
goodAuth        = (HTTP.hAuthorization, "Basic "<>BS64.encode "user:pass")
goodHeaders     = [goodAuth, goodAccept, goodContentType]