{-# LANGUAGE CPP #-}

module Testlib.Assertions where

import Control.Applicative ((<|>))
import Control.Exception as E
import Control.Lens ((^?))
import qualified Control.Lens.Plated as LP
import Control.Monad
import qualified Control.Monad.Catch as Catch
import Control.Monad.Reader
import Control.Retry
import Data.Aeson (Value)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Diff as AD
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import Data.Aeson.Lens (_Array, _Object)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Foldable
import Data.Hex
import Data.List
import qualified Data.Map as Map
import Data.Maybe (isJust, mapMaybe)
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 GHC.Stack as Stack
import qualified Network.HTTP.Client as HTTP
import System.FilePath
import Testlib.JSON
import Testlib.Printing
import Testlib.Types
import Prelude

assertBool :: (HasCallStack) => String -> Bool -> App ()
assertBool :: HasCallStack => String -> Bool -> App ()
assertBool String
_ Bool
True = () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
assertBool String
msg Bool
False = String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
msg

assertOne :: (HasCallStack, Foldable t) => t a -> App a
assertOne :: forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne t a
xs = case t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs of
  [a
x] -> a -> App a
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  [a]
other -> String -> App a
forall a. HasCallStack => String -> App a
assertFailure (String
"Expected one, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
other))

expectFailure :: (HasCallStack) => (AssertionFailure -> App ()) -> App a -> App ()
expectFailure :: forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure AssertionFailure -> App ()
checkFailure App a
action = do
  Env
env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  Either AssertionFailure a
res :: Either AssertionFailure x <-
    IO (Either AssertionFailure a) -> App (Either AssertionFailure a)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO a -> IO (Either AssertionFailure a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (Env -> App a -> IO a
forall a. Env -> App a -> IO a
runAppWithEnv Env
env App a
action))
  case Either AssertionFailure a
res of
    Left AssertionFailure
e -> AssertionFailure -> App ()
checkFailure AssertionFailure
e
    Right a
_ -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"Expected AssertionFailure, but none occured"

shouldMatch ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected value
  b ->
  App ()
shouldMatch :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch = Maybe String -> a -> b -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
Maybe String -> a -> b -> App ()
shouldMatchWithMsg Maybe String
forall a. Maybe a
Nothing

-- | Retries every 100ms until timeOutSeconds from Env is reached
shouldEventuallyMatch :: (MakesValue a, MakesValue b, HasCallStack) => a -> b -> App ()
shouldEventuallyMatch :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldEventuallyMatch a
a b
b = do
  Int
timeout <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.timeOutSeconds)
  RetryPolicyM App
-> [RetryStatus -> Handler App Bool]
-> (RetryStatus -> App ())
-> App ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering
    (Int -> RetryPolicyM App -> RetryPolicyM App
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay (Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000) (RetryPolicyM App -> RetryPolicyM App)
-> RetryPolicyM App -> RetryPolicyM App
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM App
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
100_000)
    ((\RetryStatus
_ -> (AssertionFailure -> App Bool) -> Handler App Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Catch.Handler ((AssertionFailure -> App Bool) -> Handler App Bool)
-> (AssertionFailure -> App Bool) -> Handler App Bool
forall a b. (a -> b) -> a -> b
$ \(AssertionFailure
_ :: AssertionFailure) -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (RetryStatus -> Handler App Bool)
-> [RetryStatus -> Handler App Bool]
-> [RetryStatus -> Handler App Bool]
forall a. a -> [a] -> [a]
: [RetryStatus -> Handler App Bool]
forall (m :: * -> *). MonadIO m => [RetryStatus -> Handler m Bool]
skipAsyncExceptions)
    (App () -> RetryStatus -> App ()
forall a b. a -> b -> a
const (App () -> RetryStatus -> App ())
-> App () -> RetryStatus -> App ()
forall a b. (a -> b) -> a -> b
$ a
a a -> b -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` b
b)

shouldMatchWithMsg ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | Message to be added to failure report
  Maybe String ->
  -- | The actual value
  a ->
  -- | The expected value
  b ->
  App ()
shouldMatchWithMsg :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
Maybe String -> a -> b -> App ()
shouldMatchWithMsg Maybe String
msg a
a b
b = do
  Value
xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  Value
xb <- b -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make b
b
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value
xa Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
xb) do
    String
pa <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
xa
    String
pb <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
xb
    String
diff <- -- show diff, but only in the interesting cases.
      if (Maybe (KeyMap Value) -> Bool
forall a. Maybe a -> Bool
isJust (Value
xa Value
-> Getting (First (KeyMap Value)) Value (KeyMap Value)
-> Maybe (KeyMap Value)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First (KeyMap Value)) Value (KeyMap Value)
forall t. AsValue t => Prism' t (KeyMap Value)
Prism' Value (KeyMap Value)
_Object) Bool -> Bool -> Bool
&& Maybe (KeyMap Value) -> Bool
forall a. Maybe a -> Bool
isJust (Value
xb Value
-> Getting (First (KeyMap Value)) Value (KeyMap Value)
-> Maybe (KeyMap Value)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First (KeyMap Value)) Value (KeyMap Value)
forall t. AsValue t => Prism' t (KeyMap Value)
Prism' Value (KeyMap Value)
_Object))
        Bool -> Bool -> Bool
|| (Maybe (Vector Value) -> Bool
forall a. Maybe a -> Bool
isJust (Value
xa Value
-> Getting (First (Vector Value)) Value (Vector Value)
-> Maybe (Vector Value)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First (Vector Value)) Value (Vector Value)
forall t. AsValue t => Prism' t (Vector Value)
Prism' Value (Vector Value)
_Array) Bool -> Bool -> Bool
&& Maybe (Vector Value) -> Bool
forall a. Maybe a -> Bool
isJust (Value
xb Value
-> Getting (First (Vector Value)) Value (Vector Value)
-> Maybe (Vector Value)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First (Vector Value)) Value (Vector Value)
forall t. AsValue t => Prism' t (Vector Value)
Prism' Value (Vector Value)
_Array))
        then (String
"\nDiff:\n" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Patch -> App String
forall a. MakesValue a => a -> App String
prettyJSON (Value -> Value -> Patch
AD.diff Value
xa Value
xb)
        else String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") Maybe String
msg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Actual:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pa String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nExpected:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pb String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
diff

data LenientMatchRule
  = EmptyArrayIsNull
  | ArraysAreSets
  | RemoveNullFieldsFromObjects
  deriving (LenientMatchRule -> LenientMatchRule -> Bool
(LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> Eq LenientMatchRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LenientMatchRule -> LenientMatchRule -> Bool
== :: LenientMatchRule -> LenientMatchRule -> Bool
$c/= :: LenientMatchRule -> LenientMatchRule -> Bool
/= :: LenientMatchRule -> LenientMatchRule -> Bool
Eq, Eq LenientMatchRule
Eq LenientMatchRule =>
(LenientMatchRule -> LenientMatchRule -> Ordering)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> LenientMatchRule)
-> (LenientMatchRule -> LenientMatchRule -> LenientMatchRule)
-> Ord LenientMatchRule
LenientMatchRule -> LenientMatchRule -> Bool
LenientMatchRule -> LenientMatchRule -> Ordering
LenientMatchRule -> LenientMatchRule -> LenientMatchRule
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LenientMatchRule -> LenientMatchRule -> Ordering
compare :: LenientMatchRule -> LenientMatchRule -> Ordering
$c< :: LenientMatchRule -> LenientMatchRule -> Bool
< :: LenientMatchRule -> LenientMatchRule -> Bool
$c<= :: LenientMatchRule -> LenientMatchRule -> Bool
<= :: LenientMatchRule -> LenientMatchRule -> Bool
$c> :: LenientMatchRule -> LenientMatchRule -> Bool
> :: LenientMatchRule -> LenientMatchRule -> Bool
$c>= :: LenientMatchRule -> LenientMatchRule -> Bool
>= :: LenientMatchRule -> LenientMatchRule -> Bool
$cmax :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
max :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
$cmin :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
min :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
Ord, Int -> LenientMatchRule -> String -> String
[LenientMatchRule] -> String -> String
LenientMatchRule -> String
(Int -> LenientMatchRule -> String -> String)
-> (LenientMatchRule -> String)
-> ([LenientMatchRule] -> String -> String)
-> Show LenientMatchRule
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LenientMatchRule -> String -> String
showsPrec :: Int -> LenientMatchRule -> String -> String
$cshow :: LenientMatchRule -> String
show :: LenientMatchRule -> String
$cshowList :: [LenientMatchRule] -> String -> String
showList :: [LenientMatchRule] -> String -> String
Show, LenientMatchRule
LenientMatchRule -> LenientMatchRule -> Bounded LenientMatchRule
forall a. a -> a -> Bounded a
$cminBound :: LenientMatchRule
minBound :: LenientMatchRule
$cmaxBound :: LenientMatchRule
maxBound :: LenientMatchRule
Bounded, Int -> LenientMatchRule
LenientMatchRule -> Int
LenientMatchRule -> [LenientMatchRule]
LenientMatchRule -> LenientMatchRule
LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
LenientMatchRule
-> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
(LenientMatchRule -> LenientMatchRule)
-> (LenientMatchRule -> LenientMatchRule)
-> (Int -> LenientMatchRule)
-> (LenientMatchRule -> Int)
-> (LenientMatchRule -> [LenientMatchRule])
-> (LenientMatchRule -> LenientMatchRule -> [LenientMatchRule])
-> (LenientMatchRule -> LenientMatchRule -> [LenientMatchRule])
-> (LenientMatchRule
    -> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule])
-> Enum LenientMatchRule
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LenientMatchRule -> LenientMatchRule
succ :: LenientMatchRule -> LenientMatchRule
$cpred :: LenientMatchRule -> LenientMatchRule
pred :: LenientMatchRule -> LenientMatchRule
$ctoEnum :: Int -> LenientMatchRule
toEnum :: Int -> LenientMatchRule
$cfromEnum :: LenientMatchRule -> Int
fromEnum :: LenientMatchRule -> Int
$cenumFrom :: LenientMatchRule -> [LenientMatchRule]
enumFrom :: LenientMatchRule -> [LenientMatchRule]
$cenumFromThen :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
enumFromThen :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
$cenumFromTo :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
enumFromTo :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
$cenumFromThenTo :: LenientMatchRule
-> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
enumFromThenTo :: LenientMatchRule
-> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
Enum)

shouldMatchWithRules ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  [LenientMatchRule] ->
  (Aeson.Value -> App (Maybe Aeson.Value)) ->
  a ->
  b ->
  App ()
shouldMatchWithRules :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
[LenientMatchRule]
-> (Value -> App (Maybe Value)) -> a -> b -> App ()
shouldMatchWithRules [LenientMatchRule]
rules Value -> App (Maybe Value)
customRules a
a b
b = do
  Value
xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  Value
xb <- b -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make b
b
  Value -> App Value
simplify Value
xa App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App Value
simplify Value
xb
  where
    simplify :: Aeson.Value -> App Aeson.Value
    simplify :: Value -> App Value
simplify = (Value -> App (Maybe Value)) -> Value -> App Value
forall (m :: * -> *) a.
(Monad m, Plated a) =>
(a -> m (Maybe a)) -> a -> m a
LP.rewriteM ((Value -> App (Maybe Value)) -> Value -> App Value)
-> (Value -> App (Maybe Value)) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ (\Value
v -> (Maybe Value -> (Value -> App (Maybe Value)) -> App (Maybe Value))
-> Maybe Value -> [Value -> App (Maybe Value)] -> App (Maybe Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Value
-> Maybe Value -> (Value -> App (Maybe Value)) -> App (Maybe Value)
tryApplyRule Value
v) Maybe Value
forall a. Maybe a
Nothing [Value -> App (Maybe Value)]
compiledRules)

    tryApplyRule ::
      Aeson.Value ->
      Maybe Aeson.Value ->
      (Aeson.Value -> App (Maybe Aeson.Value)) ->
      App (Maybe Aeson.Value)
    tryApplyRule :: Value
-> Maybe Value -> (Value -> App (Maybe Value)) -> App (Maybe Value)
tryApplyRule Value
v Maybe Value
bresult Value -> App (Maybe Value)
arule = (Maybe Value
bresult <|>) (Maybe Value -> Maybe Value)
-> App (Maybe Value) -> App (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> App (Maybe Value)
arule Value
v

    compiledRules :: [Aeson.Value -> App (Maybe Aeson.Value)]
    compiledRules :: [Value -> App (Maybe Value)]
compiledRules = Value -> App (Maybe Value)
customRules (Value -> App (Maybe Value))
-> [Value -> App (Maybe Value)] -> [Value -> App (Maybe Value)]
forall a. a -> [a] -> [a]
: ((\LenientMatchRule
r Value
v -> Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> App (Maybe Value))
-> Maybe Value -> App (Maybe Value)
forall a b. (a -> b) -> a -> b
$ LenientMatchRule -> Value -> Maybe Value
runRule LenientMatchRule
r Value
v) (LenientMatchRule -> Value -> App (Maybe Value))
-> [LenientMatchRule] -> [Value -> App (Maybe Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LenientMatchRule]
rules)

    runRule :: LenientMatchRule -> Aeson.Value -> Maybe Aeson.Value
    runRule :: LenientMatchRule -> Value -> Maybe Value
runRule LenientMatchRule
EmptyArrayIsNull = \case
      Aeson.Array Vector Value
arr
        | Vector Value
arr Vector Value -> Vector Value -> Bool
forall a. Eq a => a -> a -> Bool
== Vector Value
forall a. Monoid a => a
mempty ->
            Value -> Maybe Value
forall a. a -> Maybe a
Just Value
Aeson.Null
      Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    runRule LenientMatchRule
ArraysAreSets = \case
      Aeson.Array (Vector Value -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [Value]
arr) ->
        let arr' :: [Value]
arr' = [Value] -> [Value]
forall a. Ord a => [a] -> [a]
sort [Value]
arr
         in if [Value]
arr [Value] -> [Value] -> Bool
forall a. Eq a => a -> a -> Bool
== [Value]
arr' then Maybe Value
forall a. Maybe a
Nothing else Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON [Value]
arr'
      Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    runRule LenientMatchRule
RemoveNullFieldsFromObjects = \case
      Aeson.Object (KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Aeson.toList -> [(Key, Value)]
obj)
        | ((Key, Value) -> Bool) -> [(Key, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
Aeson.Null) (Value -> Bool) -> ((Key, Value) -> Value) -> (Key, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Value
forall a b. (a, b) -> b
snd) [(Key, Value)]
obj ->
            let rmNulls :: (a, Value) -> Maybe (a, Value)
rmNulls (a
_, Value
Aeson.Null) = Maybe (a, Value)
forall a. Maybe a
Nothing
                rmNulls (a
k, Value
v) = (a, Value) -> Maybe (a, Value)
forall a. a -> Maybe a
Just (a
k, Value
v)
             in Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([(Key, Value)] -> Value) -> [(Key, Value)] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Value -> Value
Aeson.Object (KeyMap Value -> Value)
-> ([(Key, Value)] -> KeyMap Value) -> [(Key, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
Aeson.fromList ([(Key, Value)] -> Maybe Value) -> [(Key, Value)] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Maybe (Key, Value))
-> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key, Value) -> Maybe (Key, Value)
forall {a}. (a, Value) -> Maybe (a, Value)
rmNulls [(Key, Value)]
obj
      Value
_ -> Maybe Value
forall a. Maybe a
Nothing

shouldMatchBase64 ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | The actual value, in base64
  a ->
  -- | The expected value, in plain text
  b ->
  App ()
a
a shouldMatchBase64 :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchBase64` b
b = do
  Text
xa <- ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (String -> ByteString) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.decodeLenient (ByteString -> ByteString)
-> (String -> ByteString) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> App String -> App Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString a
a
  Text
xa Text -> b -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` b
b

shouldNotMatch ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The un-expected value
  b ->
  App ()
a
a shouldNotMatch :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldNotMatch` b
b = do
  Value
xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  Value
xb <- b -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make b
b

  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> String
jsonType Value
xa String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> String
jsonType Value
xb) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String
pa <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
xa
    String
pb <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
xb
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$
      String
"Compared values are not of the same type:\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Left side:\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pa
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nRight side:\n"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pb

  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
xa Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
xb) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String
pa <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
xa
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Expected different value but got this:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pa

-- | Specialized variant of `shouldMatch` to avoid the need for type annotations.
shouldMatchInt ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected value
  Int ->
  App ()
shouldMatchInt :: forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
shouldMatchInt = a -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch

shouldNotMatchInt ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected value
  Int ->
  App ()
shouldNotMatchInt :: forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
shouldNotMatchInt = a -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldNotMatch

shouldMatchRange ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected range, inclusive both sides
  (Int, Int) ->
  App ()
shouldMatchRange :: forall a. (MakesValue a, HasCallStack) => a -> (Int, Int) -> App ()
shouldMatchRange a
a (Int
lower, Int
upper) = do
  Int
xa :: Int <- a -> App Int
forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral a
a
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
xa Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lower Bool -> Bool -> Bool
|| Int
xa Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
upper) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String
pa <- Int -> App String
forall a. MakesValue a => a -> App String
prettyJSON Int
xa
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Actual:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pa String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nExpected:\nin range (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
lower String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
upper String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") (including bounds)"

-- | Match on sorted lists (sets where elements may occur more than once).  (Maybe this should
-- be called `shouldMatchMultiSet`?)
shouldMatchSet ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  a ->
  b ->
  App ()
shouldMatchSet :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatchSet a
a b
b = do
  [Value]
la <- ([Value] -> [Value]) -> App [Value] -> App [Value]
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Value] -> [Value]
forall a. Ord a => [a] -> [a]
sort (a -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList a
a)
  [Value]
lb <- ([Value] -> [Value]) -> App [Value] -> App [Value]
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Value] -> [Value]
forall a. Ord a => [a] -> [a]
sort (b -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList b
b)
  [Value]
la [Value] -> [Value] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` [Value]
lb

shouldBeEmpty :: (MakesValue a, HasCallStack) => a -> App ()
shouldBeEmpty :: forall a. (MakesValue a, HasCallStack) => a -> App ()
shouldBeEmpty a
a = a
a a -> [Value] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ([Value]
forall a. Monoid a => a
mempty :: [Value])

shouldBeNull :: (MakesValue a, HasCallStack) => a -> App ()
shouldBeNull :: forall a. (MakesValue a, HasCallStack) => a -> App ()
shouldBeNull a
a = a
a a -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
Aeson.Null

shouldMatchOneOf ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  a ->
  b ->
  App ()
shouldMatchOneOf :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatchOneOf a
a b
b = do
  [Value]
lb <- b -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList b
b
  Value
xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value
xa Value -> [Value] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Value]
lb) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String
pa <- a -> App String
forall a. MakesValue a => a -> App String
prettyJSON a
a
    String
pb <- b -> App String
forall a. MakesValue a => a -> App String
prettyJSON b
b
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Expected:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pa String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n to match at least one of:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pb

shouldContainString ::
  (HasCallStack) =>
  -- | The actual value
  String ->
  -- | The expected value
  String ->
  App ()
shouldContainString :: HasCallStack => String -> String -> App ()
shouldContainString = String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
shouldContain

shouldContain ::
  (Eq a, Show a, HasCallStack) =>
  -- | The actual value
  [a] ->
  -- | The expected value
  [a] ->
  App ()
[a]
super shouldContain :: forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` [a]
sub = do
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([a]
sub [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [a]
super) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"String or List:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
super String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nDoes not contain:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
sub

printFailureDetails :: AssertionFailure -> IO String
printFailureDetails :: AssertionFailure -> IO String
printFailureDetails (AssertionFailure CallStack
stack Maybe Response
mbResponse Maybe String
ctx String
msg) = do
  String
s <- CallStack -> IO String
prettierCallStack CallStack
stack
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> ([String] -> String) -> [String] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO String) -> [String] -> IO String
forall a b. (a -> b) -> a -> b
$
    String -> String -> String
colored String
yellow String
"assertion failure:"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> String -> String
colored String
red String
msg
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Maybe String -> [String]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Response -> String) -> Maybe Response -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> String
prettyResponse Maybe Response
mbResponse)
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Maybe String -> [String]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
prettyContext Maybe String
ctx)

printAppFailureDetails :: AppFailure -> IO String
printAppFailureDetails :: AppFailure -> IO String
printAppFailureDetails (AppFailure String
msg CallStack
stack) = do
  String
s <- CallStack -> IO String
prettierCallStack CallStack
stack
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> ([String] -> String) -> [String] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO String) -> [String] -> IO String
forall a b. (a -> b) -> a -> b
$
    String -> String -> String
colored String
yellow String
"app failure:"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> String -> String
colored String
red String
msg
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"\n"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
s]

prettyContext :: String -> String
prettyContext :: String -> String
prettyContext String
ctx = do
  [String] -> String
unlines
    [ String -> String -> String
colored String
yellow String
"context:",
      String -> String -> String
colored String
blue String
ctx
    ]

printExceptionDetails :: SomeException -> IO String
printExceptionDetails :: SomeException -> IO String
printExceptionDetails SomeException
e = do
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> ([String] -> String) -> [String] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO String) -> [String] -> IO String
forall a b. (a -> b) -> a -> b
$
    [ String -> String -> String
colored String
yellow String
"exception:",
      String -> String -> String
colored String
red (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
    ]

prettierCallStack :: CallStack -> IO String
prettierCallStack :: CallStack -> IO String
prettierCallStack CallStack
cstack = do
  String
sl <-
    CallStack -> IO String
prettierCallStackLines
      (CallStack -> IO String)
-> (CallStack -> CallStack) -> CallStack -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, SrcLoc)] -> CallStack
Stack.fromCallSiteList
      ([(String, SrcLoc)] -> CallStack)
-> (CallStack -> [(String, SrcLoc)]) -> CallStack -> CallStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, SrcLoc) -> Bool)
-> [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, SrcLoc) -> Bool) -> (String, SrcLoc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> Bool
isTestlibEntry)
      ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> (CallStack -> [(String, SrcLoc)])
-> CallStack
-> [(String, SrcLoc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [(String, SrcLoc)]
Stack.getCallStack
      (CallStack -> IO String) -> CallStack -> IO String
forall a b. (a -> b) -> a -> b
$ CallStack
cstack
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String -> String -> String
colored String
yellow String
"call stack: ", String
sl]
  where
    isTestlibEntry :: (String, SrcLoc) -> Bool
    isTestlibEntry :: (String, SrcLoc) -> Bool
isTestlibEntry (String
_, SrcLoc {Int
String
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
..}) =
      String
"RunAllTests.hs" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
srcLocFile

prettierCallStackLines :: CallStack -> IO String
prettierCallStackLines :: CallStack -> IO String
prettierCallStackLines CallStack
cstack =
  SourceDirCache -> String -> [(String, SrcLoc)] -> Int -> IO String
forall {t}.
(Show t, Num t) =>
SourceDirCache -> String -> [(String, SrcLoc)] -> t -> IO String
go SourceDirCache
forall k a. Map k a
Map.empty String
"" (CallStack -> [(String, SrcLoc)]
Stack.getCallStack CallStack
cstack) (Int
1 :: Int)
  where
    go :: SourceDirCache -> String -> [(String, SrcLoc)] -> t -> IO String
go SourceDirCache
_ String
s [] t
_ = String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
    go SourceDirCache
cache String
s ((String
funName, SrcLoc {Int
String
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
..}) : [(String, SrcLoc)]
rest) t
i = do
      (SourceDirCache
cache', Maybe String
mSrcDir) <- SourceDirCache -> String -> IO (SourceDirCache, Maybe String)
getSourceDirCached SourceDirCache
cache String
srcLocPackage
      Maybe String
mLine <- case Maybe String
mSrcDir of
        Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        Just String
srcDir -> do
          Maybe String
mSrc <- String -> IO (Maybe String)
tryReadFile (String
srcDir String -> String -> String
</> String
srcLocFile)
          case Maybe String
mSrc of
            Just String
src ->
              case Int -> String -> Maybe String
getLineNumber Int
srcLocStartLine String
src of
                Just String
line -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
line))
                Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
            Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
      let s' :: String
s' = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
funName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
srcLocFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
yellow (Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
      let s'' :: String
s'' = case Maybe String
mLine of
            Just String
line -> String
s' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
blue (String
"     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
line String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n")
            Maybe String
Nothing -> String
s'
      SourceDirCache -> String -> [(String, SrcLoc)] -> t -> IO String
go SourceDirCache
cache' (String
s'' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") [(String, SrcLoc)]
rest (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

getSourceDir :: String -> IO (Maybe FilePath)
getSourceDir :: String -> IO (Maybe String)
getSourceDir String
packageId = do
  Maybe String
ms <- String -> IO (Maybe String)
tryReadFile (String -> String
packagedbFile String
packageId)
  case Maybe String
ms of
    Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    Just String
s ->
      Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
extractDataDir String
s)
  where
    packagedbFile :: String -> FilePath
    packagedbFile :: String -> String
packagedbFile String
pkgId =
      let root :: String
root = String
"./dist-newstyle/packagedb/ghc-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> __GLASGOW_HASKELL_FULL_VERSION__
       in String
root String -> String -> String
</> (String
pkgId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".conf")

    extractDataDir :: String -> Maybe String
    extractDataDir :: String -> Maybe String
extractDataDir String
s = [String] -> Maybe String
go (String -> [String]
lines String
s)
      where
        go :: [String] -> Maybe String
go [] = Maybe String
forall a. Maybe a
Nothing
        go (String
line : [String]
otherlines) =
          case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"data-dir:" String
line of
            Just String
rest -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest
            Maybe String
Nothing -> [String] -> Maybe String
go [String]
otherlines

type SourceDirCache = Map.Map String (Maybe FilePath)

getSourceDirCached :: SourceDirCache -> String -> IO (SourceDirCache, Maybe FilePath)
getSourceDirCached :: SourceDirCache -> String -> IO (SourceDirCache, Maybe String)
getSourceDirCached SourceDirCache
cache String
packageId =
  case String -> SourceDirCache -> Maybe (Maybe String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
packageId SourceDirCache
cache of
    Just Maybe String
hit -> (SourceDirCache, Maybe String) -> IO (SourceDirCache, Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceDirCache
cache, Maybe String
hit)
    Maybe (Maybe String)
Nothing -> do
      Maybe String
v <- String -> IO (Maybe String)
getSourceDir String
packageId
      (SourceDirCache, Maybe String) -> IO (SourceDirCache, Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String -> SourceDirCache -> SourceDirCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
packageId Maybe String
v SourceDirCache
cache, Maybe String
v)

tryReadFile :: FilePath -> IO (Maybe String)
tryReadFile :: String -> IO (Maybe String)
tryReadFile String
p = do
  Either SomeException String
eith <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (String -> IO String
readFile String
p)
  Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ case Either SomeException String
eith of
    Left SomeException
_ -> Maybe String
forall a. Maybe a
Nothing
    Right String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s

getLineNumber :: Int -> String -> Maybe String
getLineNumber :: Int -> String -> Maybe String
getLineNumber Int
lineNo String
s =
  case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (String -> [String]
lines String
s) of
    [] -> Maybe String
forall a. Maybe a
Nothing
    (String
l : [String]
_) -> String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
l

prettyResponse :: Response -> String
prettyResponse :: Response -> String
prettyResponse Response
r =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
yellow String
"request: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Request -> String
showRequest Response
r.request,
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
yellow String
"request headers: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Header] -> String
showHeaders (Request -> [Header]
HTTP.requestHeaders Response
r.request),
        case Request -> Maybe ByteString
getRequestBody Response
r.request of
          Maybe ByteString
Nothing -> []
          Just ByteString
b ->
            [ String -> String -> String
colored String
yellow String
"request body:",
              Text -> String
Text.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> ByteString
BS.fromStrict ByteString
b) of
                Just Value
v -> ByteString -> ByteString
BS.toStrict (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty (Value
v :: Aeson.Value))
                Maybe Value
Nothing -> ByteString -> ByteString
forall t. Hex t => t -> t
hex ByteString
b
            ],
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
blue String
"response status: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Response
r.status,
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
blue String
"response body:",
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$
          ( Text -> String
TL.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$
              case Response
r.jsonBody of
                Just Value
b -> (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty Value
b)
                Maybe Value
Nothing -> ByteString -> ByteString
BS.fromStrict Response
r.body
          )
      ]