{-# LANGUAGE CPP #-}
module Servant.QuickCheck.Internal.ErrorTypes where

import           Control.Exception       (Exception (..))
import qualified Data.ByteString.Lazy    as LBS
import qualified Data.ByteString.Char8   as BS8
import qualified Data.Text               as T
import           Data.Typeable           (Typeable)
import           GHC.Generics            (Generic)
import qualified Network.HTTP.Client     as C
import           Network.HTTP.Types      (Header, statusCode)
import           Text.PrettyPrint

import           Prelude.Compat hiding ((<>))
import qualified Data.ByteString.Lazy.Char8 as BSL8

data PredicateFailure
  = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
  deriving (Typeable, (forall x. PredicateFailure -> Rep PredicateFailure x)
-> (forall x. Rep PredicateFailure x -> PredicateFailure)
-> Generic PredicateFailure
forall x. Rep PredicateFailure x -> PredicateFailure
forall x. PredicateFailure -> Rep PredicateFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PredicateFailure -> Rep PredicateFailure x
from :: forall x. PredicateFailure -> Rep PredicateFailure x
$cto :: forall x. Rep PredicateFailure x -> PredicateFailure
to :: forall x. Rep PredicateFailure x -> PredicateFailure
Generic)

instance Exception ServerEqualityFailure where

instance Show PredicateFailure where
  show :: PredicateFailure -> String
show = Doc -> String
render (Doc -> String)
-> (PredicateFailure -> Doc) -> PredicateFailure -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure -> Doc
prettyPredicateFailure


data ServerEqualityFailure
  = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
  deriving (Typeable, (forall x. ServerEqualityFailure -> Rep ServerEqualityFailure x)
-> (forall x. Rep ServerEqualityFailure x -> ServerEqualityFailure)
-> Generic ServerEqualityFailure
forall x. Rep ServerEqualityFailure x -> ServerEqualityFailure
forall x. ServerEqualityFailure -> Rep ServerEqualityFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerEqualityFailure -> Rep ServerEqualityFailure x
from :: forall x. ServerEqualityFailure -> Rep ServerEqualityFailure x
$cto :: forall x. Rep ServerEqualityFailure x -> ServerEqualityFailure
to :: forall x. Rep ServerEqualityFailure x -> ServerEqualityFailure
Generic)

instance Show ServerEqualityFailure where
  show :: ServerEqualityFailure -> String
show = Doc -> String
render (Doc -> String)
-> (ServerEqualityFailure -> Doc)
-> ServerEqualityFailure
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerEqualityFailure -> Doc
prettyServerEqualityFailure


instance Exception PredicateFailure where

-- * Pretty printing

prettyHeaders :: [Header] -> Doc
prettyHeaders :: [Header] -> Doc
prettyHeaders [Header]
hdrs = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Header -> Doc
forall {a} {a}. (Show a, Show a) => (a, a) -> Doc
prettyHdr (Header -> Doc) -> [Header] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Header]
hdrs
  where
    prettyHdr :: (a, a) -> Doc
prettyHdr (a
hn, a
h) = String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
hn) Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<+>  String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
h)

prettyReq :: C.Request -> Doc
prettyReq :: Request -> Doc
prettyReq Request
r =
  String -> Doc
text String
"Request:" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
5 (String -> Doc
text String
"Method:"   Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
5 (String -> Doc
text (String -> Doc) -> (ByteString -> String) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a. Show a => a -> String
show (ByteString -> Doc) -> ByteString -> Doc
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
C.method Request
r)
  Doc -> Doc -> Doc
$$ String -> Doc
text String
"Path:"     Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
5 (String -> Doc
text (String -> Doc) -> (ByteString -> String) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS8.unpack (ByteString -> Doc) -> ByteString -> Doc
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
C.path Request
r)
  Doc -> Doc -> Doc
$$ String -> Doc
text String
"Headers:"  Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
5 ([Header] -> Doc
prettyHeaders ([Header] -> Doc) -> [Header] -> Doc
forall a b. (a -> b) -> a -> b
$ Request -> [Header]
C.requestHeaders Request
r)
  Doc -> Doc -> Doc
$$ String -> Doc
text String
"Body:"     Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
5 (String -> Doc
text (String -> Doc) -> (RequestBody -> String) -> RequestBody -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestBody -> String
getReqBody (RequestBody -> Doc) -> RequestBody -> Doc
forall a b. (a -> b) -> a -> b
$ Request -> RequestBody
C.requestBody Request
r))
  where
    getReqBody :: C.RequestBody -> String
    getReqBody :: RequestBody -> String
getReqBody (C.RequestBodyLBS ByteString
lbs ) = ByteString -> String
BSL8.unpack ByteString
lbs
    getReqBody (C.RequestBodyBS ByteString
bs ) = ByteString -> String
BS8.unpack ByteString
bs
    getReqBody RequestBody
_ = ShowS
forall a. HasCallStack => String -> a
error String
"expected bytestring body"

prettyResp :: C.Response LBS.ByteString -> Doc
prettyResp :: Response ByteString -> Doc
prettyResp Response ByteString
r =
  String -> Doc
text String
"Response:" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
5 (String -> Doc
text String
"Status code:" Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
5 (String -> Doc
text (String -> Doc) -> (Status -> String) -> Status -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Status -> Int) -> Status -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode (Status -> Doc) -> Status -> Doc
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
C.responseStatus Response ByteString
r)
  Doc -> Doc -> Doc
$$ String -> Doc
text String
"Headers:"  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
10 ([Header] -> Doc
prettyHeaders ([Header] -> Doc) -> [Header] -> Doc
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [Header]
forall body. Response body -> [Header]
C.responseHeaders Response ByteString
r)
  Doc -> Doc -> Doc
$$ String -> Doc
text String
"Body:"     Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
5 (String -> Doc
text (String -> Doc) -> (ByteString -> String) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSL8.unpack (ByteString -> Doc) -> ByteString -> Doc
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
C.responseBody Response ByteString
r))



prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
prettyServerEqualityFailure (ServerEqualityFailure Request
req Response ByteString
resp1 Response ByteString
resp2) =
  String -> Doc
text String
"Server equality failed" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
5 (Request -> Doc
prettyReq Request
req
  Doc -> Doc -> Doc
$$ Response ByteString -> Doc
prettyResp Response ByteString
resp1
  Doc -> Doc -> Doc
$$ Response ByteString -> Doc
prettyResp Response ByteString
resp2)


prettyPredicateFailure :: PredicateFailure -> Doc
prettyPredicateFailure :: PredicateFailure -> Doc
prettyPredicateFailure (PredicateFailure Text
predicate Maybe Request
req Response ByteString
resp) =
  String -> Doc
text String
"Predicate failed" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
5 (String -> Doc
text String
"Predicate:" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
T.unpack Text
predicate)
  Doc -> Doc -> Doc
$$ Doc
r
  Doc -> Doc -> Doc
$$ Response ByteString -> Doc
prettyResp Response ByteString
resp)
  where
    r :: Doc
r = case Maybe Request
req of
      Maybe Request
Nothing -> String -> Doc
text String
""
      Just Request
v  -> Request -> Doc
prettyReq Request
v