pg-store 0.2 → 0.4.0
raw patch · 15 files changed
+1334/−882 lines, 15 filesdep +QuickCheckdep +hashabledep +pg-storedep ~base
Dependencies added: QuickCheck, hashable, pg-store, tagged, test-framework, test-framework-quickcheck2
Dependency ranges changed: base
Files
- pg-store.cabal +16/−3
- src/Database/PostgreSQL/Store.hs +17/−13
- src/Database/PostgreSQL/Store/ColumnEntity.hs +0/−188
- src/Database/PostgreSQL/Store/Entity.hs +292/−187
- src/Database/PostgreSQL/Store/Errand.hs +131/−100
- src/Database/PostgreSQL/Store/Generics.hs +23/−32
- src/Database/PostgreSQL/Store/Query.hs +1/−10
- src/Database/PostgreSQL/Store/Query/Builder.hs +186/−84
- src/Database/PostgreSQL/Store/Query/TH.hs +191/−46
- src/Database/PostgreSQL/Store/RowParser.hs +92/−122
- src/Database/PostgreSQL/Store/Table.hs +36/−84
- src/Database/PostgreSQL/Store/Tuple.hs +174/−0
- src/Database/PostgreSQL/Store/Types.hs +45/−12
- src/Database/PostgreSQL/Store/Utilities.hs +4/−1
- tests/Entities.hs +126/−0
pg-store.cabal view
@@ -1,5 +1,5 @@ name: pg-store-version: 0.2+version: 0.4.0 category: Database synopsis: Simple storage interface to PostgreSQL description: Simple storage interface to PostgreSQL@@ -22,17 +22,30 @@ build-depends: base >= 4.9 && < 5, template-haskell >= 2.11 && < 3, bytestring, blaze-builder, text, postgresql-libpq, attoparsec, mtl, time,- haskell-src-meta, aeson, scientific+ haskell-src-meta, aeson, scientific, tagged, hashable hs-source-dirs: src exposed-modules: Database.PostgreSQL.Store.RowParser Database.PostgreSQL.Store.Errand+ Database.PostgreSQL.Store.Tuple Database.PostgreSQL.Store.Query.Builder Database.PostgreSQL.Store.Query.TH Database.PostgreSQL.Store.Query Database.PostgreSQL.Store.Types Database.PostgreSQL.Store.Generics Database.PostgreSQL.Store.Entity- Database.PostgreSQL.Store.ColumnEntity Database.PostgreSQL.Store.Table Database.PostgreSQL.Store other-modules: Database.PostgreSQL.Store.Utilities++test-suite entities+ type: exitcode-stdio-1.0+ ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-tabs -fno-warn-name-shadowing+ -Wno-orphans+ default-language: Haskell2010+ build-depends: base, pg-store, mtl,+ test-framework, test-framework-quickcheck2, QuickCheck,+ postgresql-libpq,+ scientific,+ bytestring, text+ hs-source-dirs: tests+ main-is: Entities.hs
src/Database/PostgreSQL/Store.hs view
@@ -13,32 +13,36 @@ query, queryWith, - insert,- insertMany,- deleteAll,- findAll,- create,+ prepare, + beginTransaction,+ commitTransaction,+ saveTransaction,+ rollbackTransaction,+ rollbackTransactionTo,+ withTransaction,+ -- * Query Query (..),- pgsq,- castQuery,+ PrepQuery (..),+ pgQuery,+ pgPrepQuery,+ pgQueryGen, + -- * Types+ Oid (..),+ -- * Entity Entity (..), -- * Tables- TableEntity (..),- ColumnEntity (..),- Table (..),- ColumnType (..),- Column (..),+ TableEntity (..), -- * Errors ErrandError (..), ErrorCode (..),- P.ExecStatus,+ P.ExecStatus (..), RowError (..), RowErrorLocation (..), RowErrorDetail (..)
− src/Database/PostgreSQL/Store/ColumnEntity.hs
@@ -1,188 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}---- |--- Module: Database.PostgreSQL.Store.ColumnEntity--- Copyright: (c) Ole Krüger 2016--- License: BSD3--- Maintainer: Ole Krüger <ole@vprsm.de>-module Database.PostgreSQL.Store.ColumnEntity (- ColumnType (..),- ColumnEntity (..)-) where--import Data.Proxy--import Data.Int-import Data.Word-import Data.Scientific-import Numeric.Natural--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.Lazy as TL--import Database.PostgreSQL.Store.Entity-import Database.PostgreSQL.Store.Utilities-import Database.PostgreSQL.Store.Query.Builder---- | Description of a column type-data ColumnType = ColumnType {- -- | Type name- colTypeName :: B.ByteString,-- -- | @NOT NULL@ constraint present?- colTypeNotNull :: Bool,-- -- | Produce a check statement body when given a column name- colTypeCheck :: Maybe (B.ByteString -> QueryBuilder)-}---- | Classify a type which can be used as a column in a table.-class (Entity a) => ColumnEntity a where- -- | Describe the column type- describeColumnType :: proxy a -> ColumnType--instance (ColumnEntity a) => ColumnEntity (Maybe a) where- describeColumnType _ =- (describeColumnType (Proxy :: Proxy a)) {- colTypeNotNull = False- }--newtype PGInt2 = PGInt2 Int16- deriving (Show, Read, Eq, Ord, Enum, Bounded, Integral, Num, Real)--instance Entity PGInt2 where- insertEntity (PGInt2 x) =- insertEntity x-- parseEntity =- PGInt2 <$> parseEntity--instance ColumnEntity PGInt2 where- describeColumnType _ =- ColumnType "int2" True Nothing--newtype PGInt4 = PGInt4 Int32- deriving (Show, Read, Eq, Ord, Enum, Bounded, Integral, Num, Real)--instance Entity PGInt4 where- insertEntity (PGInt4 x) =- insertEntity x-- parseEntity =- PGInt4 <$> parseEntity--instance ColumnEntity PGInt4 where- describeColumnType _ =- ColumnType "int4" True Nothing--newtype PGInt8 = PGInt8 Int64- deriving (Show, Read, Eq, Ord, Enum, Bounded, Integral, Num, Real)--instance Entity PGInt8 where- insertEntity (PGInt8 x) =- insertEntity x-- parseEntity =- PGInt8 <$> parseEntity--instance ColumnEntity PGInt8 where- describeColumnType _ =- ColumnType "int8" True Nothing---- | Select a type which can contain the given numeric type.-selectBestColumnType :: (Show a, Num a, Ord a, Bounded a) => proxy a -> ColumnType-selectBestColumnType proxy- | -32768 <= lower && upper <= 32767 =- ColumnType "int2" True Nothing- | -2147483648 <= lower && upper <= 2147483647 =- ColumnType "int4" True Nothing- | -9223372036854775808 <= lower && upper <= 9223372036854775807 =- ColumnType "int8" True Nothing- | otherwise =- ColumnType (buildByteString ("numeric(" ++ show digits ++ ",0)")) True Nothing- where- upper = (const maxBound :: (Bounded a) => proxy a -> a) proxy- lower = (const minBound :: (Bounded a) => proxy a -> a) proxy- digits = max (length (show upper)) (length (show lower))--instance ColumnEntity Bool where- describeColumnType _ =- ColumnType "bool" True Nothing--instance ColumnEntity Integer where- describeColumnType _ =- ColumnType "numeric" True Nothing--instance ColumnEntity Int where- describeColumnType = selectBestColumnType--instance ColumnEntity Int8 where- describeColumnType = selectBestColumnType--instance ColumnEntity Int16 where- describeColumnType = selectBestColumnType--instance ColumnEntity Int32 where- describeColumnType = selectBestColumnType--instance ColumnEntity Int64 where- describeColumnType = selectBestColumnType--instance ColumnEntity Natural where- describeColumnType _ =- ColumnType "numeric" True Nothing--instance ColumnEntity Word where- describeColumnType = selectBestColumnType--instance ColumnEntity Word8 where- describeColumnType = selectBestColumnType--instance ColumnEntity Word16 where- describeColumnType = selectBestColumnType--instance ColumnEntity Word32 where- describeColumnType = selectBestColumnType--instance ColumnEntity Word64 where- describeColumnType = selectBestColumnType--instance ColumnEntity Float where- describeColumnType _ =- ColumnType "real" True Nothing--instance ColumnEntity Double where- describeColumnType _ =- ColumnType "double precision" True Nothing--instance ColumnEntity Scientific where- describeColumnType _ =- ColumnType "numeric" True Nothing--instance ColumnEntity String where- describeColumnType _ =- ColumnType "text" True Nothing--instance ColumnEntity T.Text where- describeColumnType _ =- ColumnType "text" True Nothing--instance ColumnEntity TL.Text where- describeColumnType _ =- ColumnType "text" True Nothing--instance ColumnEntity B.ByteString where- describeColumnType _ =- ColumnType "bytea" True Nothing--instance ColumnEntity BL.ByteString where- describeColumnType _ =- ColumnType "bytea" True Nothing--instance ColumnEntity A.Value where- describeColumnType _ =- ColumnType "json" True Nothing
src/Database/PostgreSQL/Store/Entity.hs view
@@ -7,6 +7,7 @@ ScopedTypeVariables, TypeFamilies, TypeOperators,+ TypeApplications, TypeSynonymInstances, UndecidableInstances #-}@@ -20,349 +21,447 @@ -- * Result and query entity Entity (..), - insertGeneric,+ embedEntity,++ param0,+ param1,+ param2,+ param3,+ param4,+ param5,+ param6,+ param7,+ param8,+ param9,++ genGeneric, parseGeneric, -- * Helpers GEntityRecord (..),- GEntityEnum (..),- GEntity (..)+ GEntity (..),+ GenericEntity ) where -import GHC.Generics-import GHC.TypeLits+import GHC.Generics (Meta (..))+import GHC.TypeLits hiding (Text) 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.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 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.Tuple import Database.PostgreSQL.Store.Generics-import Database.PostgreSQL.Store.Query.Builder+import Database.PostgreSQL.Store.Utilities import Database.PostgreSQL.Store.RowParser--import Database.PostgreSQL.LibPQ (Oid (..), invalidOid)+import Database.PostgreSQL.Store.Query.Builder -- | Generic record entity-class GEntityRecord (rec :: KRecord) where- gInsertRecord :: Record rec -> QueryBuilder+class (KnownNat (GRecordWidth rec)) => GEntityRecord (rec :: KRecord) where+ type GRecordWidth rec :: Nat - gParseRecord :: RowParser (Record rec)+ gEmbedRecord :: QueryGenerator (Record rec) + gParseRecord :: RowParser (GRecordWidth rec) (Record rec)+ instance (Entity typ) => GEntityRecord ('TSingle meta typ) where- gInsertRecord (Single x) =- insertEntity x+ type GRecordWidth ('TSingle meta typ) = Width typ - gParseRecord =- Single <$> parseEntity+ gEmbedRecord = With (\ (Single x) -> x) genEntity -instance (GEntityRecord lhs, GEntityRecord rhs) => GEntityRecord ('TCombine lhs rhs) where- gInsertRecord (Combine lhs rhs) = do- gInsertRecord lhs- insertCode ","- gInsertRecord rhs+ 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+ Combine <$> gParseRecord+ <*>$ gParseRecord --- | Generic enumeration entity+-- | Generic enumeration value class GEntityEnum (enum :: KFlatSum) where- gInsertEnum :: FlatSum enum -> QueryBuilder+ gEnumToPayload :: FlatSum enum -> B.ByteString - gEnumValues :: [(B.ByteString, FlatSum enum)]+ gEnumFromPayload :: B.ByteString -> Maybe (FlatSum enum) instance (KnownSymbol name) => GEntityEnum ('TValue ('MetaCons name f r)) where- gInsertEnum _ =- insertQuote (buildByteString (symbolVal (Proxy :: Proxy name)))+ gEnumToPayload _ = buildByteString (symbolVal @name Proxy) - gEnumValues =- [(buildByteString (symbolVal (Proxy :: Proxy name)), Unit)]+ gEnumFromPayload value+ | value == buildByteString (symbolVal @name Proxy) = Just Unit+ | otherwise = Nothing instance (GEntityEnum lhs, GEntityEnum rhs) => GEntityEnum ('TChoose lhs rhs) where- gInsertEnum (ChooseLeft lhs) = gInsertEnum lhs- gInsertEnum (ChooseRight rhs) = gInsertEnum rhs+ gEnumToPayload (ChooseLeft lhs) = gEnumToPayload lhs+ gEnumToPayload (ChooseRight rhs) = gEnumToPayload rhs - gEnumValues =- map (second ChooseLeft) gEnumValues- ++ map (second ChooseRight) gEnumValues+ gEnumFromPayload input =+ (ChooseLeft <$> gEnumFromPayload input) <|> (ChooseRight <$> gEnumFromPayload input) + -- | Generic entity-class GEntity (dat :: KDataType) where- gInsertEntity :: DataType dat -> QueryBuilder+class (KnownNat (GEntityWidth dat)) => GEntity (dat :: KDataType) where+ type GEntityWidth dat :: Nat - gParseEntity :: RowParser (DataType dat)+ gEmbedEntity :: QueryGenerator (DataType dat) + gParseEntity :: RowParser (GEntityWidth dat) (DataType dat)+ instance (GEntityRecord rec) => GEntity ('TRecord d c rec) where- gInsertEntity (Record x) =- gInsertRecord x+ type GEntityWidth ('TRecord d c rec) = GRecordWidth rec - gParseEntity =- Record <$> gParseRecord+ gEmbedEntity = With (\ (Record x) -> x) gEmbedRecord + gParseEntity = Record <$> gParseRecord+ instance (GEntityEnum enum) => GEntity ('TFlatSum d enum) where- gInsertEntity (FlatSum x) =- gInsertEnum x+ type GEntityWidth ('TFlatSum d enum) = 1 + gEmbedEntity = Gen (Oid 0) (\ (FlatSum x) -> Just (gEnumToPayload x))+ gParseEntity =- FlatSum <$> parseContents (`lookup` gEnumValues)+ retrieveContent >>=$ \ input ->+ case gEnumFromPayload input of+ Just x -> finish (FlatSum x)+ Nothing -> cancel ColumnRejected --- | Insert generic entity into the query.-insertGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder-insertGeneric x =- gInsertEntity (fromGenericEntity x)+-- | This is required if you want to use the default implementations of 'genEntity'or 'parseEntity'+-- with polymorphic data types.+type GenericEntity a = (Generic a, GEntity (Rep a)) +-- | Generic 'QueryGenerator' for an entity.+genGeneric :: (Generic a, GEntity (Rep a)) => QueryGenerator a+genGeneric = With fromGeneric gEmbedEntity+ -- | Generic 'RowParser' for an entity.-parseGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a-parseGeneric =- toGenericEntity <$> gParseEntity+parseGeneric :: (Generic a, GEntity (Rep a)) => RowParser (GEntityWidth (Rep a)) a+parseGeneric = toGeneric <$> gParseEntity -- | An entity that is used as a parameter or result of a query.-class Entity a where- -- | Insert an instance of @a@ into the query.- insertEntity :: a -> QueryBuilder+class (KnownNat (Width a)) => Entity a where+ -- | Number of values the entity consists of+ type Width a :: Nat - default insertEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder- insertEntity = insertGeneric+ type Width a = GEntityWidth (Rep a) + -- | Embed the entity into the query.+ genEntity :: QueryGenerator a++ default genEntity :: (Generic a, GEntity (Rep a)) => QueryGenerator a+ genEntity = genGeneric+ -- | Retrieve an instance of @a@ from the result set.- parseEntity :: RowParser a+ parseEntity :: RowParser (Width a) a - default parseEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a+ default parseEntity :: (Generic a, GEntity (Rep a))+ => RowParser (GEntityWidth (Rep a)) a parseEntity = parseGeneric --- | 2 result entities in sequence-instance (Entity a, Entity b) => Entity (a, b)+-- | Embed an entity into the query.+embedEntity :: (Entity e) => e -> QueryGenerator a+embedEntity e = withOther e genEntity --- | 3 result entities in sequence-instance (Entity a, Entity b, Entity c) => Entity (a, b, c)+-- | Parameter entity at index 0+param0 :: (Entity r) => QueryGenerator (Tuple (r ': ts))+param0 = withParam0 genEntity --- | 4 result entities in sequence-instance (Entity a, Entity b, Entity c, Entity d) => Entity (a, b, c, d)+-- | Parameter entity at index 1+param1 :: (Entity r) => QueryGenerator (Tuple (t0 ': r ': ts))+param1 = withParam1 genEntity --- | 5 result entities in sequence-instance (Entity a, Entity b, Entity c, Entity d, Entity e) => Entity (a, b, c, d, e)+-- | Parameter entity at index 2+param2 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': r ': ts))+param2 = withParam2 genEntity --- | 6 result entities in sequence-instance (Entity a, Entity b, Entity c, Entity d, Entity e, Entity f) => Entity (a, b, c, d, e, f)+-- | Parameter entity at index 3+param3 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': r ': ts))+param3 = withParam3 genEntity --- | 7 result entities in sequence-instance (Entity a, Entity b, Entity c, Entity d, Entity e, Entity f, Entity g) => Entity (a, b, c, d, e, f, g)+-- | Parameter entity at index 4+param4 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': r ': ts))+param4 = withParam4 genEntity --- | 'QueryBuilder'-instance Entity QueryBuilder where- insertEntity = id+-- | Parameter entity at index 5+param5 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': r ': ts))+param5 = withParam5 genEntity - parseEntity = do- colsLeft <- columnsLeft- insertCommaSeperated <$> replicateM (fromEnum colsLeft) (insertTypedValue <$> fetchColumn)+-- | Parameter entity at index 6+param6 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': r ': ts))+param6 = withParam6 genEntity --- | Untyped column value-instance Entity Value where- insertEntity = insertValue+-- | Parameter entity at index 7+param7 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': r ': ts))+param7 = withParam7 genEntity - parseEntity = parseColumn (\ (TypedValue _ mbValue) -> mbValue)+-- | Parameter entity at index 8+param8 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': r ': ts))+param8 = withParam8 genEntity --- | Typed column value-instance Entity TypedValue where- insertEntity = insertTypedValue+-- | Parameter entity at index 9+param9 :: (Entity r) => QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': t8 ': r ': ts))+param9 = withParam9 genEntity - parseEntity = fetchColumn+-- | Chain of 2 entities+instance (GenericEntity (a, b)) => Entity (a, b) --- | A value which may normally not be @NULL@.-instance (Entity a) => Entity (Maybe a) where- insertEntity Nothing = insertTypedValue (TypedValue invalidOid Nothing)- insertEntity (Just x) = insertEntity x+-- | Chain of 3 entities+instance (GenericEntity (a, b, c)) => Entity (a, b, c) - parseEntity = do- TypedValue _ value <- peekColumn- case value of- Nothing -> pure Nothing- _ -> Just <$> parseEntity+-- | Chain of 4 entities+instance (GenericEntity (a, b, c, d)) => Entity (a, b, c, d) +-- | Chain of 5 entities+instance (GenericEntity (a, b, c, d, e)) => Entity (a, b, c, d, e) --- | @boolean@-instance Entity Bool where- insertEntity input =- insertTypedValue (TypedValue (Oid 16) (Just (Value value)))- where value | input = "t" | otherwise = "f"+-- | Chain of 6 entities+instance (GenericEntity (a, b, c, d, e, f)) => Entity (a, b, c, d, e, f) +-- | Chain of 7 entities+instance (GenericEntity (a, b, c, d, e, f, g)) => Entity (a, b, c, d, e, f, g)++-- | A value which may normally not be @NULL@.+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 =- parseContents $ \ dat ->- Just (elem dat ["t", "1", "true", "TRUE", "y", "yes", "YES", "on", "ON"])+ nonNullCheck width >>=$ \ allNonNull ->+ if allNonNull then+ Just <$> parseEntity+ else+ skipColumns >>$ finish Nothing+ where+ width = fromIntegral (natVal @(Width a) Proxy) --- | Parse a column using the given 'Parser'.-parseContentsWith :: Parser a -> RowParser a-parseContentsWith p =- parseContents (maybeResult . endResult . parse p)+-- | Construct a 'QueryGenerator' using a 'B.Builder'.+buildGen :: Oid -> (a -> B.Builder) -> QueryGenerator a+buildGen typ builder =+ Gen typ (Just . BL.toStrict . B.toLazyByteString . builder)++-- | Parse the contents of a column.+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 --- | Simplified version of 'insertTypedValue'-insertTypedValue_ :: Oid -> B.ByteString -> QueryBuilder-insertTypedValue_ typ val =- insertTypedValue (TypedValue typ (Just (Value val)))+-- | @boolean@+instance Entity Bool where+ type Width Bool = 1 --- | Insert a numeric value.-insertNumericValue :: (Show a) => a -> QueryBuilder-insertNumericValue x =- insertTypedValue_ (Oid 1700) (showByteString x)+ genEntity = Gen (Oid 16) (\ v -> Just (if v then "t" else "f")) + parseEntity =+ (`elem` ["t", "1", "true", "TRUE", "y", "yes", "YES", "on", "ON"]) <$> retrieveContent+ -- | Any integer instance Entity Integer where- insertEntity = insertNumericValue+ type Width Integer = 1 - parseEntity = parseContentsWith (signed decimal)+ genEntity = buildGen (Oid 1700) B.integerDec + parseEntity = parseContent (signed decimal)+ -- | Any integer instance Entity Int where- insertEntity = insertNumericValue+ type Width Int = 1 - parseEntity = parseContentsWith (signed decimal)+ genEntity = buildGen (Oid 20) B.intDec + parseEntity = parseContent (signed decimal)+ -- | Any integer instance Entity Int8 where- insertEntity = insertNumericValue+ type Width Int8 = 1 - parseEntity = parseContentsWith (signed decimal)+ genEntity = buildGen (Oid 21) B.int8Dec + parseEntity = parseContent (signed decimal)+ -- | Any integer instance Entity Int16 where- insertEntity = insertNumericValue+ type Width Int16 = 1 - parseEntity = parseContentsWith (signed decimal)+ genEntity = buildGen (Oid 21) B.int16Dec + parseEntity = parseContent (signed decimal)+ -- | Any integer instance Entity Int32 where- insertEntity = insertNumericValue+ type Width Int32 = 1 - parseEntity = parseContentsWith (signed decimal)+ genEntity = buildGen (Oid 23) B.int32Dec + parseEntity = parseContent (signed decimal)+ -- | Any integer instance Entity Int64 where- insertEntity = insertNumericValue+ type Width Int64 = 1 - parseEntity = parseContentsWith (signed decimal)+ genEntity = buildGen (Oid 20) B.int64Dec + parseEntity = parseContent (signed decimal)+ -- | Any unsigned integer instance Entity Natural where- insertEntity = insertNumericValue+ type Width Natural = 1 - parseEntity = parseContentsWith decimal+ genEntity = With toInteger genEntity + parseEntity = parseContent decimal+ -- | Any unsigned integer instance Entity Word where- insertEntity = insertNumericValue+ type Width Word = 1 - parseEntity = parseContentsWith decimal+ genEntity = buildGen (Oid 1700) B.wordDec + parseEntity = parseContent decimal+ -- | Any unsigned integer instance Entity Word8 where- insertEntity = insertNumericValue+ type Width Word8 = 1 - parseEntity = parseContentsWith decimal+ genEntity = buildGen (Oid 21) B.word8Dec + parseEntity = parseContent decimal+ -- | Any unsigned integer instance Entity Word16 where- insertEntity = insertNumericValue+ type Width Word16 = 1 - parseEntity = parseContentsWith decimal+ genEntity = buildGen (Oid 23) B.word16Dec + parseEntity = parseContent decimal+ -- | Any unsigned integer instance Entity Word32 where- insertEntity = insertNumericValue+ type Width Word32 = 1 - parseEntity = parseContentsWith decimal+ genEntity = buildGen (Oid 20) B.word32Dec + parseEntity = parseContent decimal+ -- | Any unsigned integer instance Entity Word64 where- insertEntity = insertNumericValue+ type Width Word64 = 1 - parseEntity = parseContentsWith decimal+ genEntity = buildGen (Oid 1700) B.word64Dec + parseEntity = parseContent decimal+ -- | Any floating-point number instance Entity Double where- insertEntity = insertNumericValue+ type Width Double = 1 - parseEntity = parseContentsWith double+ genEntity = buildGen (Oid 1700) B.doubleDec + parseEntity = parseContent double+ -- | Any floating-point number instance Entity Float where- insertEntity = insertNumericValue+ type Width Float = 1 - parseEntity = (realToFrac :: Double -> Float) <$> parseEntity+ genEntity = buildGen (Oid 1700) B.floatDec + parseEntity = realToFrac @Double @Float <$> parseEntity+ -- | Any numeric type instance Entity Scientific where- insertEntity x =- insertTypedValue_ (Oid 1700) (buildByteString (formatScientific Fixed Nothing x))+ type Width Scientific = 1 - parseEntity = parseContentsWith scientific+ genEntity = Gen (Oid 1700) (Just . buildByteString . formatScientific Fixed Nothing) --- | @char@, @varchar@ or @text@ - UTF-8 encoded+ parseEntity = parseContent scientific++-- | @char@, @varchar@ or @text@ - UTF-8 encoded; does not allow NULL characters instance Entity String where- insertEntity value =- insertTypedValue_ (Oid 25) (buildByteString value)+ type Width String = 1 + genEntity = Gen (Oid 25) (Just . buildByteString . filter (/= '\NUL'))+ parseEntity = T.unpack <$> parseEntity --- | @char@, @varchar@ or @text@ - UTF-8 encoded+-- | @char@, @varchar@ or @text@ - UTF-8 encoded; does not allow NULL characters instance Entity T.Text where- insertEntity value =- insertTypedValue_ (Oid 25) (T.encodeUtf8 value)+ type Width T.Text = 1 + genEntity = Gen (Oid 25) (Just . T.encodeUtf8 . T.filter (/= '\NUL'))+ parseEntity =- parseContents (either (const Nothing) Just . T.decodeUtf8')+ retrieveContent >>=$ \ input ->+ case T.decodeUtf8' input of+ Right x -> finish x+ _ -> cancel ColumnRejected --- | @char@, @varchar@ or @text@ - UTF-8 encoded+-- | @char@, @varchar@ or @text@ - UTF-8 encoded; does not allow NULL characters instance Entity TL.Text where- insertEntity value =- insertEntity (TL.toStrict value)+ type Width TL.Text = 1 - parseEntity =- parseContents (either (const Nothing) Just . TL.decodeUtf8' . BL.fromStrict)+ genEntity = With TL.toStrict genEntity + parseEntity = TL.fromStrict <$> parseEntity+ -- | @bytea@ - byte array encoded in hex format instance Entity B.ByteString where- insertEntity value =- insertTypedValue_ (Oid 17) dat- where- dat = B.append "\\x" (B.concatMap showHex' value)+ type Width B.ByteString = 1 - showHex' n =- buildByteString $ case showHex n [] of- (a : b : _) -> [a, b]- (a : _) -> ['0', a]- [] -> "00"+ 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 =- parseContentsWith (hexFormat <|> escapedFormat)+ parseContent (hexFormat <|> escapedFormat) where isHexChar x = (x >= 48 && x <= 57) -- 0 - 9- || (x >= 65 && x <= 70) -- A - Z- || (x >= 97 && x <= 102) -- a - z+ || (x >= 65 && x <= 70) -- A - F+ || (x >= 97 && x <= 102) -- a - f hexCharToWord x | x >= 48 && x <= 57 = x - 48@@ -382,14 +481,14 @@ word8 120 -- x B.pack <$> many hexWord <* skipSpace - isOctChar x = x >= 48 && x <= 55+ isOctChar x = x >= 48 && x <= 55 -- 0 - 7 octCharToWord x- | isOctChar x = x - 48+ | isOctChar x = x - 48 -- 0 | otherwise = 0 escapedWord = do- word8 92+ word8 92 -- \ a <- satisfy isOctChar b <- satisfy isOctChar c <- satisfy isOctChar@@ -397,7 +496,7 @@ pure (shiftL (octCharToWord a) 6 .|. shiftL (octCharToWord b) 3 .|. c) escapedBackslash = do- word8 92+ word8 92 -- \ word8 92 escapedFormat =@@ -405,14 +504,20 @@ -- | @bytea@ - byte array encoded in hex format instance Entity BL.ByteString where- insertEntity value =- insertEntity (BL.toStrict value)+ type Width BL.ByteString = 1 + genEntity = With BL.toStrict genEntity+ parseEntity = BL.fromStrict <$> parseEntity -- | @json@ or @jsonb@ instance Entity A.Value where- insertEntity value =- insertTypedValue_ (Oid 114) (BL.toStrict (A.encode value))+ type Width A.Value = 1 - parseEntity = parseContents A.decodeStrict+ genEntity = Gen (Oid 114) (Just . BL.toStrict . A.encode)++ parseEntity =+ retrieveContent >>=$ \ input ->+ case A.decodeStrict input of+ Just x -> finish x+ _ -> cancel ColumnRejected
src/Database/PostgreSQL/Store/Errand.hs view
@@ -1,4 +1,16 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings,+ GeneralizedNewtypeDeriving,+ TypeApplications,+ TypeFamilies,+ ScopedTypeVariables,+ MultiParamTypeClasses,+ FunctionalDependencies,+ UndecidableInstances,+ FlexibleInstances,+ FlexibleContexts,+ TypeSynonymInstances,+ DataKinds,+ QuasiQuotes #-} -- | -- Module: Database.PostgreSQL.Store.Errand@@ -18,19 +30,25 @@ query, queryWith, - insert,- insertMany,- deleteAll,- findAll,- create+ prepare,++ beginTransaction,+ commitTransaction,+ saveTransaction,+ rollbackTransaction,+ rollbackTransactionTo,+ withTransaction ) where +import GHC.TypeLits++import Control.Applicative import Control.Monad.Trans import Control.Monad.Except import Control.Monad.Reader -import Data.Proxy import Data.Maybe+ import qualified Data.ByteString as B import Data.Attoparsec.ByteString.Char8@@ -38,10 +56,10 @@ import qualified Database.PostgreSQL.LibPQ as P import Database.PostgreSQL.Store.Types-import Database.PostgreSQL.Store.Table+import Database.PostgreSQL.Store.Tuple import Database.PostgreSQL.Store.Entity import Database.PostgreSQL.Store.RowParser-import Database.PostgreSQL.Store.Query.Builder+import Database.PostgreSQL.Store.Query -- | Error during errand data ErrandError@@ -55,6 +73,11 @@ -- ^ Result processing failed. deriving (Show, Eq) +instance Monoid ErrandError where+ mempty = UserError "mempty"++ mappend _ e = e+ -- | Error codes data ErrorCode = UnknownErrorCause B.ByteString@@ -69,26 +92,24 @@ -- | An interaction with the database newtype Errand a = Errand (ReaderT P.Connection (ExceptT ErrandError IO) a)- deriving (Functor, Applicative, Monad, MonadIO, MonadError ErrandError)+ deriving (Functor, Applicative, Monad, Alternative, MonadIO, MonadError ErrandError) -- | Run an errand. runErrand :: P.Connection -> Errand a -> IO (Either ErrandError a)-runErrand con (Errand errand) =- runExceptT (runReaderT errand con)+runErrand con (Errand errand) = runExceptT (runReaderT errand con) --- | Execute a query and return the internal raw result.-execute :: Query a -> Errand P.Result-execute (Query statement params) = Errand . ReaderT $ \ con -> do- res <- ExceptT (transformResult <$> P.execParams con statement (map transformParam params) P.Text)- status <- lift (P.resultStatus res)+-- | Validate the result.+validateResult :: P.Result -> Errand ()+validateResult res = do+ status <- liftIO (P.resultStatus res) case status of- P.CommandOk -> pure res- P.TuplesOk -> pure res- P.SingleTuple -> pure res+ P.CommandOk -> pure ()+ P.TuplesOk -> pure ()+ P.SingleTuple -> pure () other -> do- (state, msg, detail, hint) <- lift $+ (state, msg, detail, hint) <- liftIO $ (,,,) <$> P.resultErrorField res P.DiagSqlstate <*> P.resultErrorField res P.DiagMessagePrimary <*> P.resultErrorField res P.DiagMessageDetail@@ -111,31 +132,6 @@ (fromMaybe B.empty detail) (fromMaybe B.empty hint)) - where- -- Turn 'Maybe P.Result' into 'Either ErrandError P.Result'- transformResult =- maybe (throwError NoResult) pure-- -- Turn 'TypedValue' into 'Maybe (P.Oid, B.ByteString, P.Format)'- transformParam (TypedValue typ mbValue) =- (\ (Value value) -> (typ, value, P.Text)) <$> mbValue---- | Same as 'execute' but instead of a 'P.Result' it returns the number of affected rows.-execute' :: Query a -> Errand Int-execute' =- countAffectedRows <=< execute---- | Execute a query and process its result set.-query :: (Entity a) => Query a -> Errand [a]-query qry =- queryWith qry parseEntity---- | Execute a query and process its result set using the provided 'RowParser'.-queryWith :: Query a -> RowParser a -> Errand [a]-queryWith qry parser = do- result <- execute qry- Errand (lift (withExceptT ParseError (parseResult result parser)))- -- | Counts the rows that have been affected by a query. countAffectedRows :: P.Result -> Errand Int countAffectedRows res = do@@ -145,62 +141,97 @@ endResult (Partial f) = f B.empty endResult x = x --- | Insert a row into a 'Table'.-insert :: (TableEntity a) => a -> Errand Bool-insert row = do- fmap (> 0) . execute' $ buildQuery $ do- insertCode "INSERT INTO "- insertName name- insertCode "("- insertCommaSeperated (map (\ (Column colName _) -> insertName colName) cols)- insertCode ") VALUES ("- insertEntity row- insertCode ")"- where- Table name cols =- describeTableType ((const Proxy :: a -> Proxy a) row)+-- | Extract the result.+transformResult :: Maybe P.Result -> Errand P.Result+transformResult = maybe (throwError NoResult) pure --- | Insert many rows into a 'Table'.-insertMany :: (TableEntity a) => [a] -> Errand Int-insertMany [] = pure 0-insertMany rows =- execute' $ buildQuery $ do- insertCode "INSERT INTO "- insertName name- insertCode "("- insertCommaSeperated (map (\ (Column colName _) -> insertName colName) cols)- insertCode ") VALUES "- insertCommaSeperated (map insertRowValue rows)- where- Table name cols =- describeTableType ((const Proxy :: [a] -> Proxy a) rows)+-- | Identifies @q@ as a query object.+class ErrandQuery q r where+ -- | A type equal to @Errand r@ or a function which will eventually yield a @Errand r@+ type ErrandResult q r - insertRowValue row = do- insertCode "("- insertEntity row- insertCode ")"+ -- | Execute the query described in @q x@ and pass its 'P.Result' to the given function.+ executeWith :: (P.Result -> Errand r) -> q x -> ErrandResult q r --- | Delete all rows of a 'Table'.-deleteAll :: (TableEntity a) => proxy a -> Errand Int-deleteAll proxy =- execute' $ buildQuery $ do- insertCode "DELETE FROM "- insertName (tableName (describeTableType proxy))+instance ErrandQuery Statement r where+ type ErrandResult Statement r = Errand r --- | Find every row of a 'Table'.-findAll :: (TableEntity a) => Errand [a]-findAll =- query (findAllQuery Proxy)- where- findAllQuery :: (TableEntity a) => Proxy a -> Query a- findAllQuery proxy =- buildQuery $ do- insertCode "SELECT "- insertColumns (describeTableType proxy)- insertCode " FROM "- insertName (tableName (describeTableType proxy))+ executeWith end (Statement stmt) = do+ con <- Errand ask+ mbRes <- liftIO (P.execParams con stmt [] P.Text)+ res <- transformResult mbRes+ validateResult res+ end res --- | Create the given 'Table' type.-create :: (TableEntity a) => proxy a -> Errand ()-create proxy =- () <$ execute (buildQuery (buildTableSchema (describeTableType proxy)))+instance ErrandQuery Query r where+ type ErrandResult Query r = Errand r++ executeWith end (Query stmt params) = do+ con <- Errand ask+ mbRes <- liftIO (P.execParams con stmt params P.Text)+ res <- transformResult mbRes+ validateResult res+ end res++instance (WithTuple ts (Errand r)) => ErrandQuery (PrepQuery ts) r where+ type ErrandResult (PrepQuery ts) r = FunctionType ts (Errand r)++ executeWith end (PrepQuery name _ _ gens) =+ withTuple $ \ params -> do+ con <- Errand ask+ mbRes <- liftIO (P.execPrepared con name (gens params) P.Text)+ res <- transformResult mbRes+ validateResult res+ end res++-- | Execute the query and return its internal result.+execute :: (ErrandQuery q P.Result) => q r -> ErrandResult q P.Result+execute = executeWith pure++-- | Same as 'execute' but instead of a 'P.Result' it returns the number of affected rows.+execute' :: (ErrandQuery q Int) => q r -> ErrandResult q Int+execute' = executeWith countAffectedRows++-- | Execute a query and process its result set using the provided 'RowParser'.+queryWith :: (ErrandQuery q [r], KnownNat n) => RowParser n r -> q r -> ErrandResult q [r]+queryWith parser =+ executeWith $ \ result ->+ Errand (lift (withExceptT ParseError (processResultWith result parser)))++-- | Execute a query and process its result set.+query :: (Entity r, ErrandQuery q [r]) => q r -> ErrandResult q [r]+query = queryWith parseEntity++-- | Prepare a preparable query.+prepare :: PrepQuery a r -> Errand ()+prepare (PrepQuery name stmt oids _) = do+ con <- Errand ask+ mbRes <- liftIO (P.prepare con name stmt (Just oids))+ res <- transformResult mbRes+ validateResult res++-- | Begin a transaction.+beginTransaction :: Errand ()+beginTransaction = () <$ execute (Statement "BEGIN")++-- | Commit transaction.+commitTransaction :: Errand ()+commitTransaction = () <$ execute (Statement "COMMIT")++-- | Create savepoint within transaction.+saveTransaction :: B.ByteString -> Errand ()+saveTransaction name = () <$ execute [pgQuery| SAVEPOINT $(genIdentifier name) |]++-- | Roll back transaction.+rollbackTransaction :: Errand ()+rollbackTransaction = () <$ execute (Statement "ROLLBACK")++-- | Roll back to a specific savepoint.+rollbackTransactionTo :: B.ByteString -> Errand ()+rollbackTransactionTo name = () <$ execute [pgQuery| ROLLBACK TO $(genIdentifier name) |]++-- | Do something within a transaction.+withTransaction :: Errand a -> Errand ()+withTransaction trans = do+ beginTransaction+ (trans >> commitTransaction) <|> rollbackTransaction
src/Database/PostgreSQL/Store/Generics.hs view
@@ -17,12 +17,11 @@ -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Generics ( -- * Generic Entity- EntityDataType,- GenericEntity,-- toGenericEntity,- fromGenericEntity,+ Generic,+ Rep, + toGeneric,+ fromGeneric, -- * Type-Level Information KRecord (..),@@ -41,15 +40,14 @@ -- * Analyzers AnalyzeRecordRep, AnalyzeFlatSumRep,- AnalyzeDataType,-- AnalyzeEntity+ AnalyzeDataType ) where -import GHC.Generics-import GHC.TypeLits+import GHC.Generics hiding (Generic (..))+import qualified GHC.Generics as G+import GHC.TypeLits -import Data.Kind+import Data.Kind -- | Information about a record data KRecord@@ -58,7 +56,7 @@ | TSingle Meta Type -- ^ Single element with meta information and type --- | Mappings between a 'Generic' representation and our 'KRecord'-based representation+-- | Mappings between a 'G.Generic' representation and our 'KRecord'-based representation class GRecord (rec :: KRecord) where -- | 'Generic' representation type RecordRep rec :: * -> *@@ -128,7 +126,7 @@ | TValue Meta -- ^ Single value of the enumeration --- | Mappings between a 'Generic' representation and our 'KFlatSum'-based representation+-- | Mappings between a 'G.Generic' representation and our 'KFlatSum'-based representation class GFlatSum (enum :: KFlatSum) where -- | 'Generic' representation type FlatSumRep enum :: * -> *@@ -207,7 +205,7 @@ | TFlatSum Meta KFlatSum -- ^ Enumeration --- | Mappings between a 'Generic' representation and our 'KDataType'-based representation+-- | Mappings between a 'G.Generic' representation and our 'KDataType'-based representation class GDataType (dat :: KDataType) where -- | 'Generic' representation type DataTypeRep dat :: * -> *@@ -277,30 +275,23 @@ ':<>: 'Text " is not a valid data type" ':$$: 'ShowType other) --- | Analyze the 'Generic' representation of a type, in order to generate its 'KDataType' instance.-type AnalyzeEntity a = AnalyzeDataType a (Rep a)---- | Analyze the 'Generic' representation of a type to figure out which 'DataType' it needs.-type EntityDataType a = DataType (AnalyzeEntity a)+-- | 'KDataType' representation of a data type+type Rep a = AnalyzeDataType a (G.Rep a) --- | Make sure @a@ has a safe generic representation. Types that qualify implement 'Generic' and--- fulfill one of the following criteria:+-- | Make sure @a@ has a safe generic representation. Types that qualify implement 'G.Generic' (GHC)+-- and fulfill one of the following criteria: -- -- * single constructor with 1 or more fields -- * multiple constructors with no fields -- -- This constraint is mostly utilized to give the user more information about why their type has -- been rejected.-type GenericEntity a = (Generic a,- GDataType (AnalyzeEntity a),- DataTypeRep (AnalyzeEntity a) ~ Rep a)+type Generic a = (G.Generic a, GDataType (Rep a), DataTypeRep (Rep a) ~ G.Rep a) --- | Convert to entity representation.-fromGenericEntity :: (GenericEntity a) => a -> EntityDataType a-fromGenericEntity =- toDataType . from+-- | Convert to generic representation.+fromGeneric :: (Generic a) => a -> DataType (Rep a)+fromGeneric = toDataType . G.from --- | Build from entity representation.-toGenericEntity :: (GenericEntity a) => EntityDataType a -> a-toGenericEntity =- to . fromDataType+-- | Build from generic representation.+toGeneric :: (Generic a) => DataType (Rep a) -> a+toGeneric = G.to . fromDataType
src/Database/PostgreSQL/Store/Query.hs view
@@ -8,17 +8,8 @@ module Database.PostgreSQL.Store.Query ( -- * Exported modules module Database.PostgreSQL.Store.Query.Builder,- module Database.PostgreSQL.Store.Query.TH,-- -- * Utilities- castQuery+ module Database.PostgreSQL.Store.Query.TH ) where -import Database.PostgreSQL.Store.Types import Database.PostgreSQL.Store.Query.Builder import Database.PostgreSQL.Store.Query.TH---- | Cast the query's result type.-castQuery :: Query a -> Query b-castQuery (Query s p) =- Query s p
src/Database/PostgreSQL/Store/Query/Builder.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification,+ TypeOperators,+ TypeApplications,+ ScopedTypeVariables,+ DataKinds #-} -- | -- Module: Database.PostgreSQL.Store.Query.Builder@@ -6,94 +10,143 @@ -- License: BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Query.Builder (- -- * Query Builder- QueryBuilder,- insertCode,- insertTypedValue,- insertValue,- insertValue',- insertQuote,- insertName,+ QueryGenerator (..), - insertCommaSeperated,+ assemble,+ assemblePrep, - -- * Generalized Building- FromQueryBuilder (..)+ withOther,++ genIdentifier,+ genNestedIdentifier,+ genQuote,++ joinGens,++ withParamN,+ withParam0,+ withParam1,+ withParam2,+ withParam3,+ withParam4,+ withParam5,+ withParam6,+ withParam7,+ withParam8,+ withParam9 ) where -import Control.Monad.State.Strict+import Data.Semigroup import Data.List-import qualified Data.ByteString as B+import Data.String+import Data.Tagged+import Data.Hashable -import Database.PostgreSQL.LibPQ (invalidOid)+import qualified Data.ByteString as B import Database.PostgreSQL.Store.Types import Database.PostgreSQL.Store.Utilities+import Database.PostgreSQL.Store.Tuple --- | Internal builder state-data BuilderState = BuilderState {- queryCode :: B.ByteString,- queryIndex :: Word,- queryValues :: [TypedValue]-}+-- | Generator for queries, its type parameter hints the type needed to generate the attached values+data QueryGenerator a+ = Gen Oid (a -> Maybe B.ByteString)+ | Code B.ByteString+ | forall b. With (a -> b) (QueryGenerator b)+ | Merge (QueryGenerator a) (QueryGenerator a) --- | Query builder-type QueryBuilder = State BuilderState ()+instance Monoid (QueryGenerator a) where+ mempty = Code B.empty --- | Insert a piece of SQL.-insertCode :: B.ByteString -> QueryBuilder-insertCode code =- modify (\ state -> state {queryCode = B.append (queryCode state) code})+ mappend (Code l) (Code r) =+ Code (B.append l r)+ mappend (Code l) (Merge (Code r) suffix) =+ mappend (Code (B.append l r)) suffix+ mappend (Merge prefix (Code l)) (Code r) =+ mappend prefix (Code (B.append l r))+ mappend (Merge prefix (Code l)) (Merge (Code r) suffix) =+ mappend prefix (Merge (Code (B.append l r)) suffix)+ mappend lhs rhs =+ Merge lhs rhs --- | Insert a parameter placeholder into the code and attach the typed value to the query.-insertTypedValue :: TypedValue -> QueryBuilder-insertTypedValue typedValue =- modify $ \ BuilderState {..} ->- BuilderState {- queryCode = B.concat [queryCode, B.singleton 36, showByteString queryIndex],- queryIndex = queryIndex + 1,- queryValues = queryValues ++ [typedValue]- }+ {-# INLINE mappend #-} --- | Same as 'insertTypedValue' but untyped.-insertValue :: Value -> QueryBuilder-insertValue value =- insertTypedValue (TypedValue invalidOid (Just value))+instance Semigroup (QueryGenerator a) --- | Extension of 'insertValue' which will add a type hint to the parameter placeholder.-insertValue' :: B.ByteString -> Value -> QueryBuilder-insertValue' typ value = do- insertCode "("- insertValue value- insertCode "::"- insertCode typ- insertCode ")"+instance IsString (QueryGenerator a) where+ fromString str = Code (buildByteString str) --- | Insert a quote into the code.-insertQuote :: B.ByteString -> QueryBuilder-insertQuote contents =- insertCode (B.concat [B.singleton 39, -- '- B.concatMap replaceDelim contents,- B.singleton 39])+instance Hashable (QueryGenerator a) where+ hashWithSalt salt (Gen _ _) = hashWithSalt salt ()+ hashWithSalt salt (Code c) = hashWithSalt salt c+ hashWithSalt salt (With _ c) = hashWithSalt salt c+ hashWithSalt salt (Merge l r) = hashWithSalt (hashWithSalt salt l) r++-- | Assemble the query object.+assemble :: QueryGenerator a -> a -> Query r+assemble gen x =+ Query code values where- replaceDelim 39 = B.pack [39, 39]- replaceDelim x = B.singleton x+ (code, values, _) = walk gen x 1 --- | Join several builders into a comma-seperated list.-insertCommaSeperated :: [QueryBuilder] -> QueryBuilder-insertCommaSeperated bs =- sequence_ (intersperse (insertCode ",") bs)+ walk :: QueryGenerator b -> b -> Word -> (B.ByteString, [Maybe (Oid, B.ByteString, Format)], Word)+ walk gen x n =+ case gen of+ Gen typ f ->+ -- 36 = $+ (B.cons 36 (showByteString n), [toTypedParam typ <$> f x], n + 1) --- | Insert a name into the code. It will be surrounded by double quotes if necessary.-insertName :: B.ByteString -> QueryBuilder-insertName name =+ Code c ->+ (c, [], n)++ Merge lhs rhs ->+ let+ (lc, lv, n') = walk lhs x n+ (rc, rv, n'') = walk rhs x n'+ in (B.append lc rc, lv ++ rv, n'')++ With t gen' ->+ walk gen' (t x) n++-- | Assemble for query preparation.+assemblePrep :: B.ByteString -> QueryGenerator (Tuple p) -> PrepQuery p r+assemblePrep prefix gen =+ PrepQuery (B.append prefix (showByteString (hash code))) code oids values+ where+ (code, oids, values, _) = walk gen 1++ walk :: QueryGenerator b -> Word -> (B.ByteString, [Oid], b -> [Maybe (B.ByteString, Format)], Word)+ walk gen n =+ case gen of+ Gen typ f ->+ (B.cons 36 (showByteString n), [typ], \ x -> [toParam <$> f x], n + 1)++ Code c ->+ (c, [], const [], n)++ Merge lhs rhs ->+ let+ (lc, lt, lf, n') = walk lhs n+ (rc, rt, rf, n'') = walk rhs n'+ in (B.append lc rc, lt ++ rt, lf <> rf, n'')++ With f gen' ->+ let (c, t, v, n') = walk gen' n in (c, t, v . f, n')++-- | Embed a generator which requires an external parameter.+withOther :: a -> QueryGenerator a -> QueryGenerator b+withOther x = With (const x)++-- | Format identifier properly.+formatIdentifier :: B.ByteString -> B.ByteString+formatIdentifier name = if isAllowed then- insertCode name+ name else- insertCode (B.concat [B.singleton 34, -- "- B.intercalate (B.pack [34, 34]) (B.split 34 name),- B.singleton 34])+ B.concat [B.singleton 34, -- "+ B.intercalate (B.pack [34, 34]) (B.split 34 name),+ B.singleton 34] where isAllowedHead b = (b >= 97 && b <= 122) -- 'a' to 'z'@@ -106,26 +159,75 @@ isAllowed = case B.uncons name of- Nothing -> True+ Nothing -> False Just (h, b) -> isAllowedHead h && B.all isAllowedBody b --- | @a@ can be instantiated using the query builder.-class FromQueryBuilder a where- buildQuery :: QueryBuilder -> a+-- | Insert an identifying name. Takes care of proper quotation.+genIdentifier :: B.ByteString -> QueryGenerator a+genIdentifier name =+ Code (formatIdentifier name) -instance FromQueryBuilder QueryBuilder where- buildQuery = id+-- | Connect two identifiers with a dot. Each identifier is surrounded by quotes if necessary.+genNestedIdentifier :: B.ByteString -> B.ByteString -> QueryGenerator a+genNestedIdentifier target field =+ Code (B.concat [formatIdentifier target,+ B.singleton 46, -- .+ formatIdentifier field]) -instance FromQueryBuilder B.ByteString where- buildQuery builder =- queryCode (execState builder (BuilderState B.empty 1 []))+-- | Surround with quotes and escape delimiting characters.+genQuote :: B.ByteString -> QueryGenerator a+genQuote contents =+ Code (B.concat [B.singleton 39, -- '+ B.intercalate (B.pack [39, 39]) (B.split 39 contents),+ B.singleton 39]) -instance FromQueryBuilder (B.ByteString, [TypedValue]) where- buildQuery builder =- (code, values)- where BuilderState code _ values = execState builder (BuilderState B.empty 1 [])+-- | Join multiple query generators with a piece of code.+joinGens :: B.ByteString -> [QueryGenerator a] -> QueryGenerator a+joinGens code gens =+ mconcat (intersperse (Code code) gens) -instance FromQueryBuilder (Query a) where- buildQuery builder =- Query code values- where BuilderState code _ values = execState builder (BuilderState B.empty 1 [])+-- | Redirect the @n@-th parameter for the given query+withParamN :: forall n r ts. (HasElement n ts r)+ => QueryGenerator r+ -> Tagged n (QueryGenerator (Tuple ts))+withParamN x = Tagged (With (untag . getElementN @n) x)++-- | Redirect the 0th paramter to the given query generator.+withParam0 :: QueryGenerator r -> QueryGenerator (Tuple (r ': ts))+withParam0 = With getElement0++-- | Redirect the 1st paramter to the given query generator.+withParam1 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': r ': ts))+withParam1 = With getElement1++-- | Redirect the 2nd paramter to the given query generator.+withParam2 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': r ': ts))+withParam2 = With getElement2++-- | Redirect the 3rd paramter to the given query generator.+withParam3 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': r ': ts))+withParam3 = With getElement3++-- | Redirect the 4th paramter to the given query generator.+withParam4 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': r ': ts))+withParam4 = With getElement4++-- | Redirect the 5th paramter to the given query generator.+withParam5 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': r ': ts))+withParam5 = With getElement5++-- | Redirect the 6th paramter to the given query generator.+withParam6 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': r ': ts))+withParam6 = With getElement6++-- | Redirect the 7th paramter to the given query generator.+withParam7 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': r ': ts))+withParam7 = With getElement7++-- | Redirect the 8th paramter to the given query generator.+withParam8 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': r ': ts))+withParam8 = With getElement8++-- | Redirect the 9th paramter to the given query generator.+withParam9 :: QueryGenerator r -> QueryGenerator (Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': t8 ': r ': ts))+withParam9 = With getElement9
src/Database/PostgreSQL/Store/Query/TH.hs view
@@ -5,10 +5,107 @@ -- Copyright: (c) Ole Krüger 2016 -- License: BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de>+--+-- All of the quasi quoters in this module accept the same language. It is almost identical to the+-- language that a PostgreSQL server accepts. Certain operators have been reused in order to achieve+-- a nice integration with the features of this library.+--+-- Each quasi quoter uses 'QueryGenerator' as an intermediate representation.+--+-- = 'QueryGenerator'+-- Other query generators can be embedded using the @$(haskell code)@ construct.+--+-- > genCatSound :: QueryGenerator a+-- > genCatSound = Code "'meow'"+-- >+-- > listCats :: Query String+-- > listCats =+-- > [pgQuery| SELECT name+-- > FROM animals+-- > WHERE sound = $(genCatSound) |]+--+-- We inline the @genCatSound@ generator which produces the SQL code @\'meow\'@. As a result we have+-- a query with this statement:+--+-- > SELECT *+-- > FROM animals+-- > WHERE sound = 'meow'+--+-- It is also possible to produce 'QueryGenerator's with the 'pgQueryGen' quasi quoter.+--+-- > genCatSound :: QueryGenerator a+-- > genCatSound = [pgQueryGen| 'meow' |]+--+-- = 'Entity'+-- Everything that has an instance of 'Entity' can also be used in these quasi quoters. So far, one+-- can only utilize them in the form of named expressions.+--+-- The @$@ operator will cause the value of the following named expression to be used in the query.+-- Any use of @$name@ is just a short cut for @$('embedEntity' name)@.+--+-- > listPeople :: Int -> Query String+-- > listPeople minimumAge =+-- > [pgQuery| SELECT name+-- > FROM people+-- > WHERE age > $minimumAge |]+--+-- This query will list the names of people above a given age.+--+-- = 'TableEntity'+-- The 'TableEntity' type class lets you associate a table name and the name of its column with a+-- data type.+--+-- Given a table schema like the following:+--+-- > CREATE TABLE MyTable (+-- > first INTEGER NOT NULL,+-- > second VARCHAR NOT NULL+-- > )+--+-- We produce Haskell code like this:+--+-- > data MyTable = MyTable {+-- > first :: Int,+-- > second :: String+-- > } deriving (Show, Eq, Ord, Generic)+-- >+-- > instance Entity MyTable+-- >+-- > instance TableEntity MyTable+--+-- Alternatively we can implement 'Entity' and 'TableEntity' ourselves. In this case it is not+-- needed.+--+-- We utilize these type classes in the following way:+--+-- > listMyTable :: Query MyTable+-- > listMyTable =+-- > [pgQuery| SELECT #MyTable+-- > FROM @MyTable |]+--+-- We expand the absolute column names using @#MyTable@ and the table name using @\@MyTable@.+-- This results in the following SQL:+--+-- > SELECT MyTable.first, MyTable.second+-- > FROM MyTable+--+-- Aliasing the table name is also possible:+--+-- > listMyTable :: Query MyTable+-- > listMyTable =+-- > [pgQuery| SELECT #MyTable(t)+-- > FROM @MyTable AS t |]+--+-- The alias is included in the resulting SQL:+--+-- > SELECT t.first, t.second+-- > FROM MyTable t+-- module Database.PostgreSQL.Store.Query.TH (- -- * Template Haskell- parseQuery,- pgsq+ -- * Quasi quoters+ pgQueryGen,+ pgQuery,+ pgPrepQuery ) where import Language.Haskell.TH@@ -17,8 +114,8 @@ import Control.Applicative +import Data.Tagged import Data.List-import Data.Proxy import Data.Char import Data.Attoparsec.Text import qualified Data.ByteString as B@@ -55,7 +152,6 @@ | QueryTable String | QuerySelector String | QuerySelectorAlias String String- -- QueryIdentifier String deriving (Show, Eq, Ord) -- | Table@@ -79,12 +175,6 @@ <*> valueName <* char ')' --- -- | Identifier--- identifierSegment :: Parser QuerySegment--- identifierSegment = do--- char '&'--- QueryIdentifier <$> qualifiedTypeName- -- | Entity entityNameSegment :: Parser QuerySegment entityNameSegment = do@@ -134,7 +224,6 @@ otherSegment :: Parser QuerySegment otherSegment = QueryOther <$> some (satisfy (notInClass "\"'@#$"))- -- QueryOther <$> some (satisfy (notInClass "\"'@&#$")) -- | Segment that is part of the query querySegment :: Parser QuerySegment@@ -144,7 +233,6 @@ tableSegment, selectorAliasSegment, selectorSegment,- -- identifierSegment, entityCodeSegment, entityNameSegment, otherSegment]@@ -154,6 +242,14 @@ packCode code = B.toByteString (B.fromString code) +-- | Shortcut for @Tagged t Table@+type TableTag t = Tagged t Table++-- |+tableDescriptionE :: Name -> Q Exp+tableDescriptionE typ =+ [e| untag (describeTableType :: TableTag $(conT typ)) |]+ -- | Translate a "QuerySegment" to an expression. translateSegment :: QuerySegment -> Q Exp translateSegment segment =@@ -161,70 +257,119 @@ QueryTable stringName -> do mbTypeName <- lookupTypeName stringName case mbTypeName of- Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+ Nothing ->+ fail ("'" ++ stringName ++ "' does not refer to a type") Just typ ->- [e| insertName (tableName (describeTableType (Proxy :: Proxy $(conT typ)))) |]+ [e| genTableName $(tableDescriptionE typ) |] QuerySelector stringName -> do mbTypeName <- lookupTypeName stringName case mbTypeName of- Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+ Nothing ->+ fail ("'" ++ stringName ++ "' does not refer to a type") Just typ ->- [e| insertColumns (describeTableType (Proxy :: Proxy $(conT typ))) |]+ [e| genTableColumns $(tableDescriptionE typ) |] QuerySelectorAlias stringName aliasName -> do mbTypeName <- lookupTypeName stringName case mbTypeName of- Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")+ Nothing ->+ fail ("'" ++ stringName ++ "' does not refer to a type") Just typ ->- [e| insertColumnsOn (describeTableType (Proxy :: Proxy $(conT typ)))- $(liftByteString (buildByteString aliasName)) |]-- -- QueryIdentifier stringName -> do- -- mbTypeName <- lookupTypeName stringName- -- case mbTypeName of- -- Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type")- -- Just typ ->- -- [e| insertTableIdentColumnName (Proxy :: Proxy $(conT typ)) |]+ [e| genTableColumnsOn $(tableDescriptionE typ)+ $(liftByteString (buildByteString aliasName)) |] QueryEntity stringName -> do mbValueName <- lookupValueName stringName case mbValueName of- Nothing -> fail ("'" ++ stringName ++ "' does not refer to a value")+ Nothing ->+ fail ("'" ++ stringName ++ "' does not refer to a value") Just name ->- [e| insertEntity $(varE name) |]+ [e| embedEntity $(varE name) |] QueryEntityCode code -> case parseExp code of- Left msg -> fail ("Error in code " ++ show code ++ ": " ++ msg)- Right expr ->- [e| insertEntity $(pure expr) |]+ Left msg -> fail ("Error in code " ++ show code ++ ": " ++ msg)+ Right expr -> pure expr QueryQuote delim code ->- [e| insertCode $(liftByteString (packCode (delim : code ++ [delim]))) |]+ [e| Code $(liftByteString (packCode (delim : code ++ [delim]))) |] QueryOther code ->- [e| insertCode $(liftByteString (packCode code)) |]+ [e| Code $(liftByteString (packCode code)) |] --- | Parse a query string in order to produce a 'QueryBuilder' expression.-parseQuery :: String -> Q Exp-parseQuery code =+-- | Parse a query string in order to produce a 'QueryGenerator' expression.+queryGenE :: String -> Q Exp+queryGenE code = case parseOnly (many querySegment <* endOfInput) (T.strip (T.pack code)) of Left msg -> fail ("Query parser failed: " ++ msg) Right [] ->- [e| buildQuery (pure ()) |]+ [e| mempty |] Right segments ->- [e| buildQuery $(DoE . map NoBindS <$> mapM translateSegment segments) |]+ [e| mconcat $(ListE <$> mapM translateSegment segments) |] --- | Generate queries conveniently. See 'BuildQuery' to find out which types can be produced.-pgsq :: QuasiQuoter-pgsq =+-- | Generate a 'QueryGenerator' expression.+--+-- See "Database.PostgreSQL.Store.Query.TH" for detailed description of the language accepted by+-- this quasi quoter.+--+pgQueryGen :: QuasiQuoter+pgQueryGen = QuasiQuoter {- quoteExp = parseQuery,- quotePat = const (fail "Cannot use 'pgsq' in pattern"),- quoteType = const (fail "Cannot use 'pgsq' in type"),- quoteDec = const (fail "Cannot use 'pgsq' in declaration")+ quoteExp = queryGenE,+ quotePat = const (fail "Cannot use 'pgQueryGen' in pattern"),+ quoteType = const (fail "Cannot use 'pgQueryGen' in type"),+ quoteDec = const (fail "Cannot use 'pgQueryGen' in declaration")+ }++-- |+queryE :: String -> Q Exp+queryE code =+ [e| assemble $(queryGenE code) () |]++-- | Generate a "Query". This utilizes an intermediate query generator of type @QueryGenerator ()@.+--+-- See "Database.PostgreSQL.Store.Query.TH" for detailed description of the language accepted by+-- this quasi quoter.+--+pgQuery :: QuasiQuoter+pgQuery =+ QuasiQuoter {+ quoteExp = queryE,+ quotePat = const (fail "Cannot use 'pgQuery' in pattern"),+ quoteType = const (fail "Cannot use 'pgQuery' in type"),+ quoteDec = const (fail "Cannot use 'pgQuery' in declaration")+ }++-- |+prepQueryE :: String -> Q Exp+prepQueryE code = do+ Loc _ p m _ _ <- location+ withPrefix (B.concat [buildByteString p, "_", buildByteString m, "_"])+ where+ withPrefix prefix =+ [e| assemblePrep $(liftByteString prefix) $(queryGenE code) |]++-- | Generate a "PrepQuery". The intermediate query generator has type @QueryGenerator (Tuple ts)@+-- where @ts@ has kind @[Type]@. @ts@ represents the types of the parameters to this prepared query.+--+-- It is highly recommended that supply a type signature, if you give the resulting expression a+-- name, to avoid ambiguity.+--+-- > q :: PrepQuery '[Int, String] User+-- > q = [pgPrepQuery| SELECT #User(u) FROM @User u WHERE age < $(param0) AND name LIKE $(param1) |]+--+-- See "Database.PostgreSQL.Store.Query.TH" for detailed description of the language accepted by+-- this quasi quoter.+--+pgPrepQuery :: QuasiQuoter+pgPrepQuery =+ QuasiQuoter {+ quoteExp = prepQueryE,+ quotePat = const (fail "Cannot use 'pgPrepQuery' in pattern"),+ quoteType = const (fail "Cannot use 'pgPrepQuery' in type"),+ quoteDec = const (fail "Cannot use 'pgPrepQuery' in declaration") }
src/Database/PostgreSQL/Store/RowParser.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds,+ RankNTypes,+ KindSignatures,+ TypeOperators,+ TypeApplications,+ ScopedTypeVariables #-} -- | -- Module: Database.PostgreSQL.Store.RowParser@@ -6,40 +11,41 @@ -- License: BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.RowParser (- -- * Row Parser+ -- * Row parser RowParser, RowErrorLocation (..), RowErrorDetail (..), RowError (..), - rowNumber,- columnNumber,- columnsLeft,-- fetchColumn,- peekColumn,- parseColumn,+ processResultWith, - peekContents,- fetchContents,- parseContents,+ -- * Means of composition+ (>>=$),+ (>>$),+ (<*>$),+ finish,+ cancel, - skipColumn,+ skipColumns,+ nonNullCheck, - -- * Result Parser- parseResult+ -- * Default parsers+ processContent,+ retrieveColumn,+ retrieveContent ) where -import Control.Monad+import GHC.TypeLits+ import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State.Strict -import qualified Data.ByteString as B+import Data.Proxy+import qualified Data.ByteString as B -import qualified Database.PostgreSQL.LibPQ as P import Database.PostgreSQL.Store.Types +import qualified Database.PostgreSQL.LibPQ as P+ -- | Location of an error data RowErrorLocation = RowErrorLocation P.Column P.Row deriving (Show, Eq, Ord)@@ -48,128 +54,92 @@ data RowErrorDetail = TooFewColumns -- ^ Underlying 'RowParser' wants more columns than are currently present.- | ColumnRejected TypedValue+ | ColumnRejected -- ^ A column value could not be parsed.- | ContentsRejected (Maybe B.ByteString)- -- ^ The contents of a column could not be parsed. deriving (Show, Eq, Ord) --- | An error that occured when parsing a row.+-- | An error that occured when parsing a row data RowError = RowError RowErrorLocation RowErrorDetail deriving (Show, Eq, Ord) --- | Static result information-data ResultInfo = ResultInfo P.Result -- Result to operate on- P.Column -- Total number of columns---- | Static row information-data RowInput = RowInput ResultInfo -- Result info- P.Row -- Current row to operate on---- | Row parser-newtype RowParser a =- RowParser (ReaderT RowInput (StateT P.Column (ExceptT RowError IO)) a)- deriving (Functor, Applicative, Monad, MonadError RowError)+-- | Shortcut for the internal monad transformer inside 'RowParser'+type M = ExceptT RowError IO --- | Parse a single row.-parseRow :: RowParser a -> RowInput -> ExceptT RowError IO a-parseRow (RowParser parser) rowInfo =- evalStateT (runReaderT parser rowInfo) (P.Col 0)+-- | Consumes @w@ columns of a result set row in order to produce an instance of @a@.+newtype RowParser (w :: Nat) a = RowParser { runProcessor :: P.Result -> P.Row -> P.Column -> M a } --- | Retrieve the current row number.-rowNumber :: RowParser P.Row-rowNumber = RowParser (asks (\ (RowInput _ row) -> row))+instance Functor (RowParser w) where+ fmap f (RowParser action) =+ RowParser (\ result row col -> f <$> action result row col) --- | Retrieve the current column number.-columnNumber :: RowParser P.Column-columnNumber = RowParser get+-- | Process the each row of the 'P.Result' with the given 'RowParser'.+processResultWith :: forall a n. (KnownNat n) => P.Result -> RowParser n a -> ExceptT RowError IO [a]+processResultWith result (RowParser run) = do+ cols <- lift (P.nfields result)+ when (cols < toEnum totalWidth) $+ throwError (RowError (RowErrorLocation 0 0) TooFewColumns) --- | Retrieve the number of columns left.-columnsLeft :: RowParser P.Column-columnsLeft = RowParser $ do- RowInput (ResultInfo _ numCols) _ <- ask- curCol <- get- pure (numCols - curCol)+ rows <- lift (P.ntuples result)+ forM [0 .. rows - 1] (\ row -> run result row 0)+ where+ totalWidth = fromIntegral (natVal @n Proxy) --- | Advance to next column without checking.-nextColumn :: RowParser ()-nextColumn =- RowParser (modify (+ 1))+-- | Terminate the parsing tree by returning the final result.+finish :: a -> RowParser 0 a+finish x = RowParser (\ _ _ _ -> pure x) --- | Do something with the underlying result, row number and column number.-withColumn :: (P.Result -> P.Row -> P.Column -> RowParser a) -> RowParser a-withColumn action = do- (RowInput (ResultInfo result numColumns) row, col) <- RowParser ((,) <$> ask <*> get)+-- | Terminate the parsing tree with an error.+cancel :: RowErrorDetail -> RowParser 0 a+cancel detail = RowParser (\ _ row col -> throwError (RowError (RowErrorLocation col row) detail)) - if col < numColumns then- action result row col- else- throwError (RowError (RowErrorLocation col row) TooFewColumns)+infixl 1 >>=$ --- | Fetch the 'TypedValue' associated with the current cell without advancing the cursor.-peekColumn :: RowParser TypedValue-peekColumn =- withColumn $ \ result row col -> RowParser $ liftIO $- TypedValue <$> P.ftype result col- <*> fmap (fmap Value) (P.getvalue' result row col)+-- | Transform the result of another 'RowParser'. Similar to monadic bind. Also keeps track+-- of how many columns are needed in total.+(>>=$) :: forall a v b w. (KnownNat v)+ => RowParser v a -> (a -> RowParser w b) -> RowParser (v + w) b+proc >>=$ func =+ RowParser $ \ result row col -> do+ x <- runProcessor proc result row col :: M a+ runProcessor (func x) result row (col + fromIntegral (natVal @v Proxy)) --- | Fetch the type 'Oid' and value of the current cell. Also advances the cell cursor to the next--- column.-fetchColumn :: RowParser TypedValue-fetchColumn =- peekColumn <* nextColumn+infixl 1 >>$ --- | Fetch a column and parse it. Returning 'Nothing' from the provided parser function will cause--- a 'ColumnRejected' to be raised. Advances the cell cursor to the next column.-parseColumn :: (TypedValue -> Maybe a) -> RowParser a-parseColumn proc = do- typedValue <- peekColumn- case proc typedValue of- Just x -> x <$ nextColumn- Nothing -> do- col <- columnNumber- row <- rowNumber- throwError (RowError (RowErrorLocation col row) (ColumnRejected typedValue))+-- | Chain two 'RowParser's, but discard the result of the first.+(>>$) :: forall a v b w. (KnownNat v)+ => RowParser v a -> RowParser w b -> RowParser (v + w) b+p1 >>$ p2 = p1 >>=$ const p2 --- | Fetch the cell's contents without moving the cell cursor.-peekContents :: RowParser (Maybe B.ByteString)-peekContents =- withColumn (\ result row col -> RowParser (liftIO (P.getvalue' result row col)))+infixl 4 <*>$ --- | Like 'peekContents' but moves the cell cursor to the next column.-fetchContents :: RowParser (Maybe B.ByteString)-fetchContents =- peekContents <* nextColumn+-- | Just like the '(<*>)' operator.+(<*>$) :: forall a v b w. (KnownNat v)+ => RowParser v (a -> b) -> RowParser w a -> RowParser (v + w) b+pf <*>$ px = pf >>=$ \ f -> (\ x -> f x) <$> px --- | Parse the contents of a column (only if present). Returning 'Nothing' from the provided parser--- function will raise a 'ContentsRejected'. When the cell is @NULL@, a 'ContentsRejected' is raised--- aswell.-parseContents :: (B.ByteString -> Maybe a) -> RowParser a-parseContents proc = do- value <- peekContents- case value >>= proc of- Just x -> x <$ nextColumn- Nothing -> do- col <- columnNumber- row <- rowNumber- throwError (RowError (RowErrorLocation col row) (ContentsRejected value))+-- | Skip a number of columns.+skipColumns :: RowParser n ()+skipColumns = RowParser (\ _ _ _ -> pure ()) --- | Point cursor to the next column.-skipColumn :: RowParser ()-skipColumn = do- (RowInput (ResultInfo _ numColumns) row, col) <- RowParser ((,) <$> ask <*> get)+-- | Check if the following n columns are not @NULL@.+nonNullCheck :: Int -> RowParser 0 Bool+nonNullCheck n =+ RowParser $ \ result row col ->+ not . or <$> lift (forM [col .. col + (toEnum n - 1)] (P.getisnull result row)) - if col < numColumns then- nextColumn- else- throwError (RowError (RowErrorLocation col row) TooFewColumns)+-- | Process the contents of a column.+processContent :: (Oid -> Maybe B.ByteString -> Maybe a) -> RowParser 1 a+processContent proc =+ RowParser $ \ result row col -> do+ res <- lift (proc <$> P.ftype result col <*> P.getvalue' result row col)+ case res of+ Just cnt -> pure cnt+ Nothing -> throwError (RowError (RowErrorLocation col row) ColumnRejected) --- | Parse the result.-parseResult :: P.Result -> RowParser a -> ExceptT RowError IO [a]-parseResult result parser = do- (resultInfo, numRows) <- liftIO $ do- numColumns <- P.nfields result- numRows <- P.ntuples result- pure (ResultInfo result numColumns, numRows)+-- | Retrieve a column's type and content.+retrieveColumn :: RowParser 1 (Oid, Maybe B.ByteString)+retrieveColumn = processContent (\ a b -> Just (a, b)) - forM [0 .. numRows - 1] (parseRow parser . RowInput resultInfo)+-- | Retrieve a column's content.+retrieveContent :: RowParser 1 B.ByteString+retrieveContent = processContent (const id)
src/Database/PostgreSQL/Store/Table.hs view
@@ -9,7 +9,8 @@ UndecidableInstances, ScopedTypeVariables, QuasiQuotes,- DefaultSignatures+ DefaultSignatures,+ TypeApplications #-} -- |@@ -18,18 +19,13 @@ -- License: BSD3 -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Table (- -- * Columns- Column (..),- ColumnType (..),- ColumnEntity (..),- -- * Table Table (..), TableEntity (..),- buildTableSchema, - insertColumns,- insertColumnsOn,+ genTableName,+ genTableColumns,+ genTableColumnsOn, GenericTable, describeGenericTable,@@ -50,16 +46,14 @@ import GHC.Generics import GHC.TypeLits -import Control.Monad- import Data.Kind import Data.Proxy+import Data.Tagged import qualified Data.ByteString as B import Database.PostgreSQL.Store.Entity import Database.PostgreSQL.Store.Utilities-import Database.PostgreSQL.Store.ColumnEntity import Database.PostgreSQL.Store.Query.Builder -- | Type-level description of a record@@ -67,29 +61,18 @@ = TCombine KColumns KColumns | TSelector Symbol Type --- | Desciption of a column-data Column = Column {- -- | Column name- colName :: B.ByteString,-- -- | Column type- colType :: ColumnType-}- -- | Provide the means to demote 'KColumns' to a value. class GColumns (rec :: KColumns) where -- | Instantiate singleton- gDescribeColumns :: proxy rec -> [Column]+ gDescribeColumns :: Tagged rec [B.ByteString] -instance (KnownSymbol name, ColumnEntity typ) => GColumns ('TSelector name typ) where- gDescribeColumns _ =- [Column (buildByteString (symbolVal (Proxy :: Proxy name)))- (describeColumnType (Proxy :: Proxy typ))]+instance (KnownSymbol name) => GColumns ('TSelector name typ) where+ gDescribeColumns =+ Tagged [buildByteString (symbolVal @name Proxy)] instance (GColumns lhs, GColumns rhs) => GColumns ('TCombine lhs rhs) where- gDescribeColumns _ =- gDescribeColumns (Proxy :: Proxy lhs)- ++ gDescribeColumns (Proxy :: Proxy rhs)+ gDescribeColumns =+ Tagged (untag (gDescribeColumns @lhs) ++ untag (gDescribeColumns @rhs)) -- | Check the 'Generic' representation of a record in order to generate an instance of 'KColumns'. type family AnalyzeRecordRep org (rec :: * -> *) :: KColumns where@@ -130,18 +113,18 @@ tableName :: B.ByteString, -- | Table columns- tableCols :: [Column]-}+ tableCols :: [B.ByteString]+} deriving (Show, Eq, Ord) -- | Provide the means to demote 'KTable' to a value. class GTable (tbl :: KTable) where -- | Instantiate singleton- gDescribeTable :: proxy tbl -> Table+ gDescribeTable :: Tagged tbl Table instance (KnownSymbol name, GColumns cols) => GTable ('TTable name cols) where- gDescribeTable _ =- Table (buildByteString (symbolVal (Proxy :: Proxy name)))- (gDescribeColumns (Proxy :: Proxy cols))+ gDescribeTable =+ Tagged (Table (buildByteString (symbolVal @name Proxy))+ (untag (gDescribeColumns @cols))) -- | Check the 'Generic' representation of a data type in order to generate an instance of 'KTable'. type family AnalyzeTableRep org (dat :: * -> *) :: KTable where@@ -169,60 +152,29 @@ type GenericTable a = (Generic a, GTable (AnalyzeTable a)) -- | Fetch the table description for a generic table type.-describeGenericTable :: (GenericTable a) => proxy a -> Table-describeGenericTable proxy =- gDescribeTable ((const Proxy :: proxy a -> Proxy (AnalyzeTable a)) proxy)+describeGenericTable :: forall a. (GenericTable a) => Tagged a Table+describeGenericTable =+ retag (gDescribeTable @(AnalyzeTable a)) --- | Classify a type which can be used as a table.+-- | Table entity with extra information about its name and column names class (Entity a) => TableEntity a where -- | Describe the table type.- describeTableType :: proxy a -> Table+ describeTableType :: Tagged a Table - default describeTableType :: (GenericTable a) => proxy a -> Table+ default describeTableType :: (GenericTable a) => Tagged a Table describeTableType = describeGenericTable --- | Build SQL code which describes the column.-buildColumn :: Column -> QueryBuilder-buildColumn (Column name (ColumnType typeName notNull mbCheck)) = do- insertName name- insertCode " "- insertName typeName-- when notNull (insertCode " NOT NULL")-- case mbCheck of- Just gen -> do- insertCode " CHECK("- gen name- insertCode ")"-- Nothing -> pure ()---- | Build the SQL code which describes and creates the table.-buildTableSchema :: Table -> QueryBuilder-buildTableSchema (Table name cols) = do- insertCode "CREATE TABLE IF NOT EXISTS "- insertName name- insertCode "("- insertCommaSeperated (map buildColumn cols)- insertCode ")"+-- | Embed table name.+genTableName :: Table -> QueryGenerator a+genTableName (Table name _) =+ genIdentifier name --- | Insert a comma-seperated list of the fully qualified column names of a table.-insertColumns :: Table -> QueryBuilder-insertColumns (Table name cols) =- insertCommaSeperated (map insertColumn cols)- where- insertColumn (Column colName _) = do- insertName name- insertCode "."- insertName colName+-- | Embed a comma-seperated list of the table's columns.+genTableColumns :: Table -> QueryGenerator a+genTableColumns (Table name columns) =+ joinGens (B.singleton 44) (map (genNestedIdentifier name) columns) --- | Similar to 'insertColumns', but instead it expands the column names on an alias.-insertColumnsOn :: Table -> B.ByteString -> QueryBuilder-insertColumnsOn (Table _ cols) name =- insertCommaSeperated (map insertColumn cols)- where- insertColumn (Column colName _) = do- insertName name- insertCode "."- insertName colName+-- | Same as 'genTableColumns' but expands the columns on an alias of the table name.+genTableColumnsOn :: Table -> B.ByteString -> QueryGenerator a+genTableColumnsOn (Table _ columns) name =+ joinGens (B.singleton 44) (map (genNestedIdentifier name) columns)
+ src/Database/PostgreSQL/Store/Tuple.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE GADTs,+ TypeFamilies,+ TypeOperators,+ TypeApplications,+ ScopedTypeVariables,+ MultiParamTypeClasses,+ RankNTypes,+ DataKinds,+ PolyKinds,+ ConstraintKinds,+ FlexibleContexts,+ FlexibleInstances,+ UndecidableInstances,+ FunctionalDependencies,+ BangPatterns,+ StandaloneDeriving+#-}++-- |+-- Module: Database.PostgreSQL.Store.Tuple+-- Copyright: (c) Ole Krüger 2016+-- License: BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Tuple (+ Tuple (..),+ appendElement,++ HasElement,+ getElementN,+ getElement0,+ getElement1,+ getElement2,+ getElement3,+ getElement4,+ getElement5,+ getElement6,+ getElement7,+ getElement8,+ getElement9,++ FunctionType,+ WithTuple,+ withTuple+) where++import GHC.TypeLits++import Data.List+import Data.Kind+import Data.Tagged++-- | Append a single element to the end of a list.+type family (|>) (x :: [a]) (y :: a) :: [a] where+ '[] |> y = '[y]+ (x ': xs) |> y = x ': (xs |> y)++infixl 5 |>++-- | Generic product type+data Tuple (ts :: [Type]) where+ Empty :: Tuple '[]+ Cons :: t -> !(Tuple ts) -> Tuple (t ': ts)++-- | Helper class for the @Show (Tuple ts)@ instance+class ShowElement ts where+ gatherShown :: Tuple ts -> [String]++-- | Nothing to show+instance ShowElement '[] where+ gatherShown _ = []++-- | Show all elements, starting with the first+instance (Show t, ShowElement ts) => ShowElement (t ': ts) where+ gatherShown (Cons x rest) = show x : gatherShown rest++instance (ShowElement ts) => Show (Tuple ts) where+ show params = concat ["(", intercalate ", " (gatherShown params), ")"]++-- | Helper class to extract an element from a 'Tuple'.+class HasElement (n :: Nat) (ts :: [Type]) r | n ts -> r where+ -- | Extract the @n@-th element from the product.+ getElementN :: Tuple ts -> Tagged n r++-- | Extract head element+instance HasElement 0 (t ': ts) t where+ getElementN (Cons x _) = Tagged x++ {-# INLINE getElementN #-}++-- | Extract element that is not the head+instance {-# OVERLAPPABLE #-} (1 <= n, HasElement (n - 1) ts r) => HasElement n (t ': ts) r where+ getElementN (Cons _ !xs) = retag (getElementN xs :: Tagged (n - 1) r)++ {-# INLINE getElementN #-}++-- | Extract element at index @0@.+getElement0 :: Tuple (r ': ts) -> r+getElement0 p = untag (getElementN @0 p)++-- | Extract element at index @1@.+getElement1 :: Tuple (t0 ': r ': ts) -> r+getElement1 p = untag (getElementN @1 p)++-- | Extract element at index @2@.+getElement2 :: Tuple (t0 ': t1 ': r ': ts) -> r+getElement2 p = untag (getElementN @2 p)++-- | Extract element at index @3@.+getElement3 :: Tuple (t0 ': t1 ': t2 ': r ': ts) -> r+getElement3 p = untag (getElementN @3 p)++-- | Extract element at index @4@.+getElement4 :: Tuple (t0 ': t1 ': t2 ': t3 ': r ': ts) -> r+getElement4 p = untag (getElementN @4 p)++-- | Extract element at index @5@.+getElement5 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': r ': ts) -> r+getElement5 p = untag (getElementN @5 p)++-- | Extract element at index @6@.+getElement6 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': r ': ts) -> r+getElement6 p = untag (getElementN @6 p)++-- | Extract element at index @7@.+getElement7 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': r ': ts) -> r+getElement7 p = untag (getElementN @7 p)++-- | Extract element at index @8@.+getElement8 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': r ': ts) -> r+getElement8 p = untag (getElementN @8 p)++-- | Extract element at index @9@.+getElement9 :: Tuple (t0 ': t1 ': t2 ': t3 ': t4 ': t5 ': t6 ': t7 ': t8 ': r ': ts) -> r+getElement9 p = untag (getElementN @9 p)++-- | Append an element to the end.+class AppendElement ts where+ appendElement :: Tuple ts -> t -> Tuple (ts |> t)++-- | Append to empty product.+instance AppendElement '[] where+ appendElement = flip Cons++ {-# INLINE appendElement #-}++-- | Append to non-empty product.+instance (AppendElement ts) => AppendElement (t ': ts) where+ appendElement (Cons y ys) x = Cons y (appendElement ys x)++ {-# INLINE appendElement #-}++-- | Do something with a 'Tuple'.+class ConsTuple ts a r | ts r -> a where+ consTuple :: Tuple ts -> a -> r++-- | Apply the given function to the current 'Tuple' state.+instance ConsTuple ts (Tuple ts -> r) r where+ consTuple state f = f state++-- | Collect and append product element, then continue.+instance (AppendElement ts, ConsTuple (ts |> t) a r) => ConsTuple ts a (t -> r) where+ consTuple state val x = consTuple (appendElement state x) val++-- | Build a function type using the given parameter types and return type.+type family FunctionType (ps :: [Type]) r where+ FunctionType '[] r = r+ FunctionType (p ': ps) r = p -> FunctionType ps r++-- | A value of type @r@ can be created using an instance of @Tuple ts@.+type WithTuple ts r = ConsTuple '[] (Tuple ts -> r) (FunctionType ts r)++-- | Collect values to construct a @Tuple ts@, then apply the given function to it.+withTuple :: (WithTuple ts r) => (Tuple ts -> r) -> FunctionType ts r+withTuple = consTuple Empty
src/Database/PostgreSQL/Store/Types.hs view
@@ -5,24 +5,57 @@ -- Maintainer: Ole Krüger <ole@vprsm.de> module Database.PostgreSQL.Store.Types ( -- * General- Value (..),- TypedValue (..),- Query (..)+ Statement (..),+ Query (..),+ PrepQuery (..),++ toParam,+ toTypedParam,++ Oid (..),+ Format ) where -import qualified Data.ByteString as B-import qualified Database.PostgreSQL.LibPQ as P+import Text.Show.Functions () --- | Value of a cell in the result set-newtype Value = Value { valueData :: B.ByteString }- deriving (Show, Eq, Ord)+import qualified Data.ByteString as B --- | Value and type 'P.Oid' of a cell in the result set-data TypedValue = TypedValue P.Oid (Maybe Value)+import Database.PostgreSQL.Store.Tuple++import Database.PostgreSQL.LibPQ (Oid (..), Format (Text))++-- | SQL statement+newtype Statement a = Statement B.ByteString deriving (Show, Eq, Ord) --- | Query+-- | Query object data Query a = Query {+ -- | SQL statement queryStatement :: B.ByteString,- queryParams :: [TypedValue]++ -- | Parameters+ queryParams :: [Maybe (Oid, B.ByteString, Format)] } deriving (Show, Eq, Ord)++-- | Preparable query object+data PrepQuery ts a = PrepQuery {+ -- | Name of the prepared statement+ prepName :: B.ByteString,++ -- | SQL statement+ prepStatement :: B.ByteString,++ -- | Parameter type hints+ prepOids :: [Oid],++ -- | Parameter generator+ prepParams :: Tuple ts -> [Maybe (B.ByteString, Format)]+} deriving (Show)++-- | Attach 'Text' tag.+toParam :: B.ByteString -> (B.ByteString, Format)+toParam dat = (dat, Text)++-- | Attach 'Text' tag.+toTypedParam :: Oid -> B.ByteString -> (Oid, B.ByteString, Format)+toTypedParam typ dat = (typ, dat, Text)
src/Database/PostgreSQL/Store/Utilities.hs view
@@ -41,4 +41,7 @@ -- | Lift 'ByteString'. liftByteString :: B.ByteString -> Q Exp liftByteString bs =- [e| B.pack $(lift (B.unpack bs)) |]+ case B.unpack bs of+ [] -> [e| B.empty |]+ [x] -> [e| B.singleton x |]+ xs -> [e| B.pack $(lift xs) |]
+ tests/Entities.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TypeApplications, FlexibleContexts #-}++module Main (main) where++import Control.Monad.Trans++import Data.Int+import Data.Word+import Numeric.Natural+import Data.Scientific++import Data.Maybe+import Data.String++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.Framework+import Test.Framework.Providers.QuickCheck2++import qualified Database.PostgreSQL.LibPQ as P++import Database.PostgreSQL.Store.Entity+import Database.PostgreSQL.Store.Errand+import Database.PostgreSQL.Store.Query++import System.Environment++instance Arbitrary B.ByteString where+ arbitrary = B.pack <$> arbitrary++ shrink bs+ | B.null bs = [bs]+ | otherwise = B.tail bs : shrink (B.tail bs)++instance Arbitrary BL.ByteString where+ arbitrary = BL.pack <$> arbitrary++ shrink bs+ | BL.null bs = [bs]+ | otherwise = BL.tail bs : shrink (BL.tail bs)++instance Arbitrary T.Text where+ arbitrary = T.pack <$> arbitrary++ shrink bs+ | T.null bs = [bs]+ | otherwise = T.tail bs : shrink (T.tail bs)++instance Arbitrary TL.Text where+ arbitrary = TL.pack <$> arbitrary++ shrink bs+ | TL.null bs = [bs]+ | otherwise = TL.tail bs : shrink (TL.tail bs)++instance Arbitrary Scientific where+ arbitrary = scientific <$> arbitrary <*> arbitrary++-- |+testEntity :: (Entity a, Eq a, Show a) => P.Connection -> a -> Property+testEntity db x = monadicIO $ do+ result <- lift (runErrand db (query [pgQuery| SELECT $x |]))+ elem <- case result of+ Left err -> fail ("ErrandError: " ++ show err)+ Right [x] -> pure x+ Right xs -> fail ("Weird result: " ++ show xs)++ stop (elem === x)++-- |+testEntityWith :: (Entity a, Eq a, Show a) => P.Connection -> (a -> a) -> a -> Property+testEntityWith db f x =+ testEntity db (f x)++-- |+filterStringNulls :: String -> String+filterStringNulls = filter (/= '\NUL')++-- |+filterTextNulls :: T.Text -> T.Text+filterTextNulls x = T.concat (T.split (== '\NUL') x)++-- |+filterLazyTextNulls :: TL.Text -> TL.Text+filterLazyTextNulls x = TL.concat (TL.split (== '\NUL') x)++-- | Test entry point+main :: IO ()+main = do+ pgInfo <- lookupEnv "PGINFO"+ db <- P.connectdb (fromString (fromMaybe "user=pgstore dbname=pgstore" pgInfo))++ defaultMain+ [+ testProperty "entity-bool" (testEntity @Bool db),++ testProperty "entity-integer" (testEntity @Integer db),+ testProperty "entity-int" (testEntity @Int db),+ testProperty "entity-int8" (testEntity @Int8 db),+ testProperty "entity-int16" (testEntity @Int16 db),+ testProperty "entity-int32" (testEntity @Int32 db),+ testProperty "entity-int64" (testEntity @Int64 db),++ testProperty "entity-natural" (testEntity @Natural db),+ testProperty "entity-word" (testEntity @Word db),+ testProperty "entity-word8" (testEntity @Word8 db),+ testProperty "entity-word16" (testEntity @Word16 db),+ testProperty "entity-word32" (testEntity @Word32 db),+ testProperty "entity-word64" (testEntity @Word64 db),++ testProperty "entity-float" (testEntity @Float db),+ testProperty "entity-double" (testEntity @Double db),++ testProperty "entity-scientific" (testEntity @Scientific db),++ testProperty "entity-bytestring" (testEntity @B.ByteString db),+ testProperty "entity-bytestring-lazy" (testEntity @BL.ByteString db),+ testProperty "entity-string" (testEntityWith @String db filterStringNulls),+ testProperty "entity-text" (testEntityWith @T.Text db filterTextNulls),+ testProperty "entity-text-lazy" (testEntityWith @TL.Text db filterLazyTextNulls)+ ]