{-# 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)
class JSONBackend b where
(~>) :: JSONValue a => Col b a -> Col b Text -> Col b (Maybe Value)
infixl 8 ~>
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