module Database.PostgreSQL.Store.Entity (
Entity (..),
embedEntity,
param0,
param1,
param2,
param3,
param4,
param5,
param6,
param7,
param8,
param9,
genGeneric,
parseGeneric,
GEntityRecord (..),
GEntity (..),
GenericEntity
) where
import GHC.Generics (Meta (..))
import GHC.TypeLits hiding (Text)
import Control.Applicative
import Data.Int
import Data.Word
import Data.Bits
import Data.Proxy
import Data.Semigroup
import Data.Scientific (Scientific, formatScientific, FPFormat (Fixed))
import Numeric.Natural
import qualified Data.Aeson as A
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8 (signed, decimal, double, scientific, skipSpace)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import Database.PostgreSQL.Store.Types
import Database.PostgreSQL.Store.Tuple
import Database.PostgreSQL.Store.Generics
import Database.PostgreSQL.Store.Utilities
import Database.PostgreSQL.Store.RowParser
import Database.PostgreSQL.Store.Query.Builder
class (KnownNat (GRecordWidth rec)) => GEntityRecord (rec :: KRecord) where
type GRecordWidth rec :: Nat
gEmbedRecord :: QueryGenerator (Record rec)
gParseRecord :: RowParser (GRecordWidth rec) (Record rec)
instance (Entity typ) => GEntityRecord ('TSingle meta typ) where
type GRecordWidth ('TSingle meta typ) = Width typ
gEmbedRecord = With (\ (Single x) -> x) genEntity
gParseRecord = Single <$> parseEntity
instance (GEntityRecord lhs,
GEntityRecord rhs,
KnownNat (GRecordWidth lhs + GRecordWidth rhs))
=> GEntityRecord ('TCombine lhs rhs) where
type GRecordWidth ('TCombine lhs rhs) = GRecordWidth lhs + GRecordWidth rhs
gEmbedRecord =
mconcat [With (\ (Combine lhs _) -> lhs) gEmbedRecord,
Code ",",
With (\ (Combine _ rhs) -> rhs) gEmbedRecord]
gParseRecord =
Combine <$> gParseRecord
<*>$ gParseRecord
class GEntityEnum (enum :: KFlatSum) where
gEnumToPayload :: FlatSum enum -> B.ByteString
gEnumFromPayload :: B.ByteString -> Maybe (FlatSum enum)
instance (KnownSymbol name) => GEntityEnum ('TValue ('MetaCons name f r)) where
gEnumToPayload _ = buildByteString (symbolVal @name Proxy)
gEnumFromPayload value
| value == buildByteString (symbolVal @name Proxy) = Just Unit
| otherwise = Nothing
instance (GEntityEnum lhs, GEntityEnum rhs) => GEntityEnum ('TChoose lhs rhs) where
gEnumToPayload (ChooseLeft lhs) = gEnumToPayload lhs
gEnumToPayload (ChooseRight rhs) = gEnumToPayload rhs
gEnumFromPayload input =
(ChooseLeft <$> gEnumFromPayload input) <|> (ChooseRight <$> gEnumFromPayload input)
class (KnownNat (GEntityWidth dat)) => GEntity (dat :: KDataType) where
type GEntityWidth dat :: Nat
gEmbedEntity :: QueryGenerator (DataType dat)
gParseEntity :: RowParser (GEntityWidth dat) (DataType dat)
instance (GEntityRecord rec) => GEntity ('TRecord d c rec) where
type GEntityWidth ('TRecord d c rec) = GRecordWidth rec
gEmbedEntity = With (\ (Record x) -> x) gEmbedRecord
gParseEntity = Record <$> gParseRecord
instance (GEntityEnum enum) => GEntity ('TFlatSum d enum) where
type GEntityWidth ('TFlatSum d enum) = 1
gEmbedEntity = Gen (Oid 0) (\ (FlatSum x) -> Just (gEnumToPayload x))
gParseEntity =
retrieveContent >>=$ \ input ->
case gEnumFromPayload input of
Just x -> finish (FlatSum x)
Nothing -> cancel ColumnRejected
type GenericEntity a = (Generic a, GEntity (Rep a))
genGeneric :: (Generic a, GEntity (Rep a)) => QueryGenerator a
genGeneric = With fromGeneric gEmbedEntity
parseGeneric :: (Generic a, GEntity (Rep a)) => RowParser (GEntityWidth (Rep a)) a
parseGeneric = toGeneric <$> gParseEntity
class (KnownNat (Width a)) => Entity a where
type Width a :: Nat
type Width a = GEntityWidth (Rep a)
genEntity :: QueryGenerator a
default genEntity :: (Generic a, GEntity (Rep a)) => QueryGenerator a
genEntity = genGeneric
parseEntity :: RowParser (Width a) a
default parseEntity :: (Generic a, GEntity (Rep a))
=> RowParser (GEntityWidth (Rep a)) a
parseEntity = parseGeneric
embedEntity :: (Entity e) => e -> QueryGenerator a
embedEntity e = withOther e genEntity
param0 :: (Entity r) => QueryGenerator (Tuple (r ': ts))
param0 = withParam0 genEntity
param1 :: (Entity r) => QueryGenerator (Tuple (t0 ': r ': ts))
param1 = withParam1 genEntity
param2 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': r ': ts))
param2 = withParam2 genEntity
param3 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': r ': ts))
param3 = withParam3 genEntity
param4 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': r ': ts))
param4 = withParam4 genEntity
param5 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': r ': ts))
param5 = withParam5 genEntity
param6 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': r ': ts))
param6 = withParam6 genEntity
param7 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': r ': ts))
param7 = withParam7 genEntity
param8 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': r ': ts))
param8 = withParam8 genEntity
param9 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': t8 ': r ': ts))
param9 = withParam9 genEntity
instance (GenericEntity (a, b)) => Entity (a, b)
instance (GenericEntity (a, b, c)) => Entity (a, b, c)
instance (GenericEntity (a, b, c, d)) => Entity (a, b, c, d)
instance (GenericEntity (a, b, c, d, e)) => Entity (a, b, c, d, e)
instance (GenericEntity (a, b, c, d, e, f)) => Entity (a, b, c, d, e, f)
instance (GenericEntity (a, b, c, d, e, f, g)) => Entity (a, b, c, d, e, f, g)
instance (Entity a) => Entity (Maybe a) where
type Width (Maybe a) = Width a
genEntity =
walkTree genEntity
where
walkTree :: QueryGenerator b -> QueryGenerator (Maybe b)
walkTree (Gen oid f) = Gen oid (>>= f)
walkTree (Code code) = Code code
walkTree (With f gen) = With (fmap f) (walkTree gen)
walkTree (Merge l r) = Merge (walkTree l) (walkTree r)
parseEntity =
nonNullCheck width >>=$ \ allNonNull ->
if allNonNull then
Just <$> parseEntity
else
skipColumns >>$ finish Nothing
where
width = fromIntegral (natVal @(Width a) Proxy)
buildGen :: Oid -> (a -> B.Builder) -> QueryGenerator a
buildGen typ builder =
Gen typ (Just . BL.toStrict . B.toLazyByteString . builder)
parseContent :: Parser a -> RowParser 1 a
parseContent p =
processContent $ \ _ mbCnt -> do
r <- mbCnt
case endResult (parse p r) of
Done _ r -> Just r
_ -> Nothing
where
endResult (Partial f) = f B.empty
endResult x = x
instance Entity Bool where
type Width Bool = 1
genEntity = Gen (Oid 16) (\ v -> Just (if v then "t" else "f"))
parseEntity =
(`elem` ["t", "1", "true", "TRUE", "y", "yes", "YES", "on", "ON"]) <$> retrieveContent
instance Entity Integer where
type Width Integer = 1
genEntity = buildGen (Oid 1700) B.integerDec
parseEntity = parseContent (signed decimal)
instance Entity Int where
type Width Int = 1
genEntity = buildGen (Oid 20) B.intDec
parseEntity = parseContent (signed decimal)
instance Entity Int8 where
type Width Int8 = 1
genEntity = buildGen (Oid 21) B.int8Dec
parseEntity = parseContent (signed decimal)
instance Entity Int16 where
type Width Int16 = 1
genEntity = buildGen (Oid 21) B.int16Dec
parseEntity = parseContent (signed decimal)
instance Entity Int32 where
type Width Int32 = 1
genEntity = buildGen (Oid 23) B.int32Dec
parseEntity = parseContent (signed decimal)
instance Entity Int64 where
type Width Int64 = 1
genEntity = buildGen (Oid 20) B.int64Dec
parseEntity = parseContent (signed decimal)
instance Entity Natural where
type Width Natural = 1
genEntity = With toInteger genEntity
parseEntity = parseContent decimal
instance Entity Word where
type Width Word = 1
genEntity = buildGen (Oid 1700) B.wordDec
parseEntity = parseContent decimal
instance Entity Word8 where
type Width Word8 = 1
genEntity = buildGen (Oid 21) B.word8Dec
parseEntity = parseContent decimal
instance Entity Word16 where
type Width Word16 = 1
genEntity = buildGen (Oid 23) B.word16Dec
parseEntity = parseContent decimal
instance Entity Word32 where
type Width Word32 = 1
genEntity = buildGen (Oid 20) B.word32Dec
parseEntity = parseContent decimal
instance Entity Word64 where
type Width Word64 = 1
genEntity = buildGen (Oid 1700) B.word64Dec
parseEntity = parseContent decimal
instance Entity Double where
type Width Double = 1
genEntity = buildGen (Oid 1700) B.doubleDec
parseEntity = parseContent double
instance Entity Float where
type Width Float = 1
genEntity = buildGen (Oid 1700) B.floatDec
parseEntity = realToFrac @Double @Float <$> parseEntity
instance Entity Scientific where
type Width Scientific = 1
genEntity = Gen (Oid 1700) (Just . buildByteString . formatScientific Fixed Nothing)
parseEntity = parseContent scientific
instance Entity String where
type Width String = 1
genEntity = Gen (Oid 25) (Just . buildByteString . filter (/= '\NUL'))
parseEntity = T.unpack <$> parseEntity
instance Entity T.Text where
type Width T.Text = 1
genEntity = Gen (Oid 25) (Just . T.encodeUtf8 . T.filter (/= '\NUL'))
parseEntity =
retrieveContent >>=$ \ input ->
case T.decodeUtf8' input of
Right x -> finish x
_ -> cancel ColumnRejected
instance Entity TL.Text where
type Width TL.Text = 1
genEntity = With TL.toStrict genEntity
parseEntity = TL.fromStrict <$> parseEntity
instance Entity B.ByteString where
type Width B.ByteString = 1
genEntity =
buildGen (Oid 17) (\ value -> mconcat (B.string7 "\\x" : map showHex (B.unpack value)))
where
showHex n
| n <= 0xF = B.char7 '0' <> B.word8Hex n
| otherwise = B.word8Hex n
parseEntity =
parseContent (hexFormat <|> escapedFormat)
where
isHexChar x =
(x >= 48 && x <= 57)
|| (x >= 65 && x <= 70)
|| (x >= 97 && x <= 102)
hexCharToWord x
| x >= 48 && x <= 57 = x 48
| x >= 65 && x <= 70 = x 55
| x >= 97 && x <= 102 = x 87
| otherwise = 0
hexWord = do
skipSpace
a <- satisfy isHexChar
b <- satisfy isHexChar
pure (shiftL (hexCharToWord a) 4 .|. hexCharToWord b)
hexFormat = do
word8 92
word8 120
B.pack <$> many hexWord <* skipSpace
isOctChar x = x >= 48 && x <= 55
octCharToWord x
| isOctChar x = x 48
| otherwise = 0
escapedWord = do
word8 92
a <- satisfy isOctChar
b <- satisfy isOctChar
c <- satisfy isOctChar
pure (shiftL (octCharToWord a) 6 .|. shiftL (octCharToWord b) 3 .|. c)
escapedBackslash = do
word8 92
word8 92
escapedFormat =
B.pack <$> many (escapedBackslash <|> escapedWord <|> anyWord8)
instance Entity BL.ByteString where
type Width BL.ByteString = 1
genEntity = With BL.toStrict genEntity
parseEntity = BL.fromStrict <$> parseEntity
instance Entity A.Value where
type Width A.Value = 1
genEntity = Gen (Oid 114) (Just . BL.toStrict . A.encode)
parseEntity =
retrieveContent >>=$ \ input ->
case A.decodeStrict input of
Just x -> finish x
_ -> cancel ColumnRejected