{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeOperators              #-}

-- | The types in this module have invariants which cannot be checked
-- if their constructors are in scope.  Preql.Wire exports the type
-- names only.

module Preql.Wire.Internal where

import Preql.Wire.Errors

import Control.Monad.Except
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.IORef
import Data.String (IsString)
import GHC.TypeNats
import Preql.Imports

import qualified Data.Vector.Sized as VS
import qualified Database.PostgreSQL.LibPQ as PQ

-- | The IsString instance does no validation; the limited instances
-- discourage directly manipulating strings, with the high risk of SQL
-- injection.  A @Query@ is tagged with a 'Nat' representing the width
-- of its return type.
newtype Query (n :: Nat) = Query ByteString
    deriving (Int -> Query n -> ShowS
[Query n] -> ShowS
Query n -> String
(Int -> Query n -> ShowS)
-> (Query n -> String) -> ([Query n] -> ShowS) -> Show (Query n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: Nat). Int -> Query n -> ShowS
forall (n :: Nat). [Query n] -> ShowS
forall (n :: Nat). Query n -> String
showList :: [Query n] -> ShowS
$cshowList :: forall (n :: Nat). [Query n] -> ShowS
show :: Query n -> String
$cshow :: forall (n :: Nat). Query n -> String
showsPrec :: Int -> Query n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> Query n -> ShowS
Show, String -> Query n
(String -> Query n) -> IsString (Query n)
forall a. (String -> a) -> IsString a
forall (n :: Nat). String -> Query n
fromString :: String -> Query n
$cfromString :: forall (n :: Nat). String -> Query n
IsString)

-- | @RowDecoder@ is 'Functor' but not 'Monad' so that we can index
-- the type by the number of columns that it consumes.  We also know &
-- verify all of the OIDs before we read any of the field data sent by
-- Postgres, which would admit an 'Applicative' instance but not 'Monad'
data RowDecoder (n :: Nat) a = RowDecoder (VS.Vector n PgType) (InternalDecoder a)
    deriving a -> RowDecoder n b -> RowDecoder n a
(a -> b) -> RowDecoder n a -> RowDecoder n b
(forall a b. (a -> b) -> RowDecoder n a -> RowDecoder n b)
-> (forall a b. a -> RowDecoder n b -> RowDecoder n a)
-> Functor (RowDecoder n)
forall a b. a -> RowDecoder n b -> RowDecoder n a
forall a b. (a -> b) -> RowDecoder n a -> RowDecoder n b
forall (n :: Nat) a b. a -> RowDecoder n b -> RowDecoder n a
forall (n :: Nat) a b. (a -> b) -> RowDecoder n a -> RowDecoder n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RowDecoder n b -> RowDecoder n a
$c<$ :: forall (n :: Nat) a b. a -> RowDecoder n b -> RowDecoder n a
fmap :: (a -> b) -> RowDecoder n a -> RowDecoder n b
$cfmap :: forall (n :: Nat) a b. (a -> b) -> RowDecoder n a -> RowDecoder n b
Functor

-- | Analogous to 'pure', @pureDecoder a@ returns the value @a@
-- without consuming any input from Postgres.
pureDecoder :: a -> RowDecoder 0 a
pureDecoder :: a -> RowDecoder 0 a
pureDecoder a
a = Vector 0 PgType -> InternalDecoder a -> RowDecoder 0 a
forall (n :: Nat) a.
Vector n PgType -> InternalDecoder a -> RowDecoder n a
RowDecoder Vector 0 PgType
forall a. Vector 0 a
VS.empty (a -> InternalDecoder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | Analogous to '<*>', @pureDecoder Constructor `applyDecoder` a
-- `applyDecoder` b@ supplies two arguments to @Constructor@, from the
-- 'RowDecoder' @a@ and @b@.
{-# INLINE applyDecoder #-}
applyDecoder :: RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m+n) b
applyDecoder :: RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m + n) b
applyDecoder (RowDecoder Vector m PgType
vm InternalDecoder (a -> b)
f) (RowDecoder Vector n PgType
vn InternalDecoder a
a) = Vector (m + n) PgType -> InternalDecoder b -> RowDecoder (m + n) b
forall (n :: Nat) a.
Vector n PgType -> InternalDecoder a -> RowDecoder n a
RowDecoder (Vector m PgType
vm Vector m PgType -> Vector n PgType -> Vector (m + n) PgType
forall (n :: Nat) (m :: Nat) a.
Vector n a -> Vector m a -> Vector (n + m) a
VS.++ Vector n PgType
vn) (InternalDecoder (a -> b)
f InternalDecoder (a -> b) -> InternalDecoder a -> InternalDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InternalDecoder a
a)

-- | Internal because we need IO for the libpq FFI, but we promise not
-- to do any IO besides decoding.  We don't even make network calls to
-- Postgres in @InternalDecoder@
type InternalDecoder =  ReaderT (IORef DecoderState) IO

data DecoderState = DecoderState
    { DecoderState -> Result
result :: !PQ.Result
    , DecoderState -> Row
row    :: !PQ.Row
    , DecoderState -> Column
column :: !PQ.Column
    }
    deriving (Int -> DecoderState -> ShowS
[DecoderState] -> ShowS
DecoderState -> String
(Int -> DecoderState -> ShowS)
-> (DecoderState -> String)
-> ([DecoderState] -> ShowS)
-> Show DecoderState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecoderState] -> ShowS
$cshowList :: [DecoderState] -> ShowS
show :: DecoderState -> String
$cshow :: DecoderState -> String
showsPrec :: Int -> DecoderState -> ShowS
$cshowsPrec :: Int -> DecoderState -> ShowS
Show, DecoderState -> DecoderState -> Bool
(DecoderState -> DecoderState -> Bool)
-> (DecoderState -> DecoderState -> Bool) -> Eq DecoderState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecoderState -> DecoderState -> Bool
$c/= :: DecoderState -> DecoderState -> Bool
== :: DecoderState -> DecoderState -> Bool
$c== :: DecoderState -> DecoderState -> Bool
Eq)

{-# INLINE incrementColumn #-}
incrementColumn :: DecoderState -> DecoderState
incrementColumn :: DecoderState -> DecoderState
incrementColumn s :: DecoderState
s@DecoderState{Column
column :: Column
$sel:column:DecoderState :: DecoderState -> Column
column} = DecoderState
s { $sel:column:DecoderState :: Column
column = Column
column Column -> Column -> Column
forall a. Num a => a -> a -> a
+ Column
1 }

{-# INLINE incrementRow #-}
incrementRow :: DecoderState -> DecoderState
incrementRow :: DecoderState -> DecoderState
incrementRow DecoderState
s = DecoderState
s { $sel:row:DecoderState :: Row
row = DecoderState -> Row
row DecoderState
s Row -> Row -> Row
forall a. Num a => a -> a -> a
+ Row
1, $sel:column:DecoderState :: Column
column = Column
0 }

-- | Can throw FieldError
{-# INLINE decodeRow #-}
decodeRow :: IORef DecoderState -> RowDecoder n a -> PQ.Result -> IO a
decodeRow :: IORef DecoderState -> RowDecoder n a -> Result -> IO a
decodeRow IORef DecoderState
ref (RowDecoder Vector n PgType
_ InternalDecoder a
parsers) Result
result = {-# SCC "decodeRow" #-} do
    a
result <- InternalDecoder a -> IORef DecoderState -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT InternalDecoder a
parsers IORef DecoderState
ref
    IORef DecoderState -> (DecoderState -> DecoderState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef DecoderState
ref DecoderState -> DecoderState
incrementRow
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

{-# INLINE getNextValue #-}
getNextValue :: InternalDecoder (Maybe ByteString)
getNextValue :: InternalDecoder (Maybe ByteString)
getNextValue = {-# SCC "getNextValue" #-} do
    IORef DecoderState
ref <- ReaderT (IORef DecoderState) IO (IORef DecoderState)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    DecoderState{Result
Column
Row
column :: Column
row :: Row
result :: Result
$sel:column:DecoderState :: DecoderState -> Column
$sel:row:DecoderState :: DecoderState -> Row
$sel:result:DecoderState :: DecoderState -> Result
..} <- IO DecoderState -> ReaderT (IORef DecoderState) IO DecoderState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO DecoderState -> ReaderT (IORef DecoderState) IO DecoderState)
-> IO DecoderState -> ReaderT (IORef DecoderState) IO DecoderState
forall a b. (a -> b) -> a -> b
$ IORef DecoderState -> IO DecoderState
forall a. IORef a -> IO a
readIORef IORef DecoderState
ref
    IO () -> ReaderT (IORef DecoderState) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT (IORef DecoderState) IO ())
-> IO () -> ReaderT (IORef DecoderState) IO ()
forall a b. (a -> b) -> a -> b
$ IORef DecoderState -> (DecoderState -> DecoderState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef DecoderState
ref DecoderState -> DecoderState
incrementColumn
    IO (Maybe ByteString) -> InternalDecoder (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> InternalDecoder (Maybe ByteString))
-> IO (Maybe ByteString) -> InternalDecoder (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Result -> Row -> Column -> IO (Maybe ByteString)
PQ.getvalue' Result
result Row
row Column
column