{-# LANGUAGE GADTs, OverloadedStrings #-}
module Database.Selda.JSON (JSONBackend (..)) where
import Database.Selda (Text, Col, Inner)
import Database.Selda.Backend
import Database.Selda.Unsafe (sink, sink2)
import Data.Aeson (Value (Null), encode, decode', FromJSON (..), ToJSON (..))
import qualified Data.ByteString.Lazy as BSL (ByteString, fromStrict, toStrict)
import Data.Text.Encoding (encodeUtf8)

class JSONValue a
instance JSONValue Value
instance JSONValue a => JSONValue (Maybe a)

-- | Any backend that supports JSON lookups in queries.
class JSONBackend b where
  -- | Look up the given key in the given JSON column.
  (~>) :: JSONValue a => Col b a -> Col b Text -> Col b (Maybe Value)
  infixl 8 ~>

  -- | Convert the given JSON column to plain text.
  jsonToText :: Col b Value -> Col b Text

instance JSONBackend b => JSONBackend (Inner b) where
  ~> :: forall a.
JSONValue a =>
Col (Inner b) a
-> Col (Inner b) Text -> Col (Inner b) (Maybe Value)
(~>) = forall (f :: * -> * -> *) s a b c.
(f s a -> f s b -> f s c)
-> f (Inner s) a -> f (Inner s) b -> f (Inner s) c
sink2 forall b a.
(JSONBackend b, JSONValue a) =>
Col b a -> Col b Text -> Col b (Maybe Value)
(~>)
  jsonToText :: Col (Inner b) Value -> Col (Inner b) Text
jsonToText = forall (f :: * -> * -> *) s a b.
(f s a -> f s b) -> f (Inner s) a -> f (Inner s) b
sink forall b. JSONBackend b => Col b Value -> Col b Text
jsonToText

decodeError :: Show a => a -> b
decodeError :: forall a b. Show a => a -> b
decodeError a
x = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"fromSql: json column with invalid json: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
x

typeError :: Show a => a -> b
typeError :: forall a b. Show a => a -> b
typeError a
x = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"fromSql: json column with non-text value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
x

textToLazyBS :: Text -> BSL.ByteString
textToLazyBS :: Text -> ByteString
textToLazyBS = ByteString -> ByteString
BSL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

instance SqlType Value where
  mkLit :: Value -> Lit Value
mkLit = forall a1 a. SqlTypeRep -> Lit a1 -> Lit a
LCustom SqlTypeRep
TJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Lit ByteString
LBlob forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
  sqlType :: Proxy Value -> SqlTypeRep
sqlType Proxy Value
_ = SqlTypeRep
TJSON
  defaultValue :: Lit Value
defaultValue = forall a. SqlType a => a -> Lit a
mkLit Value
Null
  fromSql :: SqlValue -> Value
fromSql (SqlBlob ByteString
t)   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. Show a => a -> b
decodeError ByteString
t) forall a. a -> a
id (forall a. FromJSON a => ByteString -> Maybe a
decode' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
t)
  fromSql (SqlString Text
t) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. Show a => a -> b
decodeError Text
t) forall a. a -> a
id (forall a. FromJSON a => ByteString -> Maybe a
decode' forall a b. (a -> b) -> a -> b
$ Text -> ByteString
textToLazyBS Text
t)
  fromSql SqlValue
x             = forall a b. Show a => a -> b
typeError SqlValue
x

instance FromJSON RowID where
  parseJSON :: Value -> Parser RowID
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> RowID
toRowId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON
instance ToJSON RowID where
  toJSON :: RowID -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. RowID -> Int64
fromRowId

instance FromJSON (ID a) where
  parseJSON :: Value -> Parser (ID a)
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Int64 -> ID a
toId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON
instance ToJSON (ID a) where
  toJSON :: ID a -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ID a -> Int64
fromId