module Testlib.JSON where

import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Aeson hiding ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.Key as KM
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Types as Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy.Char8 as LC8
import Data.Foldable
import Data.Function
import Data.Functor
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import qualified Data.Scientific as Sci
import qualified Data.Set as Set
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Vector ((!?))
import qualified Data.Vector as V
import GHC.Stack
import Testlib.Types
import Prelude

-- | All library functions should use this typeclass for all untyped value
-- arguments wherever possible. This design choice has advantages:
--
-- No need convert value between different representations. E.g. if a function
-- needs a user id as a string, all these input types become valid input:
--
-- - String
-- - Text
-- - Value
-- - App Text
-- - App String
-- - App Value
--
-- Internally the function calls `asString` to convert to App String
--
-- Since (App a) are treated as first-class values values this means we can
-- compose operations that might fail without giving up nice error messages:
--
-- callMe (response.json %. "user" & "foo.bar.baz" %.= 2)
--
-- This can fail if
-- 1. the response is not application/json
-- 2. has no "user" field
-- 3. the nested update fails
class MakesValue a where
  make :: (HasCallStack) => a -> App Value

instance {-# OVERLAPPABLE #-} (ToJSON a) => MakesValue a where
  make :: HasCallStack => a -> App Value
make = Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> (a -> Value) -> a -> App Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON

instance {-# OVERLAPPING #-} (ToJSON a) => MakesValue (App a) where
  make :: HasCallStack => App a -> App Value
make App a
m = App a
m App a -> (a -> Value) -> App Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> a -> Value
forall a. ToJSON a => a -> Value
toJSON

-- use this to provide Nothing for MakesValue a => (Maybe a) values.
noValue :: Maybe Value
noValue :: Maybe Value
noValue = Maybe Value
forall a. Maybe a
Nothing

(.=) :: (ToJSON a) => String -> a -> Aeson.Pair
.= :: forall a. ToJSON a => String -> a -> Pair
(.=) String
k a
v = String -> Key
forall a. IsString a => String -> a
fromString String
k Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= a
v

(.=?) :: (ToJSON a) => String -> Maybe a -> Maybe Aeson.Pair
.=? :: forall a. ToJSON a => String -> Maybe a -> Maybe Pair
(.=?) String
k Maybe a
v = Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
(Aeson..=) (String -> Key
forall a. IsString a => String -> a
fromString String
k) (a -> Pair) -> Maybe a -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
v

-- | Convert JSON null to Nothing.
asOptional :: (HasCallStack) => (MakesValue a) => a -> App (Maybe Value)
asOptional :: forall a. (HasCallStack, MakesValue a) => a -> App (Maybe Value)
asOptional a
x = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x
  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
$ case Value
v of
    Value
Null -> Maybe Value
forall a. Maybe a
Nothing
    Value
_ -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v

asString :: (HasCallStack) => (MakesValue a) => a -> App String
asString :: forall a. (HasCallStack, MakesValue a) => a -> App String
asString a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (String Text
s) -> String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
s)
    Value
v -> a -> String -> App String
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String
"String" String -> Value -> String
`typeWasExpectedButGot` Value
v)

asText :: (HasCallStack) => (MakesValue a) => a -> App T.Text
asText :: forall a. (HasCallStack, MakesValue a) => a -> App Text
asText = ((String -> Text) -> App String -> App Text
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack) (App String -> App Text) -> (a -> App String) -> a -> App Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

asStringM :: (HasCallStack) => (MakesValue a) => a -> App (Maybe String)
asStringM :: forall a. (HasCallStack, MakesValue a) => a -> App (Maybe String)
asStringM a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App (Maybe String)) -> App (Maybe String)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (String Text
s) -> Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack Text
s))
    Value
_ -> Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

asByteString :: (HasCallStack, MakesValue a) => a -> App ByteString
asByteString :: forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString a
x = do
  String
s <- a -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString a
x
  let bs :: ByteString
bs = Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack String
s)
  case ByteString -> Either String ByteString
Base64.decode ByteString
bs of
    Left String
_ -> String -> App ByteString
forall a. HasCallStack => String -> App a
assertFailure String
"Could not base64 decode"
    Right ByteString
a -> ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
a

asObject :: (HasCallStack) => (MakesValue a) => a -> App Object
asObject :: forall a. (HasCallStack, MakesValue a) => a -> App Object
asObject a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App Object) -> App Object
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Object Object
o) -> Object -> App Object
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
o
    Value
v -> a -> String -> App Object
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String
"Object" String -> Value -> String
`typeWasExpectedButGot` Value
v)

asInt :: (HasCallStack) => (MakesValue a) => a -> App Int
asInt :: forall a. (HasCallStack, MakesValue a) => a -> App Int
asInt = a -> App Int
forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral

asIntegral :: (Integral i, HasCallStack) => (MakesValue a) => a -> App i
asIntegral :: forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App i) -> App i
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Number Scientific
n) ->
      case Scientific -> Either Double i
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Sci.floatingOrInteger Scientific
n of
        Left (Double
_ :: Double) -> String -> App i
forall a. HasCallStack => String -> App a
assertFailure String
"Expected an integral, but got a floating point"
        Right i
i -> i -> App i
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure i
i
    Value
v -> a -> String -> App i
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String
"Number" String -> Value -> String
`typeWasExpectedButGot` Value
v)

asList :: (HasCallStack) => (MakesValue a) => a -> App [Value]
asList :: forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App [Value]) -> App [Value]
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Array Array
arr) -> [Value] -> App [Value]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
arr)
    Value
v -> a -> String -> App [Value]
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String
"Array" String -> Value -> String
`typeWasExpectedButGot` Value
v)

asListOf :: (HasCallStack) => (Value -> App b) -> (MakesValue a) => a -> App [b]
asListOf :: forall b a.
HasCallStack =>
(Value -> App b) -> MakesValue a => a -> App [b]
asListOf Value -> App b
makeElem a
x =
  a -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList a
x App [Value] -> ([Value] -> App [b]) -> App [b]
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> App b) -> [Value] -> App [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> App b
makeElem

asSet :: (HasCallStack) => (MakesValue a) => a -> App (Set.Set Value)
asSet :: forall a. (HasCallStack, MakesValue a) => a -> App (Set Value)
asSet = ([Value] -> Set Value) -> App [Value] -> App (Set Value)
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Value] -> Set Value
forall a. Ord a => [a] -> Set a
Set.fromList (App [Value] -> App (Set Value))
-> (a -> App [Value]) -> a -> App (Set Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList

asSetOf :: (HasCallStack, Ord b) => (Value -> App b) -> (MakesValue a) => a -> App (Set.Set b)
asSetOf :: forall b a.
(HasCallStack, Ord b) =>
(Value -> App b) -> MakesValue a => a -> App (Set b)
asSetOf Value -> App b
makeElem a
x = [b] -> Set b
forall a. Ord a => [a] -> Set a
Set.fromList ([b] -> Set b) -> App [b] -> App (Set b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> App b) -> MakesValue a => a -> App [b]
forall b a.
HasCallStack =>
(Value -> App b) -> MakesValue a => a -> App [b]
asListOf Value -> App b
makeElem a
x

asBool :: (HasCallStack) => (MakesValue a) => a -> App Bool
asBool :: forall a. (HasCallStack, MakesValue a) => a -> App Bool
asBool a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App Bool) -> App Bool
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Bool Bool
b) -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
    Value
v -> a -> String -> App Bool
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String
"Bool" String -> Value -> String
`typeWasExpectedButGot` Value
v)

-- | Get a (nested) field of a JSON object
-- Raise an AssertionFailure if the field at the (nested) key is missing. See
-- 'lookupField' for details.
(%.) ::
  (HasCallStack, MakesValue a) =>
  a ->
  -- | A plain key, e.g. "id", or a nested key "user.profile.id"
  String ->
  App Value
%. :: forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
(%.) a
x String
k = a -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField a
x String
k App (Maybe Value) -> (Maybe Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> String -> Maybe Value -> App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> Maybe Value -> App Value
assertField a
x String
k

isEqual ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  a ->
  b ->
  App Bool
isEqual :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
isEqual = (Value -> Value -> Bool) -> a -> b -> App Bool
forall a b c.
(MakesValue a, MakesValue b, HasCallStack) =>
(Value -> Value -> c) -> a -> b -> App c
liftP2 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(==)

liftP2 ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  (Value -> Value -> c) ->
  a ->
  b ->
  App c
liftP2 :: forall a b c.
(MakesValue a, MakesValue b, HasCallStack) =>
(Value -> Value -> c) -> a -> b -> App c
liftP2 Value -> Value -> c
f a
a b
b = do
  Value -> Value -> c
f (Value -> Value -> c) -> App Value -> App (Value -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a App (Value -> c) -> App Value -> App c
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make b
b

fieldEquals :: (MakesValue a, MakesValue b) => a -> String -> b -> App Bool
fieldEquals :: forall a b.
(MakesValue a, MakesValue b) =>
a -> String -> b -> App Bool
fieldEquals a
a String
fieldSelector b
b = do
  Maybe Value
ma <- a -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField a
a String
fieldSelector App (Maybe Value)
-> (SomeException -> App (Maybe Value)) -> App (Maybe Value)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` App (Maybe Value) -> SomeException -> App (Maybe Value)
forall a b. a -> b -> a
const (Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing)
  case Maybe Value
ma of
    Maybe Value
Nothing -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Value
f ->
      Value
f Value -> b -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` b
b

assertFieldMissing :: (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing :: forall a. (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing a
x String
k = do
  Maybe Value
mValue <- a -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField a
x String
k
  case Maybe Value
mValue of
    Maybe Value
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Value
_ -> a -> String -> App ()
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Field \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" should be missing from object:"

assertField :: (HasCallStack, MakesValue a) => a -> String -> Maybe Value -> App Value
assertField :: forall a.
(HasCallStack, MakesValue a) =>
a -> String -> Maybe Value -> App Value
assertField a
x String
k Maybe Value
Nothing = a -> String -> App Value
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
x (String -> App Value) -> String -> App Value
forall a b. (a -> b) -> a -> b
$ String
"Field \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" is missing from object:"
assertField a
_ String
_ (Just Value
x) = Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
x

-- rename a field if it exists, else return the old object
renameField :: String -> String -> Value -> App Value
renameField :: String -> String -> Value -> App Value
renameField String
old String
new Value
obj =
  Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
obj (Maybe Value -> Value) -> App (Maybe Value) -> App Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT App Value -> App (Maybe Value)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    Value
o :: Value <- MaybeT App Value
-> (Value -> MaybeT App Value) -> Maybe Value -> MaybeT App Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaybeT App Value
forall a. MaybeT App a
forall (m :: * -> *) a. MonadPlus m => m a
mzero Value -> MaybeT App Value
forall a. a -> MaybeT App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> MaybeT App Value)
-> MaybeT App (Maybe Value) -> MaybeT App Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< App (Maybe Value) -> MaybeT App (Maybe Value)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
obj String
old)
    App Value -> MaybeT App Value
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> Value -> App Value
forall a. (HasCallStack, MakesValue a) => String -> a -> App Value
removeField String
old Value
obj App Value -> (Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Value -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
new Value
o)

-- | like 'lookupField' but wrapped in 'MaybeT' for convenience
lookupFieldM ::
  (HasCallStack, MakesValue a) =>
  a ->
  -- | A plain key, e.g. "id", or a nested key "user.profile.id"
  String ->
  MaybeT App Value
lookupFieldM :: forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM = (App (Maybe Value) -> MaybeT App Value)
-> (String -> App (Maybe Value)) -> String -> MaybeT App Value
forall a b. (a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap App (Maybe Value) -> MaybeT App Value
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((String -> App (Maybe Value)) -> String -> MaybeT App Value)
-> (a -> String -> App (Maybe Value))
-> a
-> String
-> MaybeT App Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField

-- | Look up (nested) field of a JSON object
--
-- If the field key has no dots then returns Nothing if the key is missing from the
-- object.
--
-- If the field key has dots (describes a nested lookuyp) then returns Nothing
-- if the last component of the key field selector is missing from nested
-- object. If any other component is missing this function raises an
-- AssertionFailure.
--
-- Objects and arrays are supported. Array keys should be integers.
lookupField ::
  (HasCallStack, MakesValue a) =>
  a ->
  -- | A plain key, e.g. "id", or a nested key "user.profile.id"
  String ->
  App (Maybe Value)
lookupField :: forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField a
val String
selector = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
val
  String
vp <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
v
  String -> App (Maybe Value) -> App (Maybe Value)
forall a. String -> App a -> App a
addFailureContext (String
"Loooking up (nested) field " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
selector String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of object:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
vp) (App (Maybe Value) -> App (Maybe Value))
-> App (Maybe Value) -> App (Maybe Value)
forall a b. (a -> b) -> a -> b
$ do
    let keys :: [String]
keys = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
selector
    case [String]
keys of
      (String
k : [String]
ks) -> String -> [String] -> Value -> App (Maybe Value)
go String
k [String]
ks Value
v
      [] -> String -> App (Maybe Value)
forall a. HasCallStack => String -> App a
assertFailure String
"No key provided"
  where
    get :: a -> String -> App (Maybe Value)
get a
v String
k = do
      a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
v App Value -> (Value -> App (Maybe Value)) -> App (Maybe Value)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- index object
        Object Object
ob -> Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (String -> Key
KM.fromString String
k) Object
ob)
        -- index array
        Array Array
arr -> case ReadS Int
forall a. Read a => ReadS a
reads String
k of
          [(Int
i, String
"")] ->
            if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
              then Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array
arr Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
!? Int
i)
              else Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array
arr Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
!? (Array -> Int
forall a. Vector a -> Int
V.length Array
arr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i))
          [(Int, String)]
_ -> Array -> String -> App (Maybe Value)
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON Array
arr (String -> App (Maybe Value)) -> String -> App (Maybe Value)
forall a b. (a -> b) -> a -> b
$ String
"Invalid array index \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""
        Value
x -> Value -> String -> App (Maybe Value)
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON Value
x (String
"Object or Array" String -> Value -> String
`typeWasExpectedButGot` Value
x)
    go :: String -> [String] -> Value -> App (Maybe Value)
go String
k [] Value
v = Value -> String -> App (Maybe Value)
forall {a}. MakesValue a => a -> String -> App (Maybe Value)
get Value
v String
k
    go String
k (String
k2 : [String]
ks) Value
v = Value -> String -> App (Maybe Value)
forall {a}. MakesValue a => a -> String -> App (Maybe Value)
get Value
v String
k App (Maybe Value) -> (Maybe Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> String -> Maybe Value -> App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> Maybe Value -> App Value
assertField Value
v String
k App Value -> (Value -> App (Maybe Value)) -> App (Maybe Value)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [String] -> Value -> App (Maybe Value)
go String
k2 [String]
ks

-- | Update nested fields
-- E.g. ob & "foo.bar.baz" %.= ("quux" :: String)
-- The selector path will be created if non-existing.
setField ::
  forall a b.
  (HasCallStack, MakesValue a, ToJSON b) =>
  -- | Selector, e.g. "id", "user.team.id"
  String ->
  -- | The value that should insert or replace the value at the selector
  b ->
  a ->
  App Value
setField :: forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
selector b
v a
x = do
  forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> (Maybe Value -> App b) -> a -> App Value
modifyField @a @Value String
selector (\Maybe Value
_ -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Value
forall a. ToJSON a => a -> Value
toJSON b
v)) a
x

-- | Merges fields if the old and new are both Objects or Arrays. Otherwise new
-- field overwrites the old completely
mergeField :: forall a b. (HasCallStack, MakesValue a, ToJSON b) => String -> b -> a -> App Value
mergeField :: forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
mergeField String
selector b
v a
x = do
  forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> (Maybe Value -> App b) -> a -> App Value
modifyField @a @Value
    String
selector
    ( \case
        Just (Object Object
old) -> case b -> Value
forall a. ToJSON a => a -> Value
toJSON b
v of
          (Object Object
new) -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object
new Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
old)
          Value
nonObjectNew -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
nonObjectNew
        Just (Array Array
old) -> case b -> Value
forall a. ToJSON a => a -> Value
toJSON b
v of
          (Array Array
new) -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Array -> Value
Array (Array
old Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
new)
          Value
nonArrayNew -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
nonArrayNew
        Maybe Value
_ -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Value
forall a. ToJSON a => a -> Value
toJSON b
v)
    )
    a
x

member :: (HasCallStack, MakesValue a) => String -> a -> App Bool
member :: forall a. (HasCallStack, MakesValue a) => String -> a -> App Bool
member String
k a
x = Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
KM.member (String -> Key
KM.fromString String
k) (Object -> Bool) -> App Object -> App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> App Object) -> App Object
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App Object
forall a. (HasCallStack, MakesValue a) => a -> App Object
asObject)

-- | Update nested fields, using the old value with a stateful action
-- The selector path will be created if non-existing.
modifyField :: (HasCallStack, MakesValue a, ToJSON b) => String -> (Maybe Value -> App b) -> a -> App Value
modifyField :: forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> (Maybe Value -> App b) -> a -> App Value
modifyField String
selector Maybe Value -> App b
up a
x = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x
  let keys :: [String]
keys = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
selector
  case [String]
keys of
    (String
k : [String]
ks) -> String -> [String] -> Value -> App Value
go String
k [String]
ks Value
v
    [] -> String -> App Value
forall a. HasCallStack => String -> App a
assertFailure String
"No key provided"
  where
    go :: String -> [String] -> Value -> App Value
go String
k [] Value
v = do
      Object
ob <- Value -> App Object
forall a. (HasCallStack, MakesValue a) => a -> App Object
asObject Value
v
      let k' :: Key
k' = String -> Key
KM.fromString String
k
      Value
newValue <- b -> Value
forall a. ToJSON a => a -> Value
toJSON (b -> Value) -> App b -> App Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value -> App b
up (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
k' Object
ob)
      Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
k' Value
newValue Object
ob
    go String
k (String
k2 : [String]
ks) Value
v = do
      Value
val <- Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
forall v. KeyMap v
KM.empty) (Maybe Value -> Value) -> App (Maybe Value) -> App Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
v String
k
      Value
newValue <- String -> [String] -> Value -> App Value
go String
k2 [String]
ks Value
val
      Object
ob <- Value -> App Object
forall a. (HasCallStack, MakesValue a) => a -> App Object
asObject Value
v
      Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (String -> Key
KM.fromString String
k) Value
newValue Object
ob

-- | `removeField "a.b" {"a": {"b": 3}, "c": true} == {"a": {}, "c": true}`
removeField :: (HasCallStack, MakesValue a) => String -> a -> App Value
removeField :: forall a. (HasCallStack, MakesValue a) => String -> a -> App Value
removeField String
selector a
x = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x
  let keys :: [String]
keys = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
selector
  case [String]
keys of
    (String
k : [String]
ks) -> String -> [String] -> Value -> App Value
go String
k [String]
ks Value
v
    [] -> String -> App Value
forall a. HasCallStack => String -> App a
assertFailure String
"No key provided"
  where
    go :: String -> [String] -> Value -> App Value
go String
k [] Value
v = do
      Object
ob <- Value -> App Object
forall a. (HasCallStack, MakesValue a) => a -> App Object
asObject Value
v
      let k' :: Key
k' = String -> Key
KM.fromString String
k
      Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KM.delete Key
k' Object
ob
    go String
k (String
k2 : [String]
ks) Value
v = do
      Value
v' <- Value
v Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
k
      Value
newValue <- String -> [String] -> Value -> App Value
go String
k2 [String]
ks Value
v'
      Object
ob <- Value -> App Object
forall a. (HasCallStack, MakesValue a) => a -> App Object
asObject Value
v
      Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (String -> Key
KM.fromString String
k) Value
newValue Object
ob

assertFailureWithJSON :: (HasCallStack) => (MakesValue a) => a -> String -> App b
assertFailureWithJSON :: forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
v String
msg = do
  String
msg' <- ((String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> App String
forall a. MakesValue a => a -> App String
prettyJSON a
v
  String -> App b
forall a. HasCallStack => String -> App a
assertFailure String
msg'

-- | Useful for debugging
printJSON :: (MakesValue a) => a -> App ()
printJSON :: forall a. MakesValue a => a -> App ()
printJSON = a -> App String
forall a. MakesValue a => a -> App String
prettyJSON (a -> App String) -> (String -> App ()) -> a -> App ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> (String -> IO ()) -> String -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

-- | useful for debugging, same as 'printJSON' but returns input JSON
traceJSON :: (MakesValue a) => a -> App a
traceJSON :: forall a. MakesValue a => a -> App a
traceJSON a
a = a -> App ()
forall a. MakesValue a => a -> App ()
printJSON a
a App () -> a -> App a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a

prettyJSON :: (MakesValue a) => a -> App String
prettyJSON :: forall a. MakesValue a => a -> App String
prettyJSON a
x =
  a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x App Value -> (Value -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> String
LC8.unpack (ByteString -> String) -> (Value -> ByteString) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty

jsonType :: Value -> String
jsonType :: Value -> String
jsonType (Object Object
_) = String
"Object"
jsonType (Array Array
_) = String
"Array"
jsonType (String Text
_) = String
"String"
jsonType (Number Scientific
_) = String
"Number"
jsonType (Bool Bool
_) = String
"Bool"
jsonType Value
Null = String
"Null"

typeWasExpectedButGot :: String -> Value -> String
typeWasExpectedButGot :: String -> Value -> String
typeWasExpectedButGot String
expectedType Value
x = String
"Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expectedType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
jsonType Value
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"

-- Get "id" field or - if already string-like return String
objId :: (HasCallStack) => (MakesValue a) => a -> App String
objId :: forall a. (HasCallStack, MakesValue a) => a -> App String
objId a
x = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x
  case Value
v of
    Object Object
ob -> Object
ob Object -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
    String Text
t -> String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
t)
    Value
other -> Value -> String -> App String
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON Value
other (String -> Value -> String
typeWasExpectedButGot String
"Object or String" Value
other)

-- Get "qualified_id" field as (domain, id) or - if already is a qualified id object - return that
objQid :: (HasCallStack) => (MakesValue a) => a -> App (String, String)
objQid :: forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid a
ob = do
  Maybe (String, String)
m <- [App (Maybe (String, String))] -> App (Maybe (String, String))
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstSuccess [a -> App (Maybe (String, String))
forall {a}. MakesValue a => a -> App (Maybe (String, String))
select a
ob, App (Maybe (String, String))
inField]
  case Maybe (String, String)
m of
    Maybe (String, String)
Nothing -> do
      a -> String -> App (String, String)
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON a
ob String
"Could not get a qualified id from value:"
    Just (String, String)
v -> (String, String) -> App (String, String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String, String)
v
  where
    select :: a -> App (Maybe (String, String))
select a
x = MaybeT App (String, String) -> App (Maybe (String, String))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App (String, String) -> App (Maybe (String, String)))
-> MaybeT App (String, String) -> App (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ do
      Value
vdom <- a -> String -> MaybeT App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM a
x String
"domain"
      String
dom <- App (Maybe String) -> MaybeT App String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (App (Maybe String) -> MaybeT App String)
-> App (Maybe String) -> MaybeT App String
forall a b. (a -> b) -> a -> b
$ Value -> App (Maybe String)
forall a. (HasCallStack, MakesValue a) => a -> App (Maybe String)
asStringM Value
vdom
      Value
vid <- a -> String -> MaybeT App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM a
x String
"id"
      String
id_ <- App (Maybe String) -> MaybeT App String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (App (Maybe String) -> MaybeT App String)
-> App (Maybe String) -> MaybeT App String
forall a b. (a -> b) -> a -> b
$ Value -> App (Maybe String)
forall a. (HasCallStack, MakesValue a) => a -> App (Maybe String)
asStringM Value
vid
      (String, String) -> MaybeT App (String, String)
forall a. a -> MaybeT App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
dom, String
id_)

    inField :: App (Maybe (String, String))
inField = do
      Maybe Value
m <- a -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField a
ob String
"qualified_id"
      case Maybe Value
m of
        Maybe Value
Nothing -> Maybe (String, String) -> App (Maybe (String, String))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (String, String)
forall a. Maybe a
Nothing
        Just Value
x -> Value -> App (Maybe (String, String))
forall {a}. MakesValue a => a -> App (Maybe (String, String))
select Value
x

    firstSuccess :: (Monad m) => [m (Maybe a)] -> m (Maybe a)
    firstSuccess :: forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstSuccess [] = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    firstSuccess (m (Maybe a)
x : [m (Maybe a)]
xs) =
      m (Maybe a)
x m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe a
Nothing -> [m (Maybe a)] -> m (Maybe a)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstSuccess [m (Maybe a)]
xs
        Just a
y -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
y)

-- | Get "qualified_id" field as {"id": _, "domain": _} object or - if already is a qualified id object - return that.
objQidObject :: (HasCallStack) => (MakesValue a) => a -> App Value
objQidObject :: forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject a
o = do
  (String
domain, String
id_) <- a -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid a
o
  Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [String
"domain" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
domain, String
"id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
id_]

-- Get "domain" field or - if already string-like - return String.
objDomain :: (HasCallStack, MakesValue a) => a -> App String
objDomain :: forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain a
x = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x
  case Value
v of
    Object Object
_ob -> (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> App (String, String) -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid Value
v
    String Text
t -> String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
t)
    Value
other -> Value -> String -> App String
forall a b. (HasCallStack, MakesValue a) => a -> String -> App b
assertFailureWithJSON Value
other (String -> Value -> String
typeWasExpectedButGot String
"Object or String" Value
other)

-- | Get conversation ID and optional subconversation ID.
--
-- This accepts subconversation objects in the format:
-- @
-- { "parent_qualified_id": {
--      "domain": "example.com",
--      "id": "7b6c21d1-322d-4be6-a923-85225691f398"
--   },
--   "subconv_id": "conference"
-- }
-- @
--
-- as well as conversation objects in the general format supported by 'objQid'.
-- Conversation objects can optionally contain a @subconv_id@ field. So, in
-- particular, a flat subconversation format, like
-- @
-- { "domain": "example.com",
--   "id": "7b6c21d1-322d-4be6-a923-85225691f398",
--   "subconv_id": "conference"
-- }
-- @
-- is also supported.
objSubConv :: (HasCallStack, MakesValue a) => a -> App (Value, Maybe String)
objSubConv :: forall a.
(HasCallStack, MakesValue a) =>
a -> App (Value, Maybe String)
objSubConv a
x = do
  Value
v <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
x
  Maybe Value
mParent <- Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
v String
"parent_qualified_id"
  Value
obj <- Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
v Maybe Value
mParent
  Maybe String
sub <- MaybeT App String -> App (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App String -> App (Maybe String))
-> MaybeT App String -> App (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
    Value
sub <- App (Maybe Value) -> MaybeT App Value
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (App (Maybe Value) -> MaybeT App Value)
-> App (Maybe Value) -> MaybeT App Value
forall a b. (a -> b) -> a -> b
$ Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
v String
"subconv_id"
    Value
sub' <- App (Maybe Value) -> MaybeT App Value
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (App (Maybe Value) -> MaybeT App Value)
-> App (Maybe Value) -> MaybeT App Value
forall a b. (a -> b) -> a -> b
$ Value -> App (Maybe Value)
forall a. (HasCallStack, MakesValue a) => a -> App (Maybe Value)
asOptional Value
sub
    App String -> MaybeT App String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App String -> MaybeT App String)
-> App String -> MaybeT App String
forall a b. (a -> b) -> a -> b
$ Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString Value
sub'
  (Value, Maybe String) -> App (Value, Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
obj, Maybe String
sub)

objConvId :: (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId :: forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId conv
conv = do
  Value
v <- conv -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make conv
conv
  -- Domain and ConvId either come from parent_qualified_id or qualified_id
  Maybe Value
mParent <- Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
v String
"parent_qualified_id"
  (String
domain, String
id_) <- Value -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid (Value -> App (String, String)) -> Value -> App (String, String)
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
v Maybe Value
mParent

  Maybe String
groupId <- (Value -> App String) -> Maybe Value -> App (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (Maybe Value -> App (Maybe String))
-> App (Maybe Value) -> App (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< App (Maybe Value) -> App (Maybe Value)
forall a. (HasCallStack, MakesValue a) => a -> App (Maybe Value)
asOptional (Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
v String
"group_id")
  Maybe String
subconvId <- (Value -> App String) -> Maybe Value -> App (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (Maybe Value -> App (Maybe String))
-> App (Maybe Value) -> App (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< App (Maybe Value) -> App (Maybe Value)
forall a. (HasCallStack, MakesValue a) => a -> App (Maybe Value)
asOptional (Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
v String
"subconv_id")
  ConvId -> App ConvId
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConvId {String
Maybe String
domain :: String
id_ :: String
groupId :: Maybe String
subconvId :: Maybe String
$sel:domain:ConvId :: String
$sel:id_:ConvId :: String
$sel:groupId:ConvId :: Maybe String
$sel:subconvId:ConvId :: Maybe String
..}

instance MakesValue ClientIdentity where
  make :: HasCallStack => ClientIdentity -> App Value
make ClientIdentity
cid =
    Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$
      [Pair] -> Value
object
        [ String
"domain" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ClientIdentity
cid.domain,
          String
"id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ClientIdentity
cid.user,
          String
"client_id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ClientIdentity
cid.client
        ]

instance MakesValue CredentialType where
  make :: HasCallStack => CredentialType -> App Value
make CredentialType
BasicCredentialType = String -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make String
"basic"
  make CredentialType
X509CredentialType = String -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make String
"x509"