Decode.hs

{-# LANGUAGE UndecidableInstances #-}

-- | Type-safe decoding of query result records.
--
-- Instead of manually pattern-matching on 'Bolt' values, build composable
-- 'Decode' and 'RowDecoder' values that validate types at extraction time.
--
-- @
-- import Database.Bolty.Decode
--
-- data Person = Person { pName :: Text, pAge :: Int64 }
--
-- personDecoder :: 'RowDecoder' Person
-- personDecoder = Person
--   \<$\> 'field' \"name\" 'text'
--   \<*\> 'field' \"age\"  'int64'
-- @
module Database.Bolty.Decode
  ( DecodeError(..)
  , Decode(..)
  , RowDecoder(..)
  , FromBolt(..)
  , ToBolt(..)
    -- * Primitive decoders
  , bool, int, int64, float, text, bytes, nullable, list, dict
    -- * UUID decoder
  , uuid
    -- * Time decoders
  , utcTime, day, timeOfDay
    -- * Aeson decoder
  , aesonValue
    -- * Node property decoders
  , nodeProperty, nodePropertyOptional, nodeLabels, nodeProperties
    -- * PackStream interop
  , psDecode
    -- * Graph type decoders
  , node, relationship, path
    -- * Record-level decoders
  , column, field
    -- * Running decoders
  , decodeRow, decodeRows
    -- * Internal converters (exported for testing)
  , psToBolt, boltToPs
  ) where

import           Data.Kind               (Constraint, Type)
import           Control.Exception       (Exception)
import           TextShow                (TextShow(..), fromText)
import           Data.Int                (Int64)
import qualified Data.Aeson              as Aeson
import qualified Data.ByteString         as BS
import qualified Data.HashMap.Lazy       as H
import qualified Data.Text               as T
import qualified Data.UUID.Types         as UUID
import qualified Data.Vector             as V
import           Data.Aeson               (ToJSON(..))
import           Data.Time.Calendar.OrdinalDate (Day)
import           Data.Time.Clock         (UTCTime)
import           Data.Time.Clock.POSIX   (posixSecondsToUTCTime)
import           Data.Time.Format.ISO8601 (iso8601ParseM)
import           Data.Time.LocalTime     (TimeOfDay)


import           Data.PackStream.Integer (PSInteger, fromPSInteger)
import           Data.PackStream.Ps      (Ps(..), PackStream(..))
import           Data.PackStream.Result  (Result(..))
import           Database.Bolty.Value.Type
import           Database.Bolty.Value.Helpers (sigNode, sigRel, sigURel, sigPath
                                              , sigDate, sigTime, sigLocalTime, sigDateTime
                                              , sigDateTimeZoneId, sigLocalDateTime, sigDuration
                                              , sigPoint2D, sigPoint3D)
import           Database.Bolty.Record   (Record)


-- | Errors that can occur when decoding a 'Bolt' value or record row.
type DecodeError :: Type
data DecodeError
  = TypeMismatch T.Text T.Text
  -- ^ The value had a different type than expected (expected, got).
  | MissingField T.Text
  -- ^ A named field was not present in the column list.
  | IndexOutOfBounds Int Int
  -- ^ Column index was out of range (requested index, actual length).
  | EmptyResultSet
  -- ^ The result set contained no records.
  deriving stock (Show, Eq)

instance Exception DecodeError

instance TextShow DecodeError where
  showb (TypeMismatch e g) = "TypeMismatch {expected = \"" <> fromText e <> "\", got = \"" <> fromText g <> "\"}"
  showb (MissingField f)   = "MissingField \"" <> fromText f <> "\""
  showb (IndexOutOfBounds i l) = "IndexOutOfBounds " <> showb i <> " " <> showb l
  showb EmptyResultSet     = "EmptyResultSet"


-- | A decoder for a single 'Bolt' value.
type Decode :: Type -> Type
type role Decode representational
newtype Decode a = Decode { runDecode :: Bolt -> Either DecodeError a }

instance Functor Decode where
  fmap f (Decode g) = Decode (fmap f . g)

instance Applicative Decode where
  pure a = Decode (\_ -> Right a)
  Decode f <*> Decode a = Decode $ \b -> f b <*> a b

instance Monad Decode where
  Decode m >>= k = Decode $ \b -> do
    a <- m b
    runDecode (k a) b


-- | Helper to build a decoder from an extractor function.
fromExtractor :: T.Text -> (Bolt -> Maybe a) -> Decode a
fromExtractor name extract = Decode $ \b ->
  case extract b of
    Just a  -> Right a
    Nothing -> Left $ TypeMismatch name (boltTypeName b)

boltTypeName :: Bolt -> T.Text
boltTypeName BoltNull               = "Null"
boltTypeName (BoltBoolean _)        = "Boolean"
boltTypeName (BoltInteger _)        = "Integer"
boltTypeName (BoltFloat _)          = "Float"
boltTypeName (BoltBytes _)          = "Bytes"
boltTypeName (BoltString _)         = "String"
boltTypeName (BoltList _)           = "List"
boltTypeName (BoltDictionary _)     = "Dictionary"
boltTypeName (BoltNode _)           = "Node"
boltTypeName (BoltRelationship _)   = "Relationship"
boltTypeName (BoltUnboundRelationship _) = "UnboundRelationship"
boltTypeName (BoltPath _)           = "Path"
boltTypeName (BoltDate _)           = "Date"
boltTypeName (BoltTime _)           = "Time"
boltTypeName (BoltLocalTime _)      = "LocalTime"
boltTypeName (BoltDateTime _)       = "DateTime"
boltTypeName (BoltDateTimeZoneId _) = "DateTimeZoneId"
boltTypeName (BoltLocalDateTime _)  = "LocalDateTime"
boltTypeName (BoltDuration _)       = "Duration"
boltTypeName (BoltPoint2D _)        = "Point2D"
boltTypeName (BoltPoint3D _)        = "Point3D"


-- * Primitive decoders

-- | Decode a 'BoltBoolean'.
bool :: Decode Bool
bool = fromExtractor "Boolean" asBool

-- | Decode a 'BoltInteger' as a 'PSInteger'.
int :: Decode PSInteger
int = fromExtractor "Integer" asInt

-- | Decode a 'BoltInteger' narrowed to 'Int64'. Fails if the value is out of range.
int64 :: Decode Int64
int64 = Decode $ \b -> case asInt b of
  Just n  -> case fromPSInteger n of
    Just i  -> Right i
    Nothing -> Left $ TypeMismatch "Int64" "Integer (out of range)"
  Nothing -> Left $ TypeMismatch "Integer" (boltTypeName b)

-- | Decode a 'BoltFloat'.
float :: Decode Double
float = fromExtractor "Float" asFloat

-- | Decode a 'BoltString'.
text :: Decode T.Text
text = fromExtractor "String" asText

-- | Decode a 'BoltBytes'.
bytes :: Decode BS.ByteString
bytes = fromExtractor "Bytes" asBytes

-- | Make a decoder nullable: returns 'Nothing' for 'BoltNull', otherwise applies the inner decoder.
nullable :: Decode a -> Decode (Maybe a)
nullable (Decode f) = Decode $ \b -> case b of
  BoltNull -> Right Nothing
  _        -> Just <$> f b

-- | Decode a 'BoltList', applying the element decoder to each item.
list :: Decode a -> Decode (V.Vector a)
list (Decode f) = Decode $ \b -> case b of
  BoltList v -> traverse f v
  _          -> Left $ TypeMismatch "List" (boltTypeName b)

-- | Decode a 'BoltDictionary'.
dict :: Decode (H.HashMap T.Text Bolt)
dict = fromExtractor "Dictionary" asDict


-- * UUID decoder

-- | Decode a UUID from a 'BoltString'.
uuid :: Decode UUID.UUID
uuid = Decode $ \b -> case b of
  BoltString t -> case UUID.fromText t of
    Just u  -> Right u
    Nothing -> Left $ TypeMismatch "UUID" ("String (invalid UUID: " <> t <> ")")
  _ -> Left $ TypeMismatch "UUID (String)" (boltTypeName b)


-- * Time decoders

-- | Decode a 'UTCTime' from a 'BoltString' (ISO 8601) or 'BoltDateTime'.
utcTime :: Decode UTCTime
utcTime = Decode $ \b -> case b of
  BoltString t -> case iso8601ParseM (T.unpack t) of
    Just u  -> Right u
    Nothing -> Left $ TypeMismatch "UTCTime" ("String (invalid ISO8601: " <> t <> ")")
  BoltDateTime dt ->
    Right $ posixSecondsToUTCTime $ fromIntegral dt.seconds
  BoltDateTimeZoneId dt ->
    Right $ posixSecondsToUTCTime $ fromIntegral dt.seconds
  BoltLocalDateTime dt ->
    Right $ posixSecondsToUTCTime $ fromIntegral dt.seconds
  _ -> Left $ TypeMismatch "UTCTime (String/DateTime)" (boltTypeName b)

-- | Decode a 'Day' from a 'BoltString' (ISO 8601).
day :: Decode Day
day = Decode $ \b -> case b of
  BoltString t -> case iso8601ParseM (T.unpack t) of
    Just d  -> Right d
    Nothing -> Left $ TypeMismatch "Day" ("String (invalid ISO8601: " <> t <> ")")
  _ -> Left $ TypeMismatch "Day (String)" (boltTypeName b)

-- | Decode a 'TimeOfDay' from a 'BoltString' (ISO 8601).
timeOfDay :: Decode TimeOfDay
timeOfDay = Decode $ \b -> case b of
  BoltString t -> case iso8601ParseM (T.unpack t) of
    Just v  -> Right v
    Nothing -> Left $ TypeMismatch "TimeOfDay" ("String (invalid ISO8601: " <> t <> ")")
  _ -> Left $ TypeMismatch "TimeOfDay (String)" (boltTypeName b)


-- * Aeson decoder

-- | Decode any Bolt value to an 'Aeson.Value'.
--
-- Uses the 'ToJSON' instance on 'Bolt', which handles all constructors
-- including graph types, temporal types, and spatial types.
aesonValue :: Decode Aeson.Value
aesonValue = Decode (Right . toJSON)


-- * Node property decoders

-- | Extract a property from a 'BoltNode' by key and decode it.
nodeProperty :: T.Text -> Decode a -> Decode a
nodeProperty key (Decode f) = Decode $ \b -> case b of
  BoltNode n -> case H.lookup key n.properties of
    Just ps -> f (psToBolt ps)
    Nothing -> Left $ MissingField key
  _ -> Left $ TypeMismatch "Node" (boltTypeName b)

-- | Extract a property from a 'BoltNode' by key, returning 'Nothing' if the key is missing.
nodePropertyOptional :: T.Text -> Decode a -> Decode (Maybe a)
nodePropertyOptional key (Decode f) = Decode $ \b -> case b of
  BoltNode n -> case H.lookup key n.properties of
    Just ps -> Just <$> f (psToBolt ps)
    Nothing -> Right Nothing
  _ -> Left $ TypeMismatch "Node" (boltTypeName b)

-- | Extract labels from a 'BoltNode'.
nodeLabels :: Decode (V.Vector T.Text)
nodeLabels = Decode $ \b -> case b of
  BoltNode n -> Right n.labels
  _ -> Left $ TypeMismatch "Node" (boltTypeName b)

-- | Extract the raw properties HashMap from a 'BoltNode'.
nodeProperties :: Decode (H.HashMap T.Text Ps)
nodeProperties = Decode $ \b -> case b of
  BoltNode n -> Right n.properties
  _ -> Left $ TypeMismatch "Node" (boltTypeName b)


-- * PackStream interop

-- | Decode via the PackStream 'fromPs' roundtrip through a node property's Ps value.
-- Useful for types that already have PackStream instances.
psDecode :: PackStream a => Decode a
psDecode = Decode $ \b -> case fromPs (boltToPs b) of
  Success v -> Right v
  Error e   -> Left $ TypeMismatch "PackStream" e


-- * Graph type decoders

-- | Decode a 'BoltNode'.
node :: Decode Node
node = fromExtractor "Node" asNode

-- | Decode a 'BoltRelationship'.
relationship :: Decode Relationship
relationship = fromExtractor "Relationship" asRelationship

-- | Decode a 'BoltPath'.
path :: Decode Path
path = fromExtractor "Path" asPath


-- * Record-level decoders

-- | A decoder for a full result row. Compose with 'Applicative' to decode multiple columns.
type RowDecoder :: Type -> Type
type role RowDecoder representational
newtype RowDecoder a = RowDecoder
  { runRowDecoder :: V.Vector T.Text -> Record -> Either DecodeError a }

instance Functor RowDecoder where
  fmap f (RowDecoder g) = RowDecoder $ \cols rec -> f <$> g cols rec

instance Applicative RowDecoder where
  pure a = RowDecoder $ \_ _ -> Right a
  RowDecoder f <*> RowDecoder a = RowDecoder $ \cols rec ->
    f cols rec <*> a cols rec


-- | Types that can be decoded from a result row without an explicit decoder.
--
-- Implement this for your application types to use 'Database.Bolty.query'
-- without passing a 'RowDecoder' explicitly:
--
-- @
-- data Person = Person { name :: Text, age :: Int64 }
--
-- instance FromBolt Person where
--   rowDecoder = Person \<$\> field \"name\" text \<*\> field \"age\" int64
-- @
type FromBolt :: Type -> Constraint
class FromBolt a where
  rowDecoder :: RowDecoder a


-- | Types that can be encoded to a 'Ps' value for use as query parameters.
-- All 'PackStream' instances are automatically 'ToBolt' instances.
type ToBolt :: Type -> Constraint
class ToBolt a where
  toBolt :: a -> Ps

instance PackStream a => ToBolt a where
  toBolt = toPs


-- | Decode a value at a positional column index.
column :: Int -> Decode a -> RowDecoder a
column idx (Decode f) = RowDecoder $ \_ rec ->
  let len = V.length rec
  in if idx < 0 || idx >= len
     then Left $ IndexOutOfBounds idx len
     else f (rec V.! idx)

-- | Decode a value by column name.
field :: T.Text -> Decode a -> RowDecoder a
field name (Decode f) = RowDecoder $ \cols rec ->
  case V.elemIndex name cols of
    Nothing  -> Left $ MissingField name
    Just idx -> f (rec V.! idx)


-- * Running decoders

-- | Decode a single record row.
decodeRow :: RowDecoder a -> V.Vector T.Text -> Record -> Either DecodeError a
decodeRow (RowDecoder f) = f

-- | Decode all records in a result set. Fails on the first 'DecodeError'.
decodeRows :: RowDecoder a -> V.Vector T.Text -> V.Vector Record -> Either DecodeError (V.Vector a)
decodeRows decoder cols = traverse (decodeRow decoder cols)


-- * Internal helpers

-- | Convert a Ps value to a Bolt value.
psToBolt :: Ps -> Bolt
psToBolt PsNull           = BoltNull
psToBolt (PsBoolean b)    = BoltBoolean b
psToBolt (PsInteger n)    = BoltInteger n
psToBolt (PsFloat d)      = BoltFloat d
psToBolt (PsString t)     = BoltString t
psToBolt (PsBytes b)      = BoltBytes b
psToBolt (PsList v)       = BoltList $ V.map psToBolt v
psToBolt (PsDictionary m) = BoltDictionary $ H.map psToBolt m
psToBolt ps@(PsStructure t _)
  | t == sigNode           = tryFromPs BoltNode ps
  | t == sigRel            = tryFromPs BoltRelationship ps
  | t == sigURel           = tryFromPs BoltUnboundRelationship ps
  | t == sigPath           = tryFromPs BoltPath ps
  | t == sigDate           = tryFromPs BoltDate ps
  | t == sigTime           = tryFromPs BoltTime ps
  | t == sigLocalTime      = tryFromPs BoltLocalTime ps
  | t == sigDateTime       = tryFromPs BoltDateTime ps
  | t == sigDateTimeZoneId = tryFromPs BoltDateTimeZoneId ps
  | t == sigLocalDateTime  = tryFromPs BoltLocalDateTime ps
  | t == sigDuration       = tryFromPs BoltDuration ps
  | t == sigPoint2D        = tryFromPs BoltPoint2D ps
  | t == sigPoint3D        = tryFromPs BoltPoint3D ps
  | otherwise              = BoltNull
  where
    tryFromPs :: PackStream a => (a -> Bolt) -> Ps -> Bolt
    tryFromPs wrap p = case fromPs p of
      Success v -> wrap v
      _         -> BoltNull

-- | Convert a Bolt value to a Ps value.
boltToPs :: Bolt -> Ps
boltToPs BoltNull           = PsNull
boltToPs (BoltBoolean b)    = PsBoolean b
boltToPs (BoltInteger n)    = PsInteger n
boltToPs (BoltFloat d)      = PsFloat d
boltToPs (BoltString t)     = PsString t
boltToPs (BoltBytes b)      = PsBytes b
boltToPs (BoltList v)       = PsList $ V.map boltToPs v
boltToPs (BoltDictionary m) = PsDictionary $ H.map boltToPs m
boltToPs (BoltNode n)                = toPs n
boltToPs (BoltRelationship r)        = toPs r
boltToPs (BoltUnboundRelationship r) = toPs r
boltToPs (BoltPath p)                = toPs p
boltToPs (BoltDate d)                = toPs d
boltToPs (BoltTime t)                = toPs t
boltToPs (BoltLocalTime t)           = toPs t
boltToPs (BoltDateTime dt)           = toPs dt
boltToPs (BoltDateTimeZoneId dt)     = toPs dt
boltToPs (BoltLocalDateTime dt)      = toPs dt
boltToPs (BoltDuration d)            = toPs d
boltToPs (BoltPoint2D p)             = toPs p
boltToPs (BoltPoint3D p)             = toPs p