-- * Class 'HTTP_API'
class
- ( Appli repr
- , Altern repr
+ ( Cat repr
+ , Alt repr
, HTTP_Path repr
, HTTP_Method repr
, HTTP_Header repr
, HTTP_Endpoint repr
) => HTTP_API (repr:: * -> * -> *)
--- * Class 'Appli'
-class Appli repr where
+-- * Class 'Cat'
+class Cat repr where
(<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
-- (.>) :: repr x y -> repr a c -> repr a c; infixl 4 .>
--- * Class 'Altern'
-class Altern repr where
+
+-- * Class 'Alt'
+class Alt repr where
{-
- type AlternMerge repr :: * -> * -> *
- (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AlternMerge repr b d); infixl 3 <!>
+ type AltMerge repr :: * -> * -> *
+ (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
-}
(<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
try :: repr k k -> repr k k
-- option :: k -> repr k k -> repr k k
+
-- ** Type ':!:'
-- Like '(,)' but 'infixl'.
data (:!:) a b = a:!:b
infixl 3 :!:
+
-- * Class 'HTTP_Path'
class HTTP_Path repr where
segment :: Segment -> repr k k
type Segment = T.Text
type Path = [Segment]
type Name = String
+
-- * Class 'HTTP_Method'
class HTTP_Method repr where
method :: HTTP.Method -> repr k k
method_CONNECT = method HTTP.methodConnect
method_OPTIONS = method HTTP.methodOptions
method_PATCH = method HTTP.methodPatch
+
-- * Class 'HTTP_Header'
class HTTP_Header repr where
header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
type HeaderValue = BS.ByteString
+
-- * Class 'HTTP_Accept'
class HTTP_Accept repr where
accept :: MediaTypeable mt => Proxy mt -> repr k k
{-
- acceptCase :: Functor repr => Altern repr => [AcceptResponse repr a] -> repr BSL.ByteString
+ acceptCase :: Functor repr => Alt repr => [AcceptResponse repr a] -> repr BSL.ByteString
acceptCase [] = tina $> BSL.empty
acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
-}
forall mt. MimeSerialize mt a =>
AcceptResponse (Proxy mt, repr a)
-}
+
-- * Class 'HTTP_Query'
class HTTP_Query repr where
- query :: QueryName -> repr ([Maybe QueryValue] -> k) k
+ query' ::
+ Web.FromHttpApiData a =>
+ Web.ToHttpApiData a =>
+ QueryName -> repr ([Maybe a] -> k) k
queryFlag :: QueryName -> repr (Bool -> k) k
type QueryName = BS.ByteString
type QueryValue = BS.ByteString
+
+query ::
+ forall a repr k.
+ HTTP_Query repr =>
+ Web.FromHttpApiData a =>
+ Web.ToHttpApiData a =>
+ QueryName -> repr ([Maybe a] -> k) k
+query = query'
+{-# INLINE query #-}
+
-- * Class 'HTTP_Version'
class HTTP_Version repr where
version :: HTTP.HttpVersion -> repr k k
+
-- * Class 'HTTP_Status'
class HTTP_Status repr where
status :: StatusIs -> repr (HTTP.Status -> k) k
+
-- ** Type 'StatusIs'
data StatusIs
= StatusIsInformational
status200 = HTTP.mkStatus 200 "Success"
status404 :: HTTP.Status
status404 = HTTP.mkStatus 404 "Not Found"
-{-
--- * Class 'HTTP_Response'
-class HTTP_Response repr where
- response ::
- MimeSerialize mt a =>
- HTTP.Method ->
- Proxy mt ->
- repr ((HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response) -> k) k
--}
+status405 :: HTTP.Status
+status405 = HTTP.mkStatus 405 "Method Not Allowed"
+status406 :: HTTP.Status
+status406 = HTTP.mkStatus 406 "Not Acceptable"
-- * Class 'HTTP_Endpoint'
class HTTP_Endpoint repr where
HTTP.Method ->
repr (EndpointArg repr mt a -> k) k
+-- | Like |capture'| but with the type variables 'a' and 'mt' first instead or 'repr'
+-- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
endpoint ::
forall a mt repr k.
HTTP_Endpoint repr =>
-- ** Type 'CommandModifier'
type CommandModifier = ClientRequest -> ClientRequest
-instance Appli Command where
+instance Cat Command where
Command x <.> Command y = Command $ \k ->
x $ \fx -> y $ \fy -> k $ fy . fx
-instance Altern Command where
+instance Alt Command where
Command x <!> Command y = Command $ \k ->
x k :!: y k
{-
- type AlternMerge Command = (:!:)
+ type AltMerge Command = (:!:)
Command x <!> Command y = Command $ \k ->
x (\cm -> let n:!:_ = k cm in n) :!:
y (\cm -> let _:!:n = k cm in n)
accept mt = Command $ \k -> k $ \req ->
req{ clientReqAccept = clientReqAccept req Seq.|> mediaType mt }
instance HTTP_Query Command where
- query n = Command $ \k vs -> k $ \req ->
- req{ clientReqQueryString = clientReqQueryString req <> fromList ((n,) <$> vs) }
+ query' n = Command $ \k vs -> k $ \req ->
+ req{ clientReqQueryString =
+ clientReqQueryString req <>
+ fromList ((\v -> (n, Text.encodeUtf8 . Web.toQueryParam <$> v)) <$> vs) }
queryFlag n = Command $ \k b -> k $ \req ->
if b
then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
instance Functor (Layout h) where
fmap _f = reLayout
-instance Appli Layout where
+instance Cat Layout where
Layout x <.> Layout y = Layout $ x <> y
-instance Altern Layout where
+instance Alt Layout where
Layout x <!> Layout y =
Layout [collapseApp x <> collapseApp y]
try = id
instance HTTP_Accept Layout where
accept mt = layoutOfNode $ LayoutNode_Accept (mediaType mt)
instance HTTP_Query Layout where
- query = layoutOfNode . LayoutNode_Query
+ query' = layoutOfNode . LayoutNode_Query
queryFlag = layoutOfNode . LayoutNode_QueryFlag
instance HTTP_Version Layout where
version = layoutOfNode . LayoutNode_Version
module Symantic.HTTP.Router where
import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..), (>=>))
+import Control.Monad (Monad(..), (>=>), forM)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (toList)
import Data.Function (($), (.), id, const)
import Data.Functor (Functor, (<$>), (<$))
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
Router ma >>= a2mb = Router $ \f ->
ma f >>= ($ f) . unRouter . a2mb
+
-- | Useful to constrain 'repr' to be 'Router'.
router :: Router f k -> Router f k
router = id
let r = RouteToken_Segment <$> Wai.pathInfo rq in
case P.runParser (p <* P.eof) "<Request>" r of
Right (RouterResponse app) -> app rq re
- Left err ->
+ Left errs ->
-- trace (show rq) $
- re $ Wai.responseLBS status404
- [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
- (fromString $ P.errorBundlePretty err)
+ case P.bundleErrors errs of
+ err:|_ ->
+ re $ Wai.responseLBS
+ (case err of
+ P.FancyError _o es | P.ErrorCustom e:_ <- toList es ->
+ case e of
+ RouteError_Query_param{} -> status405
+ RouteError_Accept_unsupported{} -> status406
+ _ -> status404
+ _ -> status404)
+ [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
+ (fromString $ P.errorBundlePretty errs)
-- ** Type 'RouteError'
data RouteError
= RouteError_Accept_unsupported {-expected-}MediaType {-got-}HeaderValue
| RouteError_Query_param_not_a_boolean QueryName [Maybe BS.ByteString]
+ | RouteError_Query_param QueryName (Maybe BS.ByteString)
| RouteError_HttpApiData Text.Text
deriving (Eq, Ord, Show)
instance P.ShowErrorComponent RouteError where
unRouteToken_Segment (RouteToken_Segment x) = x
unRouteToken_Segment _ = undefined
-instance Appli Router where
+instance Cat Router where
Router x <.> Router y = Router $ x >=> y
-instance Altern Router where
+instance Alt Router where
Router x <!> Router y = Router $ \(b:!:c) ->
P.try (x b) <|> y c
{-
- type AlternMerge Router = Either
+ type AltMerge Router = Either
Router x <!> Router y = Router $ \(b:!:c) ->
P.try (Left <$> x b)
<|> (Right <$> y c)
_ -> P.fancyFailure $ Set.singleton $
P.ErrorCustom $ RouteError_Accept_unsupported (mediaType exp) hdr
instance HTTP_Query Router where
- query exp = Router $ \f -> do
+ query' name = Router $ \f -> do
got <- R.asks Wai.queryString
inp <- P.getInput
P.setInput [RouteToken_QueryString got]
- ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Query exp)) $ \_tok ->
- case List.filter ((== exp) . fst) got of
+ vals <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Query name)) $ \_tok ->
+ case List.filter ((== name) . fst) got of
[] -> Nothing
hs -> Just $ snd <$> hs
P.setInput inp
+ ret <- forM vals $ \mayVal ->
+ case mayVal of
+ Nothing -> return Nothing
+ Just val ->
+ case Web.parseQueryParam $ Text.decodeUtf8 val of
+ Right ret -> return (Just ret)
+ Left err -> P.fancyFailure $ Set.singleton $
+ P.ErrorCustom $ RouteError_Query_param name mayVal
return (f ret)
+ {-
queryFlag n = Router $ \f -> do
- vs <- inRouter $ query n
+ vs <- inRouter $ query' n
f <$> case vs of
[] -> return True
[Nothing] -> return True
[Just "true"] -> return True
_ -> P.fancyFailure $ Set.singleton $
P.ErrorCustom $ RouteError_Query_param_not_a_boolean n vs
+ -}
instance HTTP_Version Router where
version exp = Router $ \f -> do
got <- R.asks Wai.httpVersion
hAccept <- (`unRouter` (id:!:id)) $ header HTTP.hAccept <!> pure "*/*"
let mt = mediaType (Proxy::Proxy mt)
case Media.parseAccept hAccept of
- Just gotAccept | mt`Media.matches`gotAccept ->
+ Just reqAccept | mt`Media.matches`reqAccept ->
return $ f $ RouterEndpointArg $ \st hs a ->
Wai.responseLBS st
((HTTP.hContentType, Media.renderHeader mt):hs)
RecordWildCards
ScopedTypeVariables
TupleSections
- -- TypeFamilies
ghc-options:
-Wall
-Wincomplete-uni-patterns
-- pkgconfig-depends: zlib
-- extra-libraries: z
--- Test-Suite symantic-xml-test
--- type: exitcode-stdio-1.0
--- hs-source-dirs: test
--- main-is: Main.hs
--- other-modules:
--- Golden
--- -- HUnit
--- -- QuickCheck
--- default-language: Haskell2010
--- default-extensions:
--- LambdaCase
--- NamedFieldPuns
--- NoImplicitPrelude
--- RecordWildCards
--- ViewPatterns
--- ghc-options:
--- -Wall
--- -Wincomplete-uni-patterns
--- -Wincomplete-record-updates
--- -fno-warn-tabs
--- -fhide-source-paths
--- build-depends:
--- symantic-xml
--- , base >= 4.10 && < 5
--- , bytestring >= 0.10
--- , containers >= 0.5
--- , deepseq >= 1.4
--- , filepath >= 1.4
--- , megaparsec >= 6.3
--- , tasty >= 0.11
--- , tasty-golden >= 2.3
--- , text >= 1.2
--- , transformers >= 0.4
--- , treeseq >= 1.0
--- -- , QuickCheck >= 2.0
--- -- , tasty-hunit
--- -- , tasty-quickcheck
+Test-Suite symantic-http-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Main.hs
+ other-modules:
+ -- Golden
+ Hspec
+ Hspec.API
+ Hspec.Router
+ Hspec.Router.Error
+ HUnit
+ -- HUnit.HSpec
+ -- QuickCheck
+ default-language: Haskell2010
+ default-extensions:
+ FlexibleContexts
+ FlexibleInstances
+ LambdaCase
+ MultiParamTypeClasses
+ NamedFieldPuns
+ NoImplicitPrelude
+ RecordWildCards
+ ScopedTypeVariables
+ TupleSections
+ ViewPatterns
+ ghc-options:
+ -Wall
+ -Wincomplete-uni-patterns
+ -Wincomplete-record-updates
+ -fno-warn-tabs
+ -fhide-source-paths
+ build-depends:
+ symantic-http
+ , base >= 4.10 && < 5
+ , bytestring >= 0.10
+ , containers >= 0.5
+ , deepseq >= 1.4
+ , filepath >= 1.4
+ , hspec-wai >= 0.9
+ , http-api-data >= 0.4
+ , http-client >= 0.5.12
+ , http-media >= 0.7
+ , http-types >= 0.12
+ , hspec
+ , megaparsec >= 6.3
+ , network-uri >= 2.6
+ , tasty >= 0.11
+ , tasty-hspec >= 1.1
+ , tasty-hunit >= 0.10
+ , text >= 1.2
+ , time
+ , transformers >= 0.4
+ , wai >= 3.2.1.1
+ , wai-extra >= 3.0
+ , warp
+ -- , wai-app-static >= 3.1.6.1
+ -- , QuickCheck >= 2.0
+ -- , tasty-golden >= 2.3
+ -- , tasty-quickcheck
--- /dev/null
+module HUnit where
+import Test.Tasty
+
+hunits :: TestTree
+hunits =
+ testGroup "HUnit"
+ [
+ ]
--- /dev/null
+module Hspec where
+import Control.Monad (Monad(..))
+import Data.Function (($))
+import Data.Semigroup (Semigroup(..))
+import System.IO (IO)
+import Test.Tasty
+import qualified Hspec.API
+import qualified Hspec.Router
+
+hspec :: IO TestTree
+hspec = do
+ hspec_api <- Hspec.API.hspec
+ hspec_router <- Hspec.Router.hspec
+ return $ testGroup "Hspec" $
+ hspec_api <>
+ [hspec_router]
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hspec.API where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..))
+import Data.Bool
+import Data.Either (Either(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Maybe (Maybe(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (IsString(..))
+import System.IO (IO)
+import Prelude (error, (+), (*))
+import Text.Read (readMaybe)
+import Text.Show (Show(..))
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
+import qualified Data.Time as Time
+import qualified Network.HTTP.Client as Client
+import qualified Network.HTTP.Types as HTTP
+import qualified Network.URI as URI
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Web.HttpApiData as Web
+import Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with)
+
+-- import Test.Hspec
+-- import Test.Tasty.HUnit
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Tasty
+import Test.Tasty.Hspec
+
+import Symantic.HTTP
+
+-- * Type 'API0'
+data API0
+ = API0_Date Time.Day
+ | API0_Time Time.ZonedTime
+ | API0_Reset Bool
+ deriving (Show)
+instance IsString Time.TimeZone where
+ fromString s = case s of
+ "CET" -> Time.TimeZone (1*60) False "CET"
+ "CEST" -> Time.TimeZone (2*60) False "CEST"
+ _ -> error "unknown TimeZone"
+instance Web.FromHttpApiData Time.TimeZone where
+ parseUrlPiece = \case
+ "CET" -> Right $ Time.TimeZone (1*60) True "CET"
+ "CEST" -> Right $ Time.TimeZone (2*60) False "CEST"
+ _ -> Left "unknown TimeZone"
+instance Web.ToHttpApiData Time.TimeZone where
+ toUrlPiece (Time.TimeZone _s _b n) = Text.pack n
+
+manager :: IO Client.Manager
+manager = Client.newManager Client.defaultManagerSettings
+Just baseURI = URI.parseURI "http://localhost:8080"
+cliEnv = clientEnv <$> manager <*> pure baseURI
+
+-- cli0_get :!: cli0_post = command api0
+
+api1
+ = segment "time"
+ <.> capture @Time.TimeZone "timezone"
+ <.> endpoint @TL.Text @PlainText HTTP.methodGet
+
+ <!> segment "date"
+ <.> endpoint @TL.Text @PlainText HTTP.methodGet
+
+ <!> segment "echo"
+ <.> captureAll
+ <.> endpoint @TL.Text @PlainText HTTP.methodGet
+
+ <!> segment "succ"
+ <.> capture @Int "n"
+ <.> endpoint @Int @PlainText HTTP.methodGet
+
+ <!>
+ segment "info"
+ <.> ( endpoint @TL.Text @PlainText HTTP.methodHead
+ <!> endpoint @TL.Text @PlainText HTTP.methodGet
+ )
+instance MimeSerialize PlainText () where
+ mimeSerialize _mt = fromString . show
+instance MimeUnserialize PlainText () where
+ mimeUnserialize _mt s =
+ case s of
+ "()" -> Right ()
+ _ -> Left "cannot parse ()"
+
+instance MimeSerialize PlainText Int where
+ mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
+instance MimeUnserialize PlainText Int where
+ mimeUnserialize _mt s =
+ case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
+ Just n -> Right n
+ _ -> Left "cannot parse Int"
+
+lay1 = layout api1
+
+(api1_time :!:
+ api1_date :!:
+ api1_echo :!:
+ api1_succ :!:
+ api1_info
+ ) = runCommand api1
+
+rou1 = runRouter api1 $
+ route_time :!:
+ route_date :!:
+ route_echo :!:
+ route_succ :!:
+ route_info
+ where
+ route_time tz (RouterEndpointArg respond) =
+ RouterResponse $ \_req res -> do
+ time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
+ res $ respond status200 [] $
+ TL.pack $ show time <> "\n"
+
+ route_date (RouterEndpointArg respond) =
+ RouterResponse $ \_req res -> do
+ date <- Time.utctDay <$> Time.getCurrentTime
+ res $ respond status200 [] $
+ TL.pack $ show date <> "\n"
+
+ route_echo path (RouterEndpointArg respond) =
+ RouterResponse $ \_req res -> do
+ res $ respond status200 [] $ TL.pack $ show path <> "\n"
+
+ route_succ n (RouterEndpointArg respond) =
+ RouterResponse $ \_req res -> do
+ res $ respond status200 [] $ n+1
+
+ route_info = route_head :!: route_get
+ where
+ route_head (RouterEndpointArg respond) =
+ RouterResponse $ \req res -> do
+ res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
+
+ route_get (RouterEndpointArg respond) =
+ RouterResponse $ \req res -> do
+ res $ respond status200 [] $ TL.pack $ show req <> "\n"
+
+srv1 :: IO ()
+srv1 = Warp.run 8080 rou1
+
+hspec =
+ testSpecs $
+ with (return rou1) $
+ it "allows running arbitrary monads" $ do
+ get "/date" `shouldRespondWith` 200
--- /dev/null
+module Hspec.Router where
+import Control.Monad (Monad(..))
+import System.IO (IO)
+import Test.Tasty
+import qualified Hspec.Router.Error
+
+hspec :: IO TestTree
+hspec = do
+ hspec_error <- Hspec.Router.Error.hspec
+ return (testGroup "Router" [hspec_error])
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hspec.Router.Error where
+import Control.Monad (Monad(..))
+import Data.Int (Int)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Function (($), (.))
+import System.IO (IO)
+import Text.Show (Show(..))
+import Text.Read (readMaybe)
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Tasty
+import Test.Tasty
+import Test.Tasty.Hspec
+import Data.Semigroup (Semigroup(..))
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
+import qualified Network.HTTP.Types as HTTP
+import qualified Network.Wai.Handler.Warp as Warp
+
+import Symantic.HTTP
+
+api = segment "good"
+ <.> capture @Int "i"
+ <.> query @Int "param"
+ <.> endpoint @Int @PlainText HTTP.methodPost
+rtr = runRouter api $ route_good
+ where
+ route_good i qry (RouterEndpointArg respond) =
+ RouterResponse $ \_req res -> do
+ res $ respond status200 [] i
+srv :: IO ()
+srv = Warp.run 8080 rtr
+instance MimeSerialize PlainText Int where
+ mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
+instance MimeUnserialize PlainText Int where
+ mimeUnserialize _mt s =
+ case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
+ Just n -> Right n
+ _ -> Left "cannot parse Int"
+
+hspec =
+ testSpec "Error order" $
+ with (return rtr) $ do
+ it "has 404 as its highest priority error" $ do
+ request badMethod badURI [badAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 404
+ it "has 405 as its second highest priority error" $ do
+ request badMethod badParam [badAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 405
+ it "has 401 as its third highest priority error (auth)" $ do
+ request goodMethod badParam [badAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 401
+ it "has 406 as its fourth highest priority error" $ do
+ request goodMethod badParam [goodAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 406
+
+
+badContentType = (HTTP.hContentType, "application/json")
+badAccept = (HTTP.hAccept, "text/plain")
+badMethod = HTTP.methodGet
+badURI = "bad"
+badBody = "bad"
+badAuth = (HTTP.hAuthorization, "Basic foofoofoo")
+goodContentType = (HTTP.hContentType, "text/plain")
+goodAccept = (HTTP.hAccept, "text/plain")
+goodMethod = HTTP.methodPost
+goodPath = "good/4"
+goodURI = goodPath<>"?param=2"
+badParam = goodPath<>"?param=foo"
+goodBody = {-encode-} (42::Int)
+-- username:password = servant:server
+goodAuth = (HTTP.hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
+
+
+{-
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.Server.ErrorSpec (spec) where
+
+import Control.Monad
+ (when)
+import Data.Aeson
+ (encode)
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy.Char8 as BCL
+import Data.Monoid
+ ((<>))
+import Data.Proxy
+import Network.HTTP.Types
+ (hAccept, hAuthorization, hContentType, methodGet, methodPost,
+ methodPut)
+import Safe
+ (readMay)
+import Test.Hspec
+import Test.Hspec.Wai
+
+import Servant
+
+spec :: Spec
+spec = describe "HTTP Errors" $ do
+ errorOrderSpec
+ prioErrorsSpec
+ errorRetrySpec
+ errorChoiceSpec
+
+-- * Auth machinery (reused throughout)
+
+-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
+errorOrderAuthCheck :: BasicAuthCheck ()
+errorOrderAuthCheck =
+ let check (BasicAuthData username password) =
+ if username == "servant" && password == "server"
+ then return (Authorized ())
+ else return Unauthorized
+ in BasicAuthCheck check
+
+------------------------------------------------------------------------------
+-- * Error Order {{{
+
+type ErrorOrderApi = "home"
+ :> BasicAuth "error-realm" ()
+ :> ReqBody '[JSON] Int
+ :> Capture "t" Int
+ :> QueryParam "param" Int
+ :> Post '[JSON] Int
+
+errorOrderApi :: Proxy ErrorOrderApi
+errorOrderApi = Proxy
+
+errorOrderServer :: Server ErrorOrderApi
+errorOrderServer = \_ _ _ _ -> throwError err402
+
+-- On error priorities:
+--
+-- We originally had
+--
+-- 404, 405, 401, 415, 400, 406, 402
+--
+-- but we changed this to
+--
+-- 404, 405, 401, 406, 415, 400, 402
+--
+-- for servant-0.7.
+--
+-- This change is due to the body check being irreversible (to support
+-- streaming). Any check done after the body check has to be made fatal,
+-- breaking modularity. We've therefore moved the accept check before
+-- the body check, to allow it being recoverable and modular, and this
+-- goes along with promoting the error priority of 406.
+errorOrderSpec :: Spec
+errorOrderSpec =
+ describe "HTTP error order" $
+ with (return $ serveWithContext errorOrderApi
+ (errorOrderAuthCheck :. EmptyContext)
+ errorOrderServer
+ ) $ do
+ let badContentType = (hContentType, "text/plain")
+ badAccept = (hAccept, "text/plain")
+ badMethod = methodGet
+ badUrl = "nonexistent"
+ badBody = "nonsense"
+ badAuth = (hAuthorization, "Basic foofoofoo")
+ goodContentType = (hContentType, "application/json")
+ goodAccept = (hAccept, "application/json")
+ goodMethod = methodPost
+ goodUrl = "home/2?param=55"
+ badParams = goodUrl <> "?param=foo"
+ goodBody = encode (5 :: Int)
+ -- username:password = servant:server
+ goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
+
+ it "has 404 as its highest priority error" $ do
+ request badMethod badUrl [badAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 404
+
+ it "has 405 as its second highest priority error" $ do
+ request badMethod badParams [badAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 405
+
+ it "has 401 as its third highest priority error (auth)" $ do
+ request goodMethod badParams [badAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 401
+
+ it "has 406 as its fourth highest priority error" $ do
+ request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
+ `shouldRespondWith` 406
+
+ it "has 415 as its fifth highest priority error" $ do
+ request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
+ `shouldRespondWith` 415
+
+ it "has 400 as its sixth highest priority error" $ do
+ badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
+ badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
+
+ -- Both bad body and bad params result in 400
+ return badParamsRes `shouldRespondWith` 400
+ return badBodyRes `shouldRespondWith` 400
+
+ -- Param check should occur before body checks
+ both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
+ when (both /= badParamsRes) $ liftIO $
+ expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
+ when (both == badBodyRes) $ liftIO $
+ expectationFailure $ "badParams + badBody == badBody: " ++ show both
+
+ it "has handler-level errors as last priority" $ do
+ request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
+ `shouldRespondWith` 402
+
+type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
+
+prioErrorsApi :: Proxy PrioErrorsApi
+prioErrorsApi = Proxy
+
+-- Check whether matching continues even if a 'ReqBody' or similar construct
+-- is encountered early in a path. We don't want to see a complaint about the
+-- request body unless the path actually matches.
+prioErrorsSpec :: Spec
+prioErrorsSpec = describe "PrioErrors" $ do
+ let server = return
+ with (return $ serve prioErrorsApi server) $ do
+ let check (mdescr, method) path (cdescr, ctype, body) resp =
+ it fulldescr $
+ Test.Hspec.Wai.request method path [(hContentType, ctype)] body
+ `shouldRespondWith` resp
+ where
+ fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
+ ++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")"
+
+ get' = ("GET", methodGet)
+ put' = ("PUT", methodPut)
+
+ txt = ("text" , "text/plain;charset=utf8" , "42" )
+ ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
+ vjson = ("valid json" , "application/json;charset=utf8", encode (5 :: Int))
+
+ check get' "/" txt 404
+ check get' "/bar" txt 404
+ check get' "/foo" txt 415
+ check put' "/" txt 404
+ check put' "/bar" txt 404
+ check put' "/foo" txt 405
+ check get' "/" ijson 404
+ check get' "/bar" ijson 404
+ check get' "/foo" ijson 400
+ check put' "/" ijson 404
+ check put' "/bar" ijson 404
+ check put' "/foo" ijson 405
+ check get' "/" vjson 404
+ check get' "/bar" vjson 404
+ check get' "/foo" vjson 200
+ check put' "/" vjson 404
+ check put' "/bar" vjson 404
+ check put' "/foo" vjson 405
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Error Retry {{{
+
+type ErrorRetryApi
+ = "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- err402
+ :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1
+ :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2
+ :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3
+ :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4
+ :<|> "a" :> BasicAuth "bar-realm" ()
+ :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5
+ :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6
+
+ :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7
+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8
+
+errorRetryApi :: Proxy ErrorRetryApi
+errorRetryApi = Proxy
+
+errorRetryServer :: Server ErrorRetryApi
+errorRetryServer
+ = (\_ -> throwError err402)
+ :<|> (\_ -> return 1)
+ :<|> (\_ -> return 2)
+ :<|> (\_ -> return 3)
+ :<|> (\_ -> return 4)
+ :<|> (\_ _ -> return 5)
+ :<|> (\_ -> return 6)
+ :<|> (\_ -> return 7)
+ :<|> (\_ -> return 8)
+
+errorRetrySpec :: Spec
+errorRetrySpec =
+ describe "Handler search" $
+ with (return $ serveWithContext errorRetryApi
+ (errorOrderAuthCheck :. EmptyContext)
+ errorRetryServer
+ ) $ do
+
+ let jsonCT = (hContentType, "application/json")
+ jsonAccept = (hAccept, "application/json")
+ jsonBody = encode (1797 :: Int)
+
+ it "should continue when URLs don't match" $ do
+ request methodPost "" [jsonCT, jsonAccept] jsonBody
+ `shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) }
+
+ it "should continue when methods don't match" $ do
+ request methodGet "a" [jsonCT, jsonAccept] jsonBody
+ `shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) }
+ where
+ mkBody b = MatchBody $ \_ b' ->
+ if b == b'
+ then Nothing
+ else Just "body not correct\n"
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Error Choice {{{
+
+type ErrorChoiceApi
+ = "path0" :> Get '[JSON] Int -- 0
+ :<|> "path1" :> Post '[JSON] Int -- 1
+ :<|> "path2" :> Post '[PlainText] Int -- 2
+ :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3
+ :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4
+ :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5
+ :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6
+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7
+
+errorChoiceApi :: Proxy ErrorChoiceApi
+errorChoiceApi = Proxy
+
+errorChoiceServer :: Server ErrorChoiceApi
+errorChoiceServer = return 0
+ :<|> return 1
+ :<|> return 2
+ :<|> (\_ -> return 3)
+ :<|> ((\_ -> return 4) :<|> (\_ -> return 5))
+ :<|> ((\_ -> return 6) :<|> (\_ -> return 7))
+
+
+errorChoiceSpec :: Spec
+errorChoiceSpec = describe "Multiple handlers return errors"
+ $ with (return $ serve errorChoiceApi errorChoiceServer) $ do
+
+ it "should respond with 404 if no path matches" $ do
+ request methodGet "" [] "" `shouldRespondWith` 404
+
+ it "should respond with 405 if a path but not method matches" $ do
+ request methodGet "path2" [] "" `shouldRespondWith` 405
+
+ it "should respond with the corresponding error if path and method match" $ do
+ request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
+ `shouldRespondWith` 415
+ request methodPost "path3" [(hContentType, "application/json")] ""
+ `shouldRespondWith` 400
+ request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
+ (hAccept, "blah")] "5"
+ `shouldRespondWith` 406
+ it "should respond with 415 only if none of the subservers supports the request's content type" $ do
+ request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"
+ `shouldRespondWith` 200
+ request methodPost "path5" [(hContentType, "application/json")] "1"
+ `shouldRespondWith` 200
+ request methodPost "path5" [(hContentType, "application/not-supported")] ""
+ `shouldRespondWith` 415
+
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Instances {{{
+
+instance MimeUnrender PlainText Int where
+ mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)
+
+instance MimeRender PlainText Int where
+ mimeRender _ = BCL.pack . show
+-- }}}
+-}
--- /dev/null
+module Main where
+
+import System.IO (IO)
+import Data.Function (($))
+import Test.Tasty
+import qualified Hspec
+
+main :: IO ()
+main = do
+ hspec <- Hspec.hspec
+ defaultMain $
+ testGroup "Symantic.HTTP"
+ [ hspec
+ ]
sourcephile / git / haskell / symantic-http.git / commitdiff