Row.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.RdsData.Decode.Row
  ( DecodeRow(..)
  , integer
  , int
  , int8
  , int16
  , int32
  , int64
  , bool
  , double
  , string
  , text
  , lazyText
  , word
  , word8
  , word16
  , word32
  , word64
  , bytestring
  , lazyBytestring
  , timeOfDay
  , day
  , utcTime
  , uuid
  , ignore
  , json
  , maybe
  , column
  , decodeRow
  , decodeRows
  ) where

import Control.Monad.Except
import Control.Monad.State
import Data.ByteString (ByteString)
import Data.Functor.Identity
import Data.Int
import Data.RdsData.Decode.Value (DecodeValue)
import Data.RdsData.Types.Value
import Data.Text
import Data.Time
import Data.UUID (UUID)
import Data.Word
import Prelude hiding (maybe)

import qualified Data.Aeson                 as J
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.RdsData.Decode.Value  as DV
import qualified Data.Text                  as T
import qualified Data.Text.Lazy             as LT
import qualified Data.UUID                  as UUID

newtype DecodeRow a = DecodeRow
  { unDecodeRow :: ExceptT Text (StateT [Value] Identity) a
  }
  deriving (Applicative, Functor, Monad, MonadState [Value], MonadError Text)

instance MonadFail DecodeRow where
  fail = DecodeRow . throwError . pack

maybe :: DecodeRow a -> DecodeRow (Maybe a)
maybe r = do
  cs <- get
  case cs of
    ValueOfNull : vs -> do
      put vs
      pure Nothing
    _ -> Just <$> r

decodeRowValue :: ()
  => MonadError Text m
  => DecodeValue a
  -> Value
  -> m a
decodeRowValue decoder v =
  case DV.decodeValue decoder v of
    Right a -> pure a
    Left e -> throwError $ "Failed to decode Value: " <> e

column :: ()
  => DecodeValue a
  -> DecodeRow a
column decoder = do
  cs <- get
  case cs of
    v : vs -> do
      s <- decodeRowValue decoder v
      put vs
      pure s
    [] -> do
      throwError "Expected RdsText, but got no more values in row."

integer :: DecodeRow Integer
integer =
  column DV.integer

int :: DecodeRow Int
int =
  column DV.int

int8 :: DecodeRow Int8
int8 =
  column DV.int8

int16 :: DecodeRow Int16
int16 =
  column DV.int16

int32 :: DecodeRow Int32
int32 =
  column DV.int32

int64 :: DecodeRow Int64
int64 =
  column DV.int64

word :: DecodeRow Word
word =
  column DV.word

word8 :: DecodeRow Word8
word8 =
  column DV.word8

word16 :: DecodeRow Word16
word16 =
  column DV.word16

word32 :: DecodeRow Word32
word32 =
  column DV.word32

word64 :: DecodeRow Word64
word64 =
  column DV.word64

text :: DecodeRow Text
text =
  column DV.text

lazyText :: DecodeRow LT.Text
lazyText =
  column DV.lazyText

bool :: DecodeRow Bool
bool =
  column DV.bool

double :: DecodeRow Double
double =
  column DV.double

bytestring :: DecodeRow ByteString
bytestring =
  column DV.bytestring

lazyBytestring :: DecodeRow LBS.ByteString
lazyBytestring =
  column DV.lazyBytestring

string :: DecodeRow String
string =
  column DV.string

json :: DecodeRow J.Value
json =
  column DV.json

timeOfDay :: DecodeRow TimeOfDay
timeOfDay = do
  t <- text
  case parseTimeM True defaultTimeLocale "%H:%M:%S%Q" (T.unpack t) of
    Just a -> pure a
    Nothing -> throwError $ "Failed to parse TimeOfDay: " <> T.pack (show t)

utcTime :: DecodeRow UTCTime
utcTime = do
  t <- text
  case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack t) of
    Just a -> pure a
    Nothing -> throwError $ "Failed to parse UTCTime: " <> T.pack (show t)

uuid :: DecodeRow UUID
uuid = do
  t <- text
  case UUID.fromString (T.unpack t) of
    Just a -> pure a
    Nothing -> throwError $ "Failed to parse UUID: " <> T.pack (show t)

day :: DecodeRow Day
day = do
  t <- text
  case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack t) of
    Just a -> pure a
    Nothing -> throwError $ "Failed to parse Day: " <> T.pack (show t)

ignore :: DecodeRow ()
ignore =
  void $ column DV.rdsValue

decodeRow :: DecodeRow a -> [Value] -> Either Text a
decodeRow r = evalState (runExceptT (unDecodeRow r))

decodeRows :: DecodeRow a ->  [[Value]] -> Either Text [a]
decodeRows r = traverse (decodeRow r)