module Database.PostgreSQL.Stream.FromRow (
FromRow(..),
FromField(..),
Row(..),
field,
runRowParser,
parseRows,
) where
import Database.PostgreSQL.Stream.Types
import Data.Int
import Control.Applicative
import Control.Exception
import Control.Monad (when)
import Control.Monad.Trans
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Data.UUID (UUID)
import Data.Word (Word8)
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Fixed
import Data.Time.Calendar
import Data.Scientific (Scientific)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Internal (toForeignPtr)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import qualified PostgreSQLBinary.Decoder as PD
import qualified Database.PostgreSQL.LibPQ as PQ
import Unsafe.Coerce
import System.IO.Unsafe
import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr.Safe
foreign import ccall unsafe "array_conversion.h extract_int4_array"
extract_int4_array :: Ptr Word8 -> Ptr CInt -> CInt -> IO Int
foreign import ccall unsafe "array_conversion.h extract_float_array"
extract_numeric_array :: Ptr Word8 -> Ptr CInt -> CInt -> IO Int
type ExFun = Ptr Word8 -> Ptr CInt -> CInt -> IO Int
class FromRow a where
fromRow :: RowParser a
instance (FromField a) => FromRow (Only a) where
fromRow = Only <$> field
instance (FromField a, FromField b) => FromRow (a,b) where
fromRow = (,) <$> field <*> field
instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where
fromRow = (,,) <$> field <*> field <*> field
instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) where
fromRow = (,,,) <$> field <*> field <*> field <*> field
instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) where
fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field
instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a,b,c,d,e,f) where
fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field
instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (a,b,c,d,e,f,g) where
fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field
data Row = Row
{ row :: !PQ.Row
, rowresult :: !PQ.Result
}
type FieldParser a = (PQ.Oid, Int, Maybe ByteString) -> a
class FromField a where
fromField :: (PQ.Oid, Int, Maybe ByteString) -> a
instance FromField Int8 where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null int2"
instance FromField Int16 where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null int4"
instance FromField Int32 where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null int4"
instance FromField Int64 where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null int8"
instance FromField Int where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null int4"
instance FromField Float where
fromField (ty, length, Just bs) = case PD.float4 bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null float4"
instance FromField Double where
fromField (ty, length, Just bs) = case PD.float8 bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null float8"
instance FromField Integer where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null integer"
instance FromField Scientific where
fromField (ty, length, Just bs) = case PD.numeric bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null numeric"
instance FromField UUID where
fromField (ty, length, Just bs) = case PD.uuid bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null uuid"
instance FromField Char where
fromField (ty, length, Just bs) = case PD.char bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null char"
instance FromField Text where
fromField (ty, length, Just bs) = case PD.text bs of
Left x -> throw $ ConversionError "Malformed bytestring."
Right x -> x
fromField _ = throw $ ConversionError "Excepted non-null text"
instance FromField TL.Text where
fromField (ty, length, Just bs) = case PD.text bs of
Left x -> throw $ ConversionError "Malformed bytestring."
Right x -> TL.fromStrict x
fromField _ = throw $ ConversionError "Excepted non-null text"
instance FromField ByteString where
fromField (ty, length, Just bs) = case PD.bytea bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null bytea"
instance FromField BL.ByteString where
fromField (ty, length, Just bs) = case PD.bytea bs of { Right x -> BL.fromStrict x }
fromField _ = throw $ ConversionError "Excepted non-null bytea"
instance FromField Bool where
fromField (ty, length, Just bs) = case PD.bool bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null bool"
instance FromField Day where
fromField (ty, length, Just bs) = case PD.date bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField TimeOfDay where
fromField (ty, length, Just bs) = case PD.time True bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField (TimeOfDay, TimeZone) where
fromField (ty, length, Just bs) = case PD.timetz True bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField UTCTime where
fromField (ty, length, Just bs) = case PD.timestamptz True bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField NominalDiffTime where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> (fromIntegral (x :: Int)) }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField DiffTime where
fromField (ty, length, Just bs) = case PD.interval True bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField LocalTime where
fromField (ty, length, Just bs) = case PD.timestamp True bs of { Right x -> x }
fromField _ = throw $ ConversionError "Excepted non-null date"
instance FromField (Fixed E3) where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> fromIntegral (x :: Int) / 100 }
fromField _ = throw $ ConversionError "Excepted non-null money"
instance FromField (Fixed E2) where
fromField (ty, length, Just bs) = case PD.int bs of { Right x -> fromIntegral (x :: Int) / 100 }
fromField _ = throw $ ConversionError "Excepted non-null money"
instance FromField a => FromField (Maybe a) where
fromField (_, _, Nothing) = Nothing
fromField x = Just (fromField x)
instance FromField (V.Vector Int32) where
fromField (ty, arrlength, Just bs) = unsafeDupablePerformIO $ int4vector bs arrlength
fromField _ = throw $ ConversionError "Excepted non-null int4[]"
instance FromField (V.Vector Float) where
fromField (ty, arrlength, Just bs) = unsafeDupablePerformIO $ float32vector bs arrlength
fromField _ = throw $ ConversionError "Excepted non-null float4[]"
converter :: Show e => (ByteString -> Either e a) -> (PQ.Oid, Int, Maybe ByteString) -> a
converter f (_, _, Just bs) = case f bs of
Left err -> throw $ ConversionError (show err)
Right val -> val
converter f (_, _, Nothing) = throw $ ConversionError "Excepted non-null"
calculateSize :: PQ.Oid -> Int -> Int
calculateSize ty len =
case ty of
PQ.Oid 16 -> 1
PQ.Oid 21 -> 2
PQ.Oid 23 -> 4
PQ.Oid 20 -> 8
PQ.Oid 700 -> 4
PQ.Oid 701 -> 8
PQ.Oid 25 -> 1
PQ.Oid 2950 -> 1
PQ.Oid 1007 -> (len 20) `div` 8
PQ.Oid 1016 -> (len 20) `div` 8
PQ.Oid 1021 -> (len 20) `div` 8
_ -> error $ "Size not yet implemented" ++ (show ty)
extractor :: ExFun -> ByteString -> Int -> IO (V.Vector a)
extractor f bs len = do
vec <- VM.new len
let (fptr, _, _) = toForeignPtr bs
let (aptr, _) = VM.unsafeToForeignPtr0 vec
rc <- withForeignPtr fptr $ \iptr ->
withForeignPtr aptr $ \optr ->
f iptr optr (fromIntegral len)
when (rc /= len) $ throwIO $ ConversionError "Extraction kernel malfunctioned."
ovec <- V.unsafeFreeze vec
return (unsafeCoerce ovec)
float32vector :: ByteString -> Int -> IO (V.Vector Float)
float32vector = extractor extract_numeric_array
int4vector :: ByteString -> Int -> IO (V.Vector Int32)
int4vector = extractor extract_int4_array
field :: FromField a => RowParser a
field = fieldWith fromField
newtype RowParser a = RP { unRP :: ReaderT Row (State PQ.Column) a }
deriving ( Functor, Applicative, Monad )
runRowParser :: RowParser a -> Row -> a
runRowParser parser rw = evalState (runReaderT (unRP parser) rw) 0
fieldWith :: FieldParser a -> RowParser a
fieldWith fieldP = RP $ do
Row{..} <- ask
column <- lift get
lift (put (column + 1))
let
!result = rowresult
!typeOid = unsafeDupablePerformIO $ PQ.ftype result column
!len = unsafeDupablePerformIO $ PQ.getlength result row column
!buffer = unsafeDupablePerformIO $ PQ.getvalue result row column
return $ fieldP (typeOid, calculateSize typeOid len, buffer)
rowLoop :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
rowLoop lo hi m = loop hi []
where
loop !n !as
| n < lo = return as
| otherwise = do
a <- m n
loop (n1) (a:as)
parseRows :: FromRow r => Query -> PQ.Result -> IO [r]
parseRows q result = do
status <- liftIO $ PQ.resultStatus result
case status of
PQ.EmptyQuery ->
liftIO $ throwIO $ QueryError "query: Empty query" q
PQ.CommandOk -> do
liftIO $ throwIO $ QueryError "query resulted in a command response" q
PQ.TuplesOk -> do
nrows <- liftIO $ PQ.ntuples result
xs <- rowLoop 0 (nrows1) $ \row -> do
let rw = Row row result
return $ runRowParser fromRow rw
return xs
_ -> do
err <- liftIO $ PQ.resultErrorMessage result
liftIO $ throwIO $ QueryError (show err) q