{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Jordan.Servant.Query.Render where

import Data.Bifunctor
import qualified Data.ByteString as BS
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Builder.Scientific
import Data.ByteString.Lazy (toStrict)
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Void
import Jordan.ToJSON.Builder
import Jordan.ToJSON.Class
import Network.HTTP.Types.URI

newtype QueryRender a = QueryRender {QueryRender a -> a -> Query
runQueryRender :: a -> Query}
  deriving (b -> QueryRender a -> QueryRender a
NonEmpty (QueryRender a) -> QueryRender a
QueryRender a -> QueryRender a -> QueryRender a
(QueryRender a -> QueryRender a -> QueryRender a)
-> (NonEmpty (QueryRender a) -> QueryRender a)
-> (forall b. Integral b => b -> QueryRender a -> QueryRender a)
-> Semigroup (QueryRender a)
forall b. Integral b => b -> QueryRender a -> QueryRender a
forall a. NonEmpty (QueryRender a) -> QueryRender a
forall a. QueryRender a -> QueryRender a -> QueryRender a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> QueryRender a -> QueryRender a
stimes :: b -> QueryRender a -> QueryRender a
$cstimes :: forall a b. Integral b => b -> QueryRender a -> QueryRender a
sconcat :: NonEmpty (QueryRender a) -> QueryRender a
$csconcat :: forall a. NonEmpty (QueryRender a) -> QueryRender a
<> :: QueryRender a -> QueryRender a -> QueryRender a
$c<> :: forall a. QueryRender a -> QueryRender a -> QueryRender a
Semigroup, Semigroup (QueryRender a)
QueryRender a
Semigroup (QueryRender a)
-> QueryRender a
-> (QueryRender a -> QueryRender a -> QueryRender a)
-> ([QueryRender a] -> QueryRender a)
-> Monoid (QueryRender a)
[QueryRender a] -> QueryRender a
QueryRender a -> QueryRender a -> QueryRender a
forall a. Semigroup (QueryRender a)
forall a. QueryRender a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [QueryRender a] -> QueryRender a
forall a. QueryRender a -> QueryRender a -> QueryRender a
mconcat :: [QueryRender a] -> QueryRender a
$cmconcat :: forall a. [QueryRender a] -> QueryRender a
mappend :: QueryRender a -> QueryRender a -> QueryRender a
$cmappend :: forall a. QueryRender a -> QueryRender a -> QueryRender a
mempty :: QueryRender a
$cmempty :: forall a. QueryRender a
$cp1Monoid :: forall a. Semigroup (QueryRender a)
Monoid) via (a -> Query)

instance Contravariant QueryRender where
  contramap :: (a -> b) -> QueryRender b -> QueryRender a
contramap a -> b
f (QueryRender b -> Query
a) = (a -> Query) -> QueryRender a
forall a. (a -> Query) -> QueryRender a
QueryRender ((a -> Query) -> QueryRender a) -> (a -> Query) -> QueryRender a
forall a b. (a -> b) -> a -> b
$ b -> Query
a (b -> Query) -> (a -> b) -> a -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance Divisible QueryRender where
  conquer :: QueryRender a
conquer = (a -> Query) -> QueryRender a
forall a. (a -> Query) -> QueryRender a
QueryRender a -> Query
forall a. Monoid a => a
mempty
  divide :: (a -> (b, c)) -> QueryRender b -> QueryRender c -> QueryRender a
divide a -> (b, c)
div (QueryRender b -> Query
renderB) (QueryRender c -> Query
renderC) = (a -> Query) -> QueryRender a
forall a. (a -> Query) -> QueryRender a
QueryRender ((a -> Query) -> QueryRender a) -> (a -> Query) -> QueryRender a
forall a b. (a -> b) -> a -> b
$ \a
a ->
    let (b
b, c
c) = a -> (b, c)
div a
a in b -> Query
renderB b
b Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> c -> Query
renderC c
c

instance Selectable QueryRender where
  giveUp :: (arg -> Void) -> QueryRender arg
giveUp arg -> Void
f = (arg -> Query) -> QueryRender arg
forall a. (a -> Query) -> QueryRender a
QueryRender ((arg -> Query) -> QueryRender arg)
-> (arg -> Query) -> QueryRender arg
forall a b. (a -> b) -> a -> b
$ Void -> Query
forall a. Void -> a
absurd (Void -> Query) -> (arg -> Void) -> arg -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. arg -> Void
f
  select :: (arg -> Either lhs rhs)
-> QueryRender lhs -> QueryRender rhs -> QueryRender arg
select arg -> Either lhs rhs
sel QueryRender lhs
renderL QueryRender rhs
renderR =
    (arg -> Query) -> QueryRender arg
forall a. (a -> Query) -> QueryRender a
QueryRender ((arg -> Query) -> QueryRender arg)
-> (arg -> Query) -> QueryRender arg
forall a b. (a -> b) -> a -> b
$
      (lhs -> Query) -> (rhs -> Query) -> Either lhs rhs -> Query
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (QueryRender lhs -> lhs -> Query
forall a. QueryRender a -> a -> Query
runQueryRender QueryRender lhs
renderL)
        (QueryRender rhs -> rhs -> Query
forall a. QueryRender a -> a -> Query
runQueryRender QueryRender rhs
renderR)
        (Either lhs rhs -> Query)
-> (arg -> Either lhs rhs) -> arg -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. arg -> Either lhs rhs
sel

escapeBracketComponent :: T.Text -> BS.ByteString
escapeBracketComponent :: Text -> ByteString
escapeBracketComponent Text
text = Bool -> ByteString -> ByteString
urlEncode Bool
False ByteString
encoded
  where
    encoded :: ByteString
encoded = Text -> ByteString
encodeUtf8 Text
text
    backsEscaped :: ByteString
backsEscaped = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\\" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
BS.split Word8
92 ByteString
encoded
    firstEscaped :: ByteString
firstEscaped = case ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"[" ByteString
backsEscaped of
      Maybe ByteString
Nothing -> ByteString
encoded
      Just ByteString
bs -> ByteString
"\\[" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs
    endsEscaped :: ByteString
endsEscaped = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"]]" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
BS.split Word8
93 ByteString
firstEscaped

escapeRawComponent :: T.Text -> BS.ByteString
escapeRawComponent :: Text -> ByteString
escapeRawComponent Text
text = Bool -> ByteString -> ByteString
urlEncode Bool
False ByteString
encoded
  where
    encoded :: ByteString
encoded = Text -> ByteString
encodeUtf8 Text
text

addBracked :: T.Text -> BS.ByteString -> BS.ByteString
addBracked :: Text -> ByteString -> ByteString
addBracked Text
key ByteString
v =
  ByteString
"[" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
escapeBracketComponent Text
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"]" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v

addArray :: BS.ByteString -> BS.ByteString
addArray :: ByteString -> ByteString
addArray ByteString
v =
  ByteString
"[]" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v

instance JSONObjectSerializer QueryRender where
  serializeFieldWith :: Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> QueryRender a
serializeFieldWith Text
name = \(QueryRender f) -> (a -> Query) -> QueryRender a
forall a. (a -> Query) -> QueryRender a
QueryRender ((a -> Query) -> QueryRender a) -> (a -> Query) -> QueryRender a
forall a b. (a -> b) -> a -> b
$ \a
other ->
    ((ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString))
-> Query -> Query
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((ByteString -> ByteString)
 -> (ByteString, Maybe ByteString)
 -> (ByteString, Maybe ByteString))
-> (ByteString -> ByteString)
-> (ByteString, Maybe ByteString)
-> (ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> ByteString
addBracked Text
name) (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ a -> Query
f a
other
  serializeJust :: Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> QueryRender (Maybe a)
serializeJust Text
name forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
qr = (Maybe a -> Query) -> QueryRender (Maybe a)
forall a. (a -> Query) -> QueryRender a
QueryRender ((Maybe a -> Query) -> QueryRender (Maybe a))
-> (Maybe a -> Query) -> QueryRender (Maybe a)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe a
Nothing -> []
    Just a
a -> ((ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString))
-> Query -> Query
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((ByteString -> ByteString)
 -> (ByteString, Maybe ByteString)
 -> (ByteString, Maybe ByteString))
-> (ByteString -> ByteString)
-> (ByteString, Maybe ByteString)
-> (ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> ByteString
addBracked Text
name) (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ QueryRender a -> a -> Query
forall a. QueryRender a -> a -> Query
runQueryRender QueryRender a
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
qr a
a

instance JSONTupleSerializer QueryRender where
  serializeItemWith :: (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> QueryRender a
serializeItemWith = \(QueryRender f) -> (a -> Query) -> QueryRender a
forall a. (a -> Query) -> QueryRender a
QueryRender ((a -> Query) -> QueryRender a) -> (a -> Query) -> QueryRender a
forall a b. (a -> b) -> a -> b
$ \a
other ->
    ((ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString))
-> Query -> Query
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> ByteString
addArray) (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ a -> Query
f a
other

instance JSONSerializer QueryRender where
  serializeObject :: (forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer a)
-> QueryRender a
serializeObject = \forall (objSerializer :: * -> *).
JSONObjectSerializer objSerializer =>
objSerializer a
x -> QueryRender a
forall (objSerializer :: * -> *).
JSONObjectSerializer objSerializer =>
objSerializer a
x
  serializeTuple :: (forall (tupleSerializer :: * -> *).
 JSONTupleSerializer tupleSerializer =>
 tupleSerializer a)
-> QueryRender a
serializeTuple = \forall (tupleSerializer :: * -> *).
JSONTupleSerializer tupleSerializer =>
tupleSerializer a
x -> QueryRender a
forall (tupleSerializer :: * -> *).
JSONTupleSerializer tupleSerializer =>
tupleSerializer a
x
  serializeTextConstant :: Text -> QueryRender a
serializeTextConstant Text
t = (a -> Query) -> QueryRender a
forall a. (a -> Query) -> QueryRender a
QueryRender ((a -> Query) -> QueryRender a) -> (a -> Query) -> QueryRender a
forall a b. (a -> b) -> a -> b
$ Query -> a -> Query
forall a b. a -> b -> a
const [(ByteString
forall a. Monoid a => a
mempty, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
encodeUtf8 Text
t))]
  serializeArray :: QueryRender [a]
serializeArray =
    ([a] -> Query) -> QueryRender [a]
forall a. (a -> Query) -> QueryRender a
QueryRender (([a] -> Query) -> QueryRender [a])
-> ([a] -> Query) -> QueryRender [a]
forall a b. (a -> b) -> a -> b
$
      (a -> Query) -> [a] -> Query
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> Query) -> [a] -> Query) -> (a -> Query) -> [a] -> Query
forall a b. (a -> b) -> a -> b
$ ((ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString))
-> Query -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> ByteString
addArray) (Query -> Query) -> (a -> Query) -> a -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryRender a -> a -> Query
forall a. QueryRender a -> a -> Query
runQueryRender QueryRender a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON
  serializeNumber :: QueryRender Scientific
serializeNumber = (Scientific -> Query) -> QueryRender Scientific
forall a. (a -> Query) -> QueryRender a
QueryRender ((Scientific -> Query) -> QueryRender Scientific)
-> (Scientific -> Query) -> QueryRender Scientific
forall a b. (a -> b) -> a -> b
$ \Scientific
num ->
    [(ByteString
forall a. Monoid a => a
mempty, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Scientific -> Builder
scientificBuilder Scientific
num)]
  serializeNull :: QueryRender any
serializeNull = (any -> Query) -> QueryRender any
forall a. (a -> Query) -> QueryRender a
QueryRender ((any -> Query) -> QueryRender any)
-> (any -> Query) -> QueryRender any
forall a b. (a -> b) -> a -> b
$ Query -> any -> Query
forall a b. a -> b -> a
const [(ByteString
forall a. Monoid a => a
mempty, Maybe ByteString
forall a. Maybe a
Nothing)]
  serializeText :: QueryRender Text
serializeText = (Text -> Query) -> QueryRender Text
forall a. (a -> Query) -> QueryRender a
QueryRender ((Text -> Query) -> QueryRender Text)
-> (Text -> Query) -> QueryRender Text
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    [(ByteString
forall a. Monoid a => a
mempty, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
encodeUtf8 Text
t))]
  serializeBool :: QueryRender Bool
serializeBool = (Bool -> Query) -> QueryRender Bool
forall a. (a -> Query) -> QueryRender a
QueryRender ((Bool -> Query) -> QueryRender Bool)
-> (Bool -> Query) -> QueryRender Bool
forall a b. (a -> b) -> a -> b
$ \Bool
b ->
    (ByteString, Maybe ByteString) -> Query
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (ByteString
forall a. Monoid a => a
mempty, if Bool
b then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"t" else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"f")
  serializeDictionary :: (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> QueryRender (t (Text, a))
serializeDictionary = \(QueryRender renderItem) -> (t (Text, a) -> Query) -> QueryRender (t (Text, a))
forall a. (a -> Query) -> QueryRender a
QueryRender ((t (Text, a) -> Query) -> QueryRender (t (Text, a)))
-> (t (Text, a) -> Query) -> QueryRender (t (Text, a))
forall a b. (a -> b) -> a -> b
$
    ((Text, a) -> Query) -> t (Text, a) -> Query
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((Text, a) -> Query) -> t (Text, a) -> Query)
-> ((Text, a) -> Query) -> t (Text, a) -> Query
forall a b. (a -> b) -> a -> b
$ \(Text
key, a
v) ->
      (ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ByteString -> ByteString
addBracked Text
key) ((ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString))
-> Query -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Query
renderItem a
v

--- | Render a query with a given base key.
renderQueryAtKeyWith ::
  -- | Query renderer to use.
  (forall jsonSerializer. (JSONSerializer jsonSerializer) => jsonSerializer a) ->
  -- | Base key
  T.Text ->
  -- | Value to serialize
  a ->
  -- | Query
  Query
renderQueryAtKeyWith :: (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> Text -> a -> Query
renderQueryAtKeyWith (QueryRender k) Text
key =
  ((ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString))
-> Query -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ByteString
escapeRawComponent Text
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)) (Query -> Query) -> (a -> Query) -> a -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Query
k

-- | Render a query at a given key, using the 'ToJSON' instance, which is what you want most of the time.
renderQueryAtKey :: (ToJSON a) => T.Text -> a -> Query
renderQueryAtKey :: Text -> a -> Query
renderQueryAtKey = (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> Text -> a -> Query
forall a.
(forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> Text -> a -> Query
renderQueryAtKeyWith forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON