module Database.PostgreSQL.Store.Entity (
Entity (..),
insertGeneric,
parseGeneric,
GEntityRecord (..),
GEntityEnum (..),
GEntity (..)
) where
import GHC.Generics
import GHC.TypeLits
import Control.Applicative
import Control.Monad
import Data.Int
import Data.Bits
import Data.Word
import Data.Scientific hiding (scientific)
import Numeric
import Numeric.Natural
import Data.Bifunctor
import Data.Proxy
import qualified Data.Aeson as A
import qualified Data.ByteString 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 qualified Data.Text.Lazy.Encoding as TL
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8 (signed, decimal, skipSpace, double, scientific)
import Database.PostgreSQL.Store.Types
import Database.PostgreSQL.Store.Utilities
import Database.PostgreSQL.Store.Generics
import Database.PostgreSQL.Store.Query.Builder
import Database.PostgreSQL.Store.RowParser
import Database.PostgreSQL.LibPQ (Oid (..), invalidOid)
class GEntityRecord (rec :: KRecord) where
gInsertRecord :: Record rec -> QueryBuilder
gParseRecord :: RowParser (Record rec)
instance (Entity typ) => GEntityRecord ('TSingle meta typ) where
gInsertRecord (Single x) =
insertEntity x
gParseRecord =
Single <$> parseEntity
instance (GEntityRecord lhs, GEntityRecord rhs) => GEntityRecord ('TCombine lhs rhs) where
gInsertRecord (Combine lhs rhs) = do
gInsertRecord lhs
insertCode ","
gInsertRecord rhs
gParseRecord =
Combine <$> gParseRecord <*> gParseRecord
class GEntityEnum (enum :: KFlatSum) where
gInsertEnum :: FlatSum enum -> QueryBuilder
gEnumValues :: [(B.ByteString, FlatSum enum)]
instance (KnownSymbol name) => GEntityEnum ('TValue ('MetaCons name f r)) where
gInsertEnum _ =
insertQuote (buildByteString (symbolVal (Proxy :: Proxy name)))
gEnumValues =
[(buildByteString (symbolVal (Proxy :: Proxy name)), Unit)]
instance (GEntityEnum lhs, GEntityEnum rhs) => GEntityEnum ('TChoose lhs rhs) where
gInsertEnum (ChooseLeft lhs) = gInsertEnum lhs
gInsertEnum (ChooseRight rhs) = gInsertEnum rhs
gEnumValues =
map (second ChooseLeft) gEnumValues
++ map (second ChooseRight) gEnumValues
class GEntity (dat :: KDataType) where
gInsertEntity :: DataType dat -> QueryBuilder
gParseEntity :: RowParser (DataType dat)
instance (GEntityRecord rec) => GEntity ('TRecord d c rec) where
gInsertEntity (Record x) =
gInsertRecord x
gParseEntity =
Record <$> gParseRecord
instance (GEntityEnum enum) => GEntity ('TFlatSum d enum) where
gInsertEntity (FlatSum x) =
gInsertEnum x
gParseEntity =
FlatSum <$> parseContents (`lookup` gEnumValues)
insertGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder
insertGeneric x =
gInsertEntity (fromGenericEntity x)
parseGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a
parseGeneric =
toGenericEntity <$> gParseEntity
class Entity a where
insertEntity :: a -> QueryBuilder
default insertEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder
insertEntity = insertGeneric
parseEntity :: RowParser a
default parseEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a
parseEntity = parseGeneric
instance (Entity a, Entity b) => Entity (a, b)
instance (Entity a, Entity b, Entity c) => Entity (a, b, c)
instance (Entity a, Entity b, Entity c, Entity d) => Entity (a, b, c, d)
instance (Entity a, Entity b, Entity c, Entity d, Entity e) => Entity (a, b, c, d, e)
instance (Entity a, Entity b, Entity c, Entity d, Entity e, Entity f) => Entity (a, b, c, d, e, f)
instance (Entity a, Entity b, Entity c, Entity d, Entity e, Entity f, Entity g) => Entity (a, b, c, d, e, f, g)
instance Entity QueryBuilder where
insertEntity = id
parseEntity = do
colsLeft <- columnsLeft
insertCommaSeperated <$> replicateM (fromEnum colsLeft) (insertTypedValue <$> fetchColumn)
instance Entity Value where
insertEntity = insertValue
parseEntity = parseColumn (\ (TypedValue _ mbValue) -> mbValue)
instance Entity TypedValue where
insertEntity = insertTypedValue
parseEntity = fetchColumn
instance (Entity a) => Entity (Maybe a) where
insertEntity Nothing = insertTypedValue (TypedValue invalidOid Nothing)
insertEntity (Just x) = insertEntity x
parseEntity = do
TypedValue _ value <- peekColumn
case value of
Nothing -> pure Nothing
_ -> Just <$> parseEntity
instance Entity Bool where
insertEntity input =
insertTypedValue (TypedValue (Oid 16) (Just (Value value)))
where value | input = "t" | otherwise = "f"
parseEntity =
parseContents $ \ dat ->
Just (elem dat ["t", "1", "true", "TRUE", "y", "yes", "YES", "on", "ON"])
parseContentsWith :: Parser a -> RowParser a
parseContentsWith p =
parseContents (maybeResult . endResult . parse p)
where
endResult (Partial f) = f B.empty
endResult x = x
insertTypedValue_ :: Oid -> B.ByteString -> QueryBuilder
insertTypedValue_ typ val =
insertTypedValue (TypedValue typ (Just (Value val)))
insertNumericValue :: (Show a) => a -> QueryBuilder
insertNumericValue x =
insertTypedValue_ (Oid 1700) (showByteString x)
instance Entity Integer where
insertEntity = insertNumericValue
parseEntity = parseContentsWith (signed decimal)
instance Entity Int where
insertEntity = insertNumericValue
parseEntity = parseContentsWith (signed decimal)
instance Entity Int8 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith (signed decimal)
instance Entity Int16 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith (signed decimal)
instance Entity Int32 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith (signed decimal)
instance Entity Int64 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith (signed decimal)
instance Entity Natural where
insertEntity = insertNumericValue
parseEntity = parseContentsWith decimal
instance Entity Word where
insertEntity = insertNumericValue
parseEntity = parseContentsWith decimal
instance Entity Word8 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith decimal
instance Entity Word16 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith decimal
instance Entity Word32 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith decimal
instance Entity Word64 where
insertEntity = insertNumericValue
parseEntity = parseContentsWith decimal
instance Entity Double where
insertEntity = insertNumericValue
parseEntity = parseContentsWith double
instance Entity Float where
insertEntity = insertNumericValue
parseEntity = (realToFrac :: Double -> Float) <$> parseEntity
instance Entity Scientific where
insertEntity x =
insertTypedValue_ (Oid 1700) (buildByteString (formatScientific Fixed Nothing x))
parseEntity = parseContentsWith scientific
instance Entity String where
insertEntity value =
insertTypedValue_ (Oid 25) (buildByteString value)
parseEntity = T.unpack <$> parseEntity
instance Entity T.Text where
insertEntity value =
insertTypedValue_ (Oid 25) (T.encodeUtf8 value)
parseEntity =
parseContents (either (const Nothing) Just . T.decodeUtf8')
instance Entity TL.Text where
insertEntity value =
insertEntity (TL.toStrict value)
parseEntity =
parseContents (either (const Nothing) Just . TL.decodeUtf8' . BL.fromStrict)
instance Entity B.ByteString where
insertEntity value =
insertTypedValue_ (Oid 17) dat
where
dat = B.append "\\x" (B.concatMap showHex' value)
showHex' n =
buildByteString $ case showHex n [] of
(a : b : _) -> [a, b]
(a : _) -> ['0', a]
[] -> "00"
parseEntity =
parseContentsWith (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
insertEntity value =
insertEntity (BL.toStrict value)
parseEntity = BL.fromStrict <$> parseEntity
instance Entity A.Value where
insertEntity value =
insertTypedValue_ (Oid 114) (BL.toStrict (A.encode value))
parseEntity = parseContents A.decodeStrict