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