{-# 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
  (~>) = sink2 (~>)
  jsonToText = sink jsonToText

decodeError :: Show a => a -> b
decodeError x = error $ "fromSql: json column with invalid json: " ++ show x

typeError :: Show a => a -> b
typeError x = error $ "fromSql: json column with non-text value: " ++ show x

textToLazyBS :: Text -> BSL.ByteString
textToLazyBS = BSL.fromStrict . encodeUtf8

instance SqlType Value where
  mkLit = LCustom TJSON . LBlob . BSL.toStrict . encode
  sqlType _ = TJSON
  defaultValue = mkLit Null
  fromSql (SqlBlob t)   = maybe (decodeError t) id (decode' $ BSL.fromStrict t)
  fromSql (SqlString t) = maybe (decodeError t) id (decode' $ textToLazyBS t)
  fromSql x             = typeError x

instance FromJSON RowID where
  parseJSON = fmap toRowId . parseJSON
instance ToJSON RowID where
  toJSON = toJSON . fromRowId

instance FromJSON (ID a) where
  parseJSON = fmap toId . parseJSON
instance ToJSON (ID a) where
  toJSON = toJSON . fromId