From 739788e42dab33e459ef183b61b32ee178904bc1 Mon Sep 17 00:00:00 2001 From: Julien Moutinho <julm+symantic-http@autogeree.net> Date: Sun, 24 Feb 2019 18:37:01 +0000 Subject: [PATCH] Stop here to drop megaparsec --- Symantic/HTTP/API.hs | 57 ++++-- Symantic/HTTP/Command.hs | 12 +- Symantic/HTTP/Layout.hs | 6 +- Symantic/HTTP/Router.hs | 49 +++-- symantic-http.cabal | 97 ++++++---- test/HUnit.hs | 8 + test/Hspec.hs | 16 ++ test/Hspec/API.hs | 162 ++++++++++++++++ test/Hspec/Router.hs | 10 + test/Hspec/Router/Error.hs | 387 +++++++++++++++++++++++++++++++++++++ test/Main.hs | 14 ++ 11 files changed, 740 insertions(+), 78 deletions(-) create mode 100644 test/HUnit.hs create mode 100644 test/Hspec.hs create mode 100644 test/Hspec/API.hs create mode 100644 test/Hspec/Router.hs create mode 100644 test/Hspec/Router/Error.hs create mode 100644 test/Main.hs diff --git a/Symantic/HTTP/API.hs b/Symantic/HTTP/API.hs index 254f6d1..db15273 100644 --- a/Symantic/HTTP/API.hs +++ b/Symantic/HTTP/API.hs @@ -23,8 +23,8 @@ import Symantic.HTTP.Mime -- * Class 'HTTP_API' class - ( Appli repr - , Altern repr + ( Cat repr + , Alt repr , HTTP_Path repr , HTTP_Method repr , HTTP_Header repr @@ -34,23 +34,26 @@ class , 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 @@ -73,6 +76,7 @@ capture = capture' type Segment = T.Text type Path = [Segment] type Name = String + -- * Class 'HTTP_Method' class HTTP_Method repr where method :: HTTP.Method -> repr k k @@ -94,15 +98,17 @@ class HTTP_Method repr where 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 -} @@ -111,18 +117,34 @@ data AcceptResponse repr a = 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 @@ -145,15 +167,10 @@ status200 :: HTTP.Status 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 @@ -166,6 +183,8 @@ 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 => diff --git a/Symantic/HTTP/Command.hs b/Symantic/HTTP/Command.hs index 0119f3a..5913f4f 100644 --- a/Symantic/HTTP/Command.hs +++ b/Symantic/HTTP/Command.hs @@ -43,14 +43,14 @@ runCommand (Command cmd) = cmd ($ def) -- ** 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) @@ -80,8 +80,10 @@ instance HTTP_Accept Command where 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) } diff --git a/Symantic/HTTP/Layout.hs b/Symantic/HTTP/Layout.hs index 1addb0c..99a3157 100644 --- a/Symantic/HTTP/Layout.hs +++ b/Symantic/HTTP/Layout.hs @@ -70,9 +70,9 @@ data LayoutNode 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 @@ -87,7 +87,7 @@ instance HTTP_Header Layout where 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 diff --git a/Symantic/HTTP/Router.hs b/Symantic/HTTP/Router.hs index aa3c3e5..9e8ec84 100644 --- a/Symantic/HTTP/Router.hs +++ b/Symantic/HTTP/Router.hs @@ -8,13 +8,14 @@ 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(..)) @@ -29,6 +30,7 @@ import qualified Data.ByteString as BS 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 @@ -59,6 +61,7 @@ instance Monad (Router f) where 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 @@ -78,16 +81,26 @@ runRouter (Router rt) api rq re = 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 @@ -179,13 +192,13 @@ unRouteToken_Segment :: RouteToken -> Segment 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) @@ -228,18 +241,27 @@ instance HTTP_Accept Router where _ -> 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 @@ -249,6 +271,7 @@ instance HTTP_Query Router where [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 @@ -287,7 +310,7 @@ instance HTTP_Endpoint Router where 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) diff --git a/symantic-http.cabal b/symantic-http.cabal index 42556c9..fbefc84 100644 --- a/symantic-http.cabal +++ b/symantic-http.cabal @@ -48,7 +48,6 @@ Library RecordWildCards ScopedTypeVariables TupleSections - -- TypeFamilies ghc-options: -Wall -Wincomplete-uni-patterns @@ -82,40 +81,62 @@ Library -- 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 diff --git a/test/HUnit.hs b/test/HUnit.hs new file mode 100644 index 0000000..5998321 --- /dev/null +++ b/test/HUnit.hs @@ -0,0 +1,8 @@ +module HUnit where +import Test.Tasty + +hunits :: TestTree +hunits = + testGroup "HUnit" + [ + ] diff --git a/test/Hspec.hs b/test/Hspec.hs new file mode 100644 index 0000000..6f4556f --- /dev/null +++ b/test/Hspec.hs @@ -0,0 +1,16 @@ +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] diff --git a/test/Hspec/API.hs b/test/Hspec/API.hs new file mode 100644 index 0000000..919133b --- /dev/null +++ b/test/Hspec/API.hs @@ -0,0 +1,162 @@ +{-# 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 diff --git a/test/Hspec/Router.hs b/test/Hspec/Router.hs new file mode 100644 index 0000000..61943d9 --- /dev/null +++ b/test/Hspec/Router.hs @@ -0,0 +1,10 @@ +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]) diff --git a/test/Hspec/Router/Error.hs b/test/Hspec/Router/Error.hs new file mode 100644 index 0000000..eb49ca3 --- /dev/null +++ b/test/Hspec/Router/Error.hs @@ -0,0 +1,387 @@ +{-# 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 +-- }}} +-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..aa4aa30 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,14 @@ +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 + ] -- 2.47.2