diff --git a/pg-store.cabal b/pg-store.cabal --- a/pg-store.cabal +++ b/pg-store.cabal @@ -1,5 +1,5 @@ name: pg-store -version: 0.1.1 +version: 0.2 category: Database synopsis: Simple storage interface to PostgreSQL description: Simple storage interface to PostgreSQL @@ -21,24 +21,18 @@ default-language: Haskell2010 build-depends: base >= 4.9 && < 5, template-haskell >= 2.11 && < 3, - bytestring, text, postgresql-libpq, attoparsec, mtl, time + bytestring, blaze-builder, text, postgresql-libpq, attoparsec, mtl, time, + haskell-src-meta, aeson, scientific hs-source-dirs: src - exposed-modules: Database.PostgreSQL.Store.Result, - Database.PostgreSQL.Store.Columns, - Database.PostgreSQL.Store.Query, - Database.PostgreSQL.Store.Errand, - Database.PostgreSQL.Store.Table, - Database.PostgreSQL.Store.OIDs, + exposed-modules: Database.PostgreSQL.Store.RowParser + Database.PostgreSQL.Store.Errand + 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 - -test-suite tests - type: exitcode-stdio-1.0 - ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-tabs -fno-warn-name-shadowing - default-language: Haskell2010 - build-depends: base, pg-store, hspec, QuickCheck, bytestring, text, postgresql-libpq, mtl - hs-source-dirs: tests - other-modules: Test.Database.PostgreSQL.Store.Query, - Test.Database.PostgreSQL.Store.Columns, - Test.Database.PostgreSQL.Store.Table, - Test.Database.PostgreSQL.Store - main-is: Main.hs + other-modules: Database.PostgreSQL.Store.Utilities diff --git a/src/Database/PostgreSQL/Store.hs b/src/Database/PostgreSQL/Store.hs --- a/src/Database/PostgreSQL/Store.hs +++ b/src/Database/PostgreSQL/Store.hs @@ -1,52 +1,54 @@ -- | -- Module: Database.PostgreSQL.Store --- Copyright: (c) Ole Krüger 2015-2016 +-- Copyright: (c) Ole Krüger 2016 -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store ( - -- * Errands + -- * Errand Errand, - ErrandError (..), - ErrorCode (..), - ExecStatus (..), runErrand, + execute, + execute', query, - query_, queryWith, - -- * Queries + insert, + insertMany, + deleteAll, + findAll, + create, + + -- * Query Query (..), pgsq, - pgss, - - QueryTable (..), - SelectorElement (..), - - -- * Values - Value (..), - Column (..), - - -- * Results - Result (..), - ResultProcessor, - ResultError (..), - skipColumn, - unpackColumn, + castQuery, - Single (..), - Reference (..), + -- * Entity + Entity (..), -- * Tables + TableEntity (..), + ColumnEntity (..), + Table (..), - mkCreateQuery, + ColumnType (..), + Column (..), - mkTable, - TableConstraint (..) + -- * Errors + ErrandError (..), + ErrorCode (..), + P.ExecStatus, + RowError (..), + RowErrorLocation (..), + RowErrorDetail (..) ) where -import Database.PostgreSQL.Store.Columns -import Database.PostgreSQL.Store.Errand -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Result -import Database.PostgreSQL.Store.Table +import Database.PostgreSQL.Store.Types +import Database.PostgreSQL.Store.Query +import Database.PostgreSQL.Store.Table +import Database.PostgreSQL.Store.Entity +import Database.PostgreSQL.Store.RowParser +import Database.PostgreSQL.Store.Errand + +import qualified Database.PostgreSQL.LibPQ as P diff --git a/src/Database/PostgreSQL/Store/ColumnEntity.hs b/src/Database/PostgreSQL/Store/ColumnEntity.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/ColumnEntity.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} + +-- | +-- Module: Database.PostgreSQL.Store.ColumnEntity +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +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 diff --git a/src/Database/PostgreSQL/Store/Columns.hs b/src/Database/PostgreSQL/Store/Columns.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Store/Columns.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, TemplateHaskell #-} - --- | --- Module: Database.PostgreSQL.Store.Columns --- Copyright: (c) Ole Krüger 2015-2016 --- License: BSD3 --- Maintainer: Ole Krüger -module Database.PostgreSQL.Store.Columns ( - -- * - Value (..), - - -- * - Column (..) -) where - -import Data.Int -import Data.Word -import Data.Bits -import Data.Time -import Data.Monoid -import Data.Typeable -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Builder -import Data.Attoparsec.ByteString -import Data.Attoparsec.ByteString.Char8 (signed, decimal) - -import Database.PostgreSQL.LibPQ (Oid) -import qualified Database.PostgreSQL.Store.OIDs as OID - --- | Query parameter or value of a column - see 'pack' on how to generate 'Value's manually but --- conveniently. -data Value - = Value { - -- | Type object identifier - valueType :: Oid, - - -- | Data value - valueData :: B.ByteString - } - | NullValue - deriving (Show, Eq, Ord) - --- | Types which implement this type class may be used as column types. -class Column a where - -- | Pack column value. - pack :: a -> Value - - -- | Unpack column value. - unpack :: Value -> Maybe a - - -- | Name of the underlying SQL type. - columnTypeName :: Proxy a -> String - - -- | May the column be NULL? - columnAllowNull :: Proxy a -> Bool - columnAllowNull _proxy = False - - -- | A condition that must hold true for the column. - columnCheck :: Proxy a -> String -> Maybe String - columnCheck _proxy _identifier = Nothing - - -- | Generate column description in SQL. Think @CREATE TABLE@. - columnDescription :: Proxy a -> String -> String - columnDescription proxy identifier = - identifier ++ " " ++ - columnTypeName proxy ++ - if columnAllowNull proxy then "" else " NOT NULL" ++ - case columnCheck proxy identifier of - Just stmt -> " CHECK (" ++ stmt ++ ")" - Nothing -> "" - -instance Column Value where - pack = id - unpack = Just - columnTypeName _ = "blob" - -instance (Column a) => Column (Maybe a) where - pack = maybe NullValue pack - - unpack NullValue = Just Nothing - unpack val = Just <$> unpack val - - columnTypeName proxy = columnTypeName ((const Proxy :: Proxy (Maybe b) -> Proxy b) proxy) - columnAllowNull _ = True - columnCheck proxy = columnCheck ((const Proxy :: Proxy (Maybe b) -> Proxy b) proxy) - -instance Column Bool where - pack True = Value $(OID.bool) "true" - pack _ = Value $(OID.bool) "false" - - unpack (Value $(OID.bool) "true") = Just True - unpack (Value $(OID.bool) "TRUE") = Just True - unpack (Value $(OID.bool) "t" ) = Just True - unpack (Value $(OID.bool) "y" ) = Just True - unpack (Value $(OID.bool) "yes" ) = Just True - unpack (Value $(OID.bool) "YES" ) = Just True - unpack (Value $(OID.bool) "on" ) = Just True - unpack (Value $(OID.bool) "ON" ) = Just True - unpack (Value $(OID.bool) "1" ) = Just True - unpack (Value $(OID.bool) _ ) = Just False - unpack _ = Nothing - - columnTypeName _ = "bool" - -instance Column Int where - pack n = Value $(OID.int8) (buildByteString intDec n) - - unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat - unpack _ = Nothing - - columnTypeName _ = "int8" - - columnCheck _ nm = - Just (nm ++ " >= " ++ show (minBound :: Int) ++ - " AND " ++ - nm ++ " <= " ++ show (maxBound :: Int)) - -instance Column Int8 where - pack n = Value $(OID.int2) (buildByteString int8Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat - unpack _ = Nothing - - columnTypeName _ = "int2" - -instance Column Int16 where - pack n = Value $(OID.int2) (buildByteString int16Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat - unpack _ = Nothing - - columnTypeName _ = "int2" - -instance Column Int32 where - pack n = Value $(OID.int4) (buildByteString int32Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat - unpack _ = Nothing - - - columnTypeName _ = "int4" - -instance Column Int64 where - pack n = Value $(OID.int8) (buildByteString int64Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat - unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat - unpack _ = Nothing - - columnTypeName _ = "int8" - --- | Does "Word" require to be stored in type "numeric"? -wordRequiresNumeric :: Bool -wordRequiresNumeric = - -- int8 upper bound is 2^63 - 1 (9223372036854775807) - (fromIntegral (maxBound :: Word) :: Integer) > 9223372036854775807 - -instance Column Word where - pack n | wordRequiresNumeric = Value $(OID.numeric) (buildByteString wordDec n) - | otherwise = Value $(OID.int8) (buildByteString wordDec n) - - unpack (Value $(OID.int2) dat) = parseMaybe decimal dat - unpack (Value $(OID.int4) dat) = parseMaybe decimal dat - unpack (Value $(OID.int8) dat) = parseMaybe decimal dat - unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat - unpack _ = Nothing - - columnTypeName _ = if wordRequiresNumeric then "numeric(20, 0)" else "int8" - - columnCheck _ nm = - Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word)) - -instance Column Word8 where - pack n = Value $(OID.int2) (buildByteString word8Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe decimal dat - unpack (Value $(OID.int4) dat) = parseMaybe decimal dat - unpack (Value $(OID.int8) dat) = parseMaybe decimal dat - unpack _ = Nothing - - columnTypeName _ = "int2" - - columnCheck _ nm = - Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word8)) - -instance Column Word16 where - pack n = Value $(OID.int4) (buildByteString word16Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe decimal dat - unpack (Value $(OID.int4) dat) = parseMaybe decimal dat - unpack (Value $(OID.int8) dat) = parseMaybe decimal dat - unpack _ = Nothing - - columnTypeName _ = "int4" - - columnCheck _ nm = - Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word16)) - -instance Column Word32 where - pack n = Value $(OID.int8) (buildByteString word32Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe decimal dat - unpack (Value $(OID.int4) dat) = parseMaybe decimal dat - unpack (Value $(OID.int8) dat) = parseMaybe decimal dat - unpack _ = Nothing - - columnTypeName _ = "bigint" - - columnCheck _ nm = - Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word32)) - -instance Column Word64 where - pack n = Value $(OID.numeric) (buildByteString word64Dec n) - - unpack (Value $(OID.int2) dat) = parseMaybe decimal dat - unpack (Value $(OID.int4) dat) = parseMaybe decimal dat - unpack (Value $(OID.int8) dat) = parseMaybe decimal dat - unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat - unpack _ = Nothing - - columnTypeName _ = "numeric(20, 0)" - - columnCheck _ nm = - Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word64)) - -instance Column Integer where - pack n = Value $(OID.numeric) (buildByteString integerDec n) - - unpack (Value $(OID.int2) dat) = parseMaybe decimal dat - unpack (Value $(OID.int4) dat) = parseMaybe decimal dat - unpack (Value $(OID.int8) dat) = parseMaybe decimal dat - unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat - unpack _ = Nothing - - columnTypeName _ = "numeric" - -instance Column UTCTime where - pack t = Value $(OID.timestamp) (C8.pack (formatTime defaultTimeLocale "%F %T%Q" t)) - - unpack (Value $(OID.timestamp) dat) = - parseTimeM False defaultTimeLocale "%F %T%Q" (C8.unpack dat) - unpack _ = Nothing - - columnTypeName _ = "timestamp" - -instance Column [Char] where - pack str = Value $(OID.text) (buildByteString stringUtf8 str) - - unpack (Value $(OID.varchar) dat) = pure (T.unpack (T.decodeUtf8 dat)) - unpack (Value $(OID.char) dat) = pure (T.unpack (T.decodeUtf8 dat)) - unpack (Value $(OID.text) dat) = pure (T.unpack (T.decodeUtf8 dat)) - unpack _ = Nothing - - columnTypeName _ = "text" - -instance Column T.Text where - pack txt = Value $(OID.text) (T.encodeUtf8 txt) - - unpack (Value $(OID.varchar) dat) = pure (T.decodeUtf8 dat) - unpack (Value $(OID.char) dat) = pure (T.decodeUtf8 dat) - unpack (Value $(OID.text) dat) = pure (T.decodeUtf8 dat) - unpack _ = Nothing - - columnTypeName _ = "text" - -instance Column TL.Text where - pack txt = pack (TL.toStrict txt) - - unpack val = TL.fromStrict <$> unpack val - - columnTypeName _ = columnTypeName (Proxy :: Proxy T.Text) - columnAllowNull _ = columnAllowNull (Proxy :: Proxy T.Text) - columnCheck _ = columnCheck (Proxy :: Proxy T.Text) - -instance Column B.ByteString where - pack bs = Value $(OID.bytea) (encodeByteaHex bs) - - unpack (Value $(OID.varchar) dat) = pure dat - unpack (Value $(OID.char) dat) = pure dat - unpack (Value $(OID.text) dat) = pure dat - unpack (Value $(OID.bytea) dat) = decodeByteaHex dat - unpack _ = Nothing - - columnTypeName _ = "bytea" - -instance Column BL.ByteString where - pack bs = pack (BL.toStrict bs) - - unpack val = BL.fromStrict <$> unpack val - - columnTypeName _ = columnTypeName (Proxy :: Proxy B.ByteString) - columnAllowNull _ = columnAllowNull (Proxy :: Proxy B.ByteString) - columnCheck _ = columnCheck (Proxy :: Proxy B.ByteString) - --- | Produce the two-digit hexadecimal representation of a 8-bit word. -word8ToHex :: Word8 -> B.ByteString -word8ToHex w = - hex (shiftR w 4) <> hex (w .&. 15) - where - hex n = - -- lel - case n of { - 15 -> "F"; 14 -> "E"; 13 -> "D"; 12 -> "C"; 11 -> "B"; - 10 -> "A"; 9 -> "9"; 8 -> "8"; 7 -> "7"; 6 -> "6"; - 5 -> "5"; 4 -> "4"; 3 -> "3"; 2 -> "2"; 1 -> "1"; - _ -> "0" - } - --- | Retrieve 8-bit word from two-digit hexadecimal representation. -hexToWord8 :: B.ByteString -> Word8 -hexToWord8 bs = - case B.unpack bs of - (a : b : _) -> shiftL (unhex a) 4 .|. unhex b - (a : _) -> unhex a - _ -> 0 - where - unhex n = - -- double lel - case n of { - 48 -> 0; 49 -> 1; 50 -> 2; 51 -> 3; 52 -> 4; - 53 -> 5; 54 -> 6; 55 -> 7; 56 -> 8; 57 -> 9; - 65 -> 10; 66 -> 11; 67 -> 12; 68 -> 13; 69 -> 14; - 70 -> 15; 97 -> 10; 98 -> 11; 99 -> 12; 100 -> 13; - 101 -> 14; 102 -> 15; _ -> 0 - } - --- | Unpack a byte array in textual representation. -decodeByteaHex :: B.ByteString -> Maybe B.ByteString -decodeByteaHex bs - | B.length bs >= 2 && mod (B.length bs) 2 == 0 && B.isPrefixOf "\\x" bs = - Just (B.pack (unfoldHex (B.drop 2 bs))) - | otherwise = Nothing - where - unfoldHex "" = [] - unfoldHex bs = hexToWord8 (B.take 2 bs) : unfoldHex (B.drop 2 bs) - --- | Pack textual representation of a byte array. -encodeByteaHex :: B.ByteString -> B.ByteString -encodeByteaHex bs = - "\\x" <> B.concatMap word8ToHex bs - --- | Finish the parsing process. -finishParser :: Result r -> Result r -finishParser (Partial f) = f B.empty -finishParser x = x - --- | Parse a ByteString. -parseMaybe :: Parser a -> B.ByteString -> Maybe a -parseMaybe p i = - maybeResult (finishParser (parse p i)) - --- | Build strict ByteString. -buildByteString :: (a -> Builder) -> a -> B.ByteString -buildByteString f x = - BL.toStrict (toLazyByteString (f x)) diff --git a/src/Database/PostgreSQL/Store/Entity.hs b/src/Database/PostgreSQL/Store/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/Entity.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE OverloadedStrings, + ConstraintKinds, + DataKinds, + DefaultSignatures, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + TypeFamilies, + TypeOperators, + TypeSynonymInstances, + UndecidableInstances +#-} + +-- | +-- Module: Database.PostgreSQL.Store.Entity +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.Entity ( + -- * Result and query entity + Entity (..), + + insertGeneric, + parseGeneric, + + -- * Helpers + 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) + +-- | Generic record entity +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 + +-- | Generic enumeration entity +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 + +-- | Generic entity +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) + +-- | Insert generic entity into the query. +insertGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder +insertGeneric x = + gInsertEntity (fromGenericEntity x) + +-- | Generic 'RowParser' for an entity. +parseGeneric :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a +parseGeneric = + toGenericEntity <$> 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 + + default insertEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => a -> QueryBuilder + insertEntity = insertGeneric + + -- | Retrieve an instance of @a@ from the result set. + parseEntity :: RowParser a + + default parseEntity :: (GenericEntity a, GEntity (AnalyzeEntity a)) => RowParser a + parseEntity = parseGeneric + +-- | 2 result entities in sequence +instance (Entity a, Entity b) => Entity (a, b) + +-- | 3 result entities in sequence +instance (Entity a, Entity b, Entity c) => Entity (a, b, c) + +-- | 4 result entities in sequence +instance (Entity a, Entity b, Entity c, Entity d) => Entity (a, b, c, d) + +-- | 5 result entities in sequence +instance (Entity a, Entity b, Entity c, Entity d, Entity e) => Entity (a, b, c, d, e) + +-- | 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) + +-- | 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) + +-- | 'QueryBuilder' +instance Entity QueryBuilder where + insertEntity = id + + parseEntity = do + colsLeft <- columnsLeft + insertCommaSeperated <$> replicateM (fromEnum colsLeft) (insertTypedValue <$> fetchColumn) + +-- | Untyped column value +instance Entity Value where + insertEntity = insertValue + + parseEntity = parseColumn (\ (TypedValue _ mbValue) -> mbValue) + +-- | Typed column value +instance Entity TypedValue where + insertEntity = insertTypedValue + + parseEntity = fetchColumn + +-- | 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 + + parseEntity = do + TypedValue _ value <- peekColumn + case value of + Nothing -> pure Nothing + _ -> Just <$> parseEntity + + +-- | @boolean@ +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"]) + +-- | Parse a column using the given 'Parser'. +parseContentsWith :: Parser a -> RowParser a +parseContentsWith p = + parseContents (maybeResult . endResult . parse p) + 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))) + +-- | Insert a numeric value. +insertNumericValue :: (Show a) => a -> QueryBuilder +insertNumericValue x = + insertTypedValue_ (Oid 1700) (showByteString x) + +-- | Any integer +instance Entity Integer where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith (signed decimal) + +-- | Any integer +instance Entity Int where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith (signed decimal) + +-- | Any integer +instance Entity Int8 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith (signed decimal) + +-- | Any integer +instance Entity Int16 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith (signed decimal) + +-- | Any integer +instance Entity Int32 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith (signed decimal) + +-- | Any integer +instance Entity Int64 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith (signed decimal) + +-- | Any unsigned integer +instance Entity Natural where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith decimal + +-- | Any unsigned integer +instance Entity Word where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith decimal + +-- | Any unsigned integer +instance Entity Word8 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith decimal + +-- | Any unsigned integer +instance Entity Word16 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith decimal + +-- | Any unsigned integer +instance Entity Word32 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith decimal + +-- | Any unsigned integer +instance Entity Word64 where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith decimal + +-- | Any floating-point number +instance Entity Double where + insertEntity = insertNumericValue + + parseEntity = parseContentsWith double + +-- | Any floating-point number +instance Entity Float where + insertEntity = insertNumericValue + + parseEntity = (realToFrac :: Double -> Float) <$> parseEntity + +-- | Any numeric type +instance Entity Scientific where + insertEntity x = + insertTypedValue_ (Oid 1700) (buildByteString (formatScientific Fixed Nothing x)) + + parseEntity = parseContentsWith scientific + +-- | @char@, @varchar@ or @text@ - UTF-8 encoded +instance Entity String where + insertEntity value = + insertTypedValue_ (Oid 25) (buildByteString value) + + parseEntity = T.unpack <$> parseEntity + +-- | @char@, @varchar@ or @text@ - UTF-8 encoded +instance Entity T.Text where + insertEntity value = + insertTypedValue_ (Oid 25) (T.encodeUtf8 value) + + parseEntity = + parseContents (either (const Nothing) Just . T.decodeUtf8') + +-- | @char@, @varchar@ or @text@ - UTF-8 encoded +instance Entity TL.Text where + insertEntity value = + insertEntity (TL.toStrict value) + + parseEntity = + parseContents (either (const Nothing) Just . TL.decodeUtf8' . BL.fromStrict) + +-- | @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) + + 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) -- 0 - 9 + || (x >= 65 && x <= 70) -- A - Z + || (x >= 97 && x <= 102) -- a - z + + 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 -- x + 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) + +-- | @bytea@ - byte array encoded in hex format +instance Entity BL.ByteString where + insertEntity value = + insertEntity (BL.toStrict value) + + parseEntity = BL.fromStrict <$> parseEntity + +-- | @json@ or @jsonb@ +instance Entity A.Value where + insertEntity value = + insertTypedValue_ (Oid 114) (BL.toStrict (A.encode value)) + + parseEntity = parseContents A.decodeStrict diff --git a/src/Database/PostgreSQL/Store/Errand.hs b/src/Database/PostgreSQL/Store/Errand.hs --- a/src/Database/PostgreSQL/Store/Errand.hs +++ b/src/Database/PostgreSQL/Store/Errand.hs @@ -9,44 +9,49 @@ -- * Errand ErrandError (..), ErrorCode (..), - P.ExecStatus (..), - Errand, + runErrand, execute, + execute', query, - query_, queryWith, - -- * Result parser - Result (..), - Single (..) + insert, + insertMany, + deleteAll, + findAll, + create ) where 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 + import qualified Database.PostgreSQL.LibPQ as P -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Result -import Database.PostgreSQL.Store.Columns +import Database.PostgreSQL.Store.Types +import Database.PostgreSQL.Store.Table +import Database.PostgreSQL.Store.Entity +import Database.PostgreSQL.Store.RowParser +import Database.PostgreSQL.Store.Query.Builder + -- | Error during errand data ErrandError = NoResult -- ^ No 'Result' has been returned. - | EmptyResult - -- ^ Result set is empty. | UserError String -- ^ A user has thrown an error. | ExecError P.ExecStatus ErrorCode B.ByteString B.ByteString B.ByteString -- ^ Query execution failed. - | ResultError ResultError + | ParseError RowError -- ^ Result processing failed. deriving (Show, Eq) @@ -72,15 +77,15 @@ runExceptT (runReaderT errand con) -- | Execute a query and return the internal raw result. -execute :: Query -> Errand P.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 + res <- ExceptT (transformResult <$> P.execParams con statement (map transformParam params) P.Text) status <- lift (P.resultStatus res) case status of - P.CommandOk -> pure res - P.TuplesOk -> pure res + P.CommandOk -> pure res + P.TuplesOk -> pure res + P.SingleTuple -> pure res other -> do (state, msg, detail, hint) <- lift $ @@ -108,64 +113,94 @@ where -- Turn 'Maybe P.Result' into 'Either ErrandError P.Result' - transformResult = maybe (throwError NoResult) pure - - -- Turn 'Value' into 'Maybe (P.Oid, B.ByteString, P.Format)' - transformParam (Value typ dat) = Just (typ, dat, P.Text) - transformParam NullValue = Nothing - --- | Allows you to implement a custom result parser for your type. --- 'mkTable' can implement this for your type. -class Result a where - queryResultProcessor :: ResultProcessor a - --- | Combine result parsers sequencially. -instance (Result a, Result b) => Result (a, b) where - queryResultProcessor = - (,) <$> queryResultProcessor <*> queryResultProcessor + transformResult = + maybe (throwError NoResult) pure -instance (Result a, Result b, Result c) => Result (a, b, c) where - queryResultProcessor = - (,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor + -- Turn 'TypedValue' into 'Maybe (P.Oid, B.ByteString, P.Format)' + transformParam (TypedValue typ mbValue) = + (\ (Value value) -> (typ, value, P.Text)) <$> mbValue -instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where - queryResultProcessor = - (,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor +-- | Same as 'execute' but instead of a 'P.Result' it returns the number of affected rows. +execute' :: Query a -> Errand Int +execute' = + countAffectedRows <=< execute -instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where - queryResultProcessor = - (,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor +-- | Execute a query and process its result set. +query :: (Entity a) => Query a -> Errand [a] +query qry = + queryWith qry parseEntity -instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where - queryResultProcessor = - (,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor +-- | 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))) -instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where - queryResultProcessor = - (,,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor +-- | Counts the rows that have been affected by a query. +countAffectedRows :: P.Result -> Errand Int +countAffectedRows res = do + fmap (\ numTuples -> fromMaybe 0 (numTuples >>= maybeResult . endResult . parse decimal)) + (liftIO (P.cmdTuples res)) + where + endResult (Partial f) = f B.empty + endResult x = x --- | Execute a query and process its result set. -query :: (Result a) => Query -> Errand [a] -query qry = - queryWith qry queryResultProcessor +-- | 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) --- | Execute a query and dismiss its result. -query_ :: Query -> Errand () -query_ qry = - () <$ execute qry +-- | 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) --- | Execute a query and process its result set using the provided result processor. -queryWith :: Query -> ResultProcessor a -> Errand [a] -queryWith qry proc = do - result <- execute qry - Errand (lift (withExceptT ResultError (processResult result proc))) + insertRowValue row = do + insertCode "(" + insertEntity row + insertCode ")" --- | Helper type to capture an single column. -newtype Single a = Single { fromSingle :: a } - deriving (Eq, Ord) +-- | 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 (Show a) => Show (Single a) where - show = show . fromSingle +-- | 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)) -instance (Column a) => Result (Single a) where - queryResultProcessor = Single <$> unpackColumn +-- | Create the given 'Table' type. +create :: (TableEntity a) => proxy a -> Errand () +create proxy = + () <$ execute (buildQuery (buildTableSchema (describeTableType proxy))) diff --git a/src/Database/PostgreSQL/Store/Generics.hs b/src/Database/PostgreSQL/Store/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/Generics.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE ConstraintKinds, + DataKinds, + FlexibleContexts, + FlexibleInstances, + GADTs, + StandaloneDeriving, + TypeFamilies, + TypeOperators, + TypeSynonymInstances, + UndecidableInstances +#-} + +-- | +-- Module: Database.PostgreSQL.Store.Generics +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.Generics ( + -- * Generic Entity + EntityDataType, + GenericEntity, + + toGenericEntity, + fromGenericEntity, + + + -- * Type-Level Information + KRecord (..), + KFlatSum (..), + KDataType (..), + + -- * Mapper classes + GRecord (..), + GFlatSum (..), + GDataType (..), + + Record (..), + FlatSum (..), + DataType (..), + + -- * Analyzers + AnalyzeRecordRep, + AnalyzeFlatSumRep, + AnalyzeDataType, + + AnalyzeEntity +) where + +import GHC.Generics +import GHC.TypeLits + +import Data.Kind + +-- | Information about a record +data KRecord + = TCombine KRecord KRecord + -- ^ Combination of two records + | TSingle Meta Type + -- ^ Single element with meta information and type + +-- | Mappings between a 'Generic' representation and our 'KRecord'-based representation +class GRecord (rec :: KRecord) where + -- | 'Generic' representation + type RecordRep rec :: * -> * + + -- | 'KRecord'-based representation + data Record rec + + -- | From 'Generic' representation + toRecord :: RecordRep rec x -> Record rec + + -- | To 'Generic' representation + fromRecord :: Record rec -> RecordRep rec x + +-- | Single record +instance GRecord ('TSingle meta typ) where + type RecordRep ('TSingle meta typ) = S1 meta (Rec0 typ) + + data Record ('TSingle meta typ) = Single typ + + toRecord (M1 (K1 x)) = Single x + + fromRecord (Single x) = M1 (K1 x) + +deriving instance (Show typ) => Show (Record ('TSingle meta typ)) + +-- | Combination of records +instance (GRecord lhs, GRecord rhs) => GRecord ('TCombine lhs rhs) where + type RecordRep ('TCombine lhs rhs) = RecordRep lhs :*: RecordRep rhs + + data Record ('TCombine lhs rhs) = Combine (Record lhs) (Record rhs) + + toRecord (lhs :*: rhs) = Combine (toRecord lhs) (toRecord rhs) + + fromRecord (Combine lhs rhs) = fromRecord lhs :*: fromRecord rhs + +deriving instance (Show (Record lhs), Show (Record rhs)) => Show (Record ('TCombine lhs rhs)) + +-- | Analyze the 'Generic' representation of the selectors. Make sure it has 1 or more fields. Then +-- transform it into a 'KRecord'. +type family AnalyzeRecordRep org (sel :: * -> *) :: KRecord where + -- Single field + AnalyzeRecordRep org (S1 meta (Rec0 typ)) = + 'TSingle meta typ + + -- Multiple fields + AnalyzeRecordRep org (lhs :*: rhs) = + 'TCombine (AnalyzeRecordRep org lhs) (AnalyzeRecordRep org rhs) + + -- Missing field(s) + AnalyzeRecordRep org U1 = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has one constructor, therefore that constructor must have \ + \at least one field") + + -- Something else + AnalyzeRecordRep org other = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has a constructor with an invalid selector" + ':$$: 'ShowType other) + +-- | Information about the constructors of an enumeration +data KFlatSum + = TChoose KFlatSum KFlatSum + -- ^ Combination of values + | TValue Meta + -- ^ Single value of the enumeration + +-- | Mappings between a 'Generic' representation and our 'KFlatSum'-based representation +class GFlatSum (enum :: KFlatSum) where + -- | 'Generic' representation + type FlatSumRep enum :: * -> * + + -- | 'KFlatSum'-based representation + data FlatSum enum + + -- | From 'Generic' representation + toFlatSum :: FlatSumRep enum x -> FlatSum enum + + -- | To 'Generic' representation + fromFlatSum :: FlatSum enum -> FlatSumRep enum x + +-- | Single constructor +instance GFlatSum ('TValue meta) where + type FlatSumRep ('TValue meta) = C1 meta U1 + + data FlatSum ('TValue meta) = Unit + + toFlatSum (M1 U1) = Unit + + fromFlatSum Unit = M1 U1 + +deriving instance Show (FlatSum ('TValue meta)) + +-- | Combination of multiple constructors +instance (GFlatSum lhs, GFlatSum rhs) => GFlatSum ('TChoose lhs rhs) where + type FlatSumRep ('TChoose lhs rhs) = FlatSumRep lhs :+: FlatSumRep rhs + + data FlatSum ('TChoose lhs rhs) = ChooseLeft (FlatSum lhs) | ChooseRight (FlatSum rhs) + + toFlatSum (L1 lhs) = ChooseLeft (toFlatSum lhs) + toFlatSum (R1 rhs) = ChooseRight (toFlatSum rhs) + + fromFlatSum (ChooseLeft lhs) = L1 (fromFlatSum lhs) + fromFlatSum (ChooseRight rhs) = R1 (fromFlatSum rhs) + +deriving instance (Show (FlatSum lhs), Show (FlatSum rhs)) => Show (FlatSum ('TChoose lhs rhs)) + +-- | Analyze the 'Generic' representation of constructors. Make sure every constructor has zero +-- fields. Then transform it into a 'KFlatSum'. +type family AnalyzeFlatSumRep org (cons :: * -> *) :: KFlatSum where + -- Constructor without record selector + AnalyzeFlatSumRep org (C1 meta U1) = + 'TValue meta + + -- Constructor with a record selector is invalid + AnalyzeFlatSumRep org (C1 meta1 (S1 meta2 rec)) = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has multiple constructors, therefore these constructors must have \ + \no fields") + + -- Constructor with a record selector is invalid + AnalyzeFlatSumRep org (C1 meta1 (lhs :*: rhs)) = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has multiple constructors, therefore these constructors must have \ + \no fields") + + -- More constructors + AnalyzeFlatSumRep org (lhs :+: rhs) = + 'TChoose (AnalyzeFlatSumRep org lhs) (AnalyzeFlatSumRep org rhs) + + -- Something else + AnalyzeFlatSumRep org other = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has an invalid constructor" + ':$$: 'ShowType other) + +-- | Information about a data type +data KDataType + = TRecord Meta Meta KRecord + -- ^ Record + | TFlatSum Meta KFlatSum + -- ^ Enumeration + +-- | Mappings between a 'Generic' representation and our 'KDataType'-based representation +class GDataType (dat :: KDataType) where + -- | 'Generic' representation + type DataTypeRep dat :: * -> * + + -- | 'KDataType'-based representation + data DataType dat + + -- | From 'Generic' representation + toDataType :: DataTypeRep dat x -> DataType dat + + -- | To 'Generic' representation + fromDataType :: DataType dat -> DataTypeRep dat x + +-- | With single constructor +instance (GRecord rec) => GDataType ('TRecord d c rec) where + type DataTypeRep ('TRecord d c rec) = D1 d (C1 c (RecordRep rec)) + + data DataType ('TRecord d c rec) = Record (Record rec) + + toDataType (M1 (M1 rec)) = Record (toRecord rec) + + fromDataType (Record rec) = M1 (M1 (fromRecord rec)) + +deriving instance (Show (Record rec)) => Show (DataType ('TRecord d c rec)) + +-- | With multiple constructors +instance (GFlatSum enum) => GDataType ('TFlatSum d enum) where + type DataTypeRep ('TFlatSum d enum) = D1 d (FlatSumRep enum) + + data DataType ('TFlatSum d enum) = FlatSum (FlatSum enum) + + toDataType (M1 enum) = FlatSum (toFlatSum enum) + + fromDataType (FlatSum flatSum) = M1 (fromFlatSum flatSum) + +deriving instance (Show (FlatSum enum)) => Show (DataType ('TFlatSum d enum)) + +-- | Analyze the 'Generic' representation of a data type. If only one constructor exists, further +-- analyzing is delegated to 'AnalyzeRecordRep'. When two or more exist, analyzing is performed by +-- 'AnalyzeFlatSumRep'. The results are gather in a 'KDataType' instance. +type family AnalyzeDataType org (dat :: * -> *) :: KDataType where + -- Single constructor + AnalyzeDataType org (D1 meta1 (C1 meta2 sel)) = + 'TRecord meta1 meta2 (AnalyzeRecordRep org sel) + + -- Multiple constructors + AnalyzeDataType org (D1 meta (lhs :+: rhs)) = + 'TFlatSum meta (AnalyzeFlatSumRep org (lhs :+: rhs)) + + -- Missing constructor(s) + AnalyzeDataType org (D1 meta V1) = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " must have a constructor") + + -- Data type with constructor(s) that does not match the given patterns + AnalyzeDataType org (D1 meta other) = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has an invalid constructor" + ':$$: 'ShowType other) + + -- Something else + AnalyzeDataType org other = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: '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) + +-- | Make sure @a@ has a safe generic representation. Types that qualify implement 'Generic' 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) + +-- | Convert to entity representation. +fromGenericEntity :: (GenericEntity a) => a -> EntityDataType a +fromGenericEntity = + toDataType . from + +-- | Build from entity representation. +toGenericEntity :: (GenericEntity a) => EntityDataType a -> a +toGenericEntity = + to . fromDataType diff --git a/src/Database/PostgreSQL/Store/OIDs.hs b/src/Database/PostgreSQL/Store/OIDs.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Store/OIDs.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes, RankNTypes #-} - --- | --- Module: Database.PostgreSQL.Store.OIDs --- Copyright: (c) Ole Krüger 2016 --- License: BSD3 --- Maintainer: Ole Krüger -module Database.PostgreSQL.Store.OIDs ( - OIDQ, - - bool, - int2, - int4, - int8, - float4, - float8, - numeric, - char, - varchar, - text, - bytea, - timestamp, - timestamptz -) where - -import Language.Haskell.TH -import qualified Database.PostgreSQL.LibPQ as P - -class GenOID a where - genOID :: Integer -> Q a - -instance GenOID Exp where - genOID oid = [e| P.Oid $(litE (IntegerL oid)) |] - -instance GenOID Pat where - genOID oid = [p| P.Oid $(pure (LitP (IntegerL oid))) |] - --- | A type which can be coerced into @Q Exp@ or @Q Pat@. -type OIDQ = forall a . GenOID a => Q a - --- | Boolean -bool :: OIDQ -bool = genOID 16 - --- | 16-bit integer -int2 :: OIDQ -int2 = genOID 21 - --- | 32-bit integer -int4 :: OIDQ -int4 = genOID 23 - --- | 64-bit integer -int8 :: OIDQ -int8 = genOID 20 - --- | Single-precision floating-point number -float4 :: OIDQ -float4 = genOID 700 - --- | Double-precision floating-point number -float8 :: OIDQ -float8 = genOID 701 - --- | Arbitrary precision number -numeric :: OIDQ -numeric = genOID 1700 - --- | Fixed-length string -char :: OIDQ -char = genOID 1042 - --- | Variable-length string -varchar :: OIDQ -varchar = genOID 1043 - --- | Unlimited variable-length string -text :: OIDQ -text = genOID 25 - --- | Byte array -bytea :: OIDQ -bytea = genOID 17 - --- | Timestamp without timezone -timestamp :: OIDQ -timestamp = genOID 1114 - --- | Timestamp with timezone -timestamptz :: OIDQ -timestamptz = genOID 1184 diff --git a/src/Database/PostgreSQL/Store/Query.hs b/src/Database/PostgreSQL/Store/Query.hs --- a/src/Database/PostgreSQL/Store/Query.hs +++ b/src/Database/PostgreSQL/Store/Query.hs @@ -1,444 +1,24 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, FunctionalDependencies, - FlexibleInstances, FlexibleContexts, TypeFamilies #-} - -- | -- Module: Database.PostgreSQL.Store.Query --- Copyright: (c) Ole Krüger 2015-2016 +-- Copyright: (c) Ole Krüger 2016 -- License: BSD3 -- Maintainer: Ole Krüger +-- +-- This module acts solely as a re-export unit. module Database.PostgreSQL.Store.Query ( - -- * Query - Query (..), - SelectorElement (..), - QueryTable (..), - pgsq, - pgss, - - -- * Helpers - quoteIdentifier, + -- * Exported modules + module Database.PostgreSQL.Store.Query.Builder, + module Database.PostgreSQL.Store.Query.TH, - -- * Query builder - QueryCode, - QueryBuildable, - QueryBuilder, - runQueryBuilder, - writeCode, - writeStringCode, - writeIdentifier, - writeAbsIdentifier, - writeParam, - writeColumn, - intercalateBuilder + -- * Utilities + castQuery ) where -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -import Control.Applicative -import Control.Monad.State.Strict - -import Data.List -import Data.Proxy -import Data.Monoid -import Data.String -import qualified Data.Text as T -import qualified Data.ByteString as B - -import Data.Char -import Data.Attoparsec.Text - -import Database.PostgreSQL.Store.Columns - --- | Properly quote an identifier. -quoteIdentifier :: String -> String -quoteIdentifier name = - '"' : stripQuotes name ++ "\"" - where - stripQuotes [] = [] - stripQuotes ('"' : xs) = '"' : '"' : stripQuotes xs - stripQuotes (x : xs) = x : stripQuotes xs - --- | Query including statement and parameters --- --- Use the 'pgsq' quasi-quoter to conveniently create queries. -data Query = Query { - -- | Statement - queryStatement :: !B.ByteString, - - -- | Parameters - queryParams :: ![Value] -} deriving (Show, Eq, Ord) - --- | @SELECT@ expression -data SelectorElement - = SelectorField String - -- ^ Select a field. The field nme will be quoted and properly escaped. - | SelectorSpecial String - -- ^ Select a special expression. The expression will be inlined as is. - deriving (Show, Eq, Ord) - --- | A type which implements this class can be used as a table in a quasi-quoted query. --- 'mkTable' can implement this for you. -class QueryTable a where - -- | Unquoted name of the table - tableName :: Proxy a -> String - - -- | Unquoted name of the ID field - tableIDName :: Proxy a -> String - - -- | Selectors needed to retrieve all fields necessary to construct the type - think @SELECT@. - tableSelectors :: Proxy a -> [SelectorElement] - --- | Generate the quoted identifier for a table. -makeTableIdentifier :: (QueryTable a, IsString b) => Proxy a -> b -makeTableIdentifier proxy = - fromString (quoteIdentifier (tableName proxy)) - --- | Generate the quoted identifier for table's id column. -makeTableIDIdentifier :: (QueryTable a, IsString b) => Proxy a -> b -makeTableIDIdentifier proxy = - fromString (quoteIdentifier (tableName proxy) ++ - "." ++ - quoteIdentifier (tableIDName proxy)) - --- | Generate the list of expression used as selector. -makeTableSelectors :: (QueryTable a, IsString b) => Proxy a -> b -makeTableSelectors proxy = - fromString (intercalate ", " (map makeElement (tableSelectors proxy))) - where - makeElement (SelectorField name) = - quoteIdentifier (tableName proxy) ++ "." ++ quoteIdentifier name - makeElement (SelectorSpecial expr) = - expr - --- | Query segment -data Segment - = SSelector String - | STable String - | SVariable String - | SIdentifier String - | SQuote Char String - | SOther String - --- | Name -name :: Parser String -name = - (:) <$> (letter <|> char '_') <*> many (satisfy isAlphaNum <|> char '_') - --- | Type name -typeName :: Parser String -typeName = - (:) <$> satisfy isUpper <*> many (satisfy isAlphaNum <|> char '_') - --- | Qualified type name -qualifiedTypeName :: Parser String -qualifiedTypeName = do - intercalate "." <$> sepBy1 typeName (char '.') - --- | Quote -quote :: Char -> Parser Segment -quote delim = do - char delim - cnt <- concat <$> many (choice [escapedDelim, notDelim]) - char delim - pure (SQuote delim cnt) - where - escapedDelim = (\ a b -> [a, b]) <$> char '\\' <*> char delim - notDelim = (: []) <$> notChar delim - --- | Segments -segments :: Parser [Segment] -segments = - many (choice [quote '"', - quote '\'', - char '#' >> SSelector <$> qualifiedTypeName, - char '@' >> STable <$> qualifiedTypeName, - char '&' >> SIdentifier <$> qualifiedTypeName, - char '$' >> SVariable <$> name, - SOther "#" <$ char '#', - SOther "@" <$ char '@', - SOther "&" <$ char '&', - SOther "$" <$ char '$', - SOther <$> some (satisfy (notInClass "\"'#@&$"))]) - --- | Reduce segments in order to resolve names and collect query parameters. -reduceSegment :: Segment -> QueryBuilder [Q Exp] (Q Exp) -reduceSegment seg = - case seg of - SOther str -> - writeStringCode str - - SQuote delim cnt -> - writeStringCode (delim : cnt ++ [delim]) - - SVariable varName -> writeParam $ do - mbName <- lookupValueName varName - case mbName of - Just name -> [e| pack $(varE name) |] - Nothing -> fail ("'" ++ varName ++ "' does not refer to anything") - - STable tableName -> writeCode $ do - mbName <- lookupTypeName tableName - case mbName of - Just table -> [e| makeTableIdentifier (Proxy :: Proxy $(conT table)) |] - Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything") - - SSelector tableName -> writeCode $ do - mbName <- lookupTypeName tableName - case mbName of - Just table -> [e| makeTableSelectors (Proxy :: Proxy $(conT table)) |] - Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything") - - SIdentifier tableName -> writeCode $ do - mbName <- lookupTypeName tableName - case mbName of - Just table -> [e| makeTableIDIdentifier (Proxy :: Proxy $(conT table)) |] - Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything") - --- | Parse quasi-quoted query. -parseStoreQueryE :: String -> Q Exp -parseStoreQueryE code = do - case parseOnly (segments <* endOfInput) (T.pack code) of - Left msg -> - fail msg - - Right xs -> do - runQueryBuilder (mapM_ reduceSegment xs) - --- | This quasi-quoter allows you to generate instances of 'Query'. It lets you write SQL with some --- small enhancements. 'pgsq' heavily relies on 'QueryTable' which can be implemented by 'mkTable' --- for a type of your choice. --- --- Some syntax definitions that might be useful later on: --- --- > TypeName ::= UpperAlpha {AlphaNumeric | '_'} --- > Name ::= (Alpha | '_') {AlphaNumeric | '_'} --- > QualifiedTypeName ::= {TypeName '.'} TypeName --- --- @Alpha@ includes all alphabetical characters; @UpperAlpha@ includes all upper-case alphabetical --- characters; @AlphaNumeric@ includes all alpha-numeric characters. --- --- = Embed values --- You can embed values whose types implement 'Column'. --- --- > ValueExp ::= '$' Name --- --- > magicNumber :: Int --- > magicNumber = 1337 --- > --- > myQuery :: Query --- > myQuery = --- > [pgsq| SELECT * FROM table t WHERE t.column1 > $magicNumber AND t.column2 < $otherNumber |] --- > where otherNumber = magicNumber * 2 --- --- @$magicNumber@ and @$otherNumber@ are references to values @magicNumber@ and @otherNumber@. --- --- The quasi-quoter will generate a 'Query' expression similar to the following. --- --- > Query "SELECT * FROM table t WHERE t.column1 > $1 AND t.column2 < $2" --- > [pack magicNumber, pack otherNumber] --- --- = Table names --- Types that implement 'QueryTable' associate a table name with themselves. Since the table name is --- not always known to the user, one can insert it dynamically. --- --- > TableNameExp ::= '@' QualifiedTypeName --- --- The @\@@-operators is also an alias for the function @ABS@. If you have an expression that --- triggers the quasi-quoter such as @\@A@, but you would like to use the @ABS@ functionality, then --- simply reformat your expression to @\@(A)@ or @ABS(A)@. --- --- > instance QueryTable YourType where --- > tableName _ = "YourTable" --- > --- > myQuery :: Query --- > myQuery = --- > [pgsq| SELECT * FROM @YourType WHERE @YourType.column = 1337 |] --- --- The table name will be inlined which results in the following. --- --- > Query "SELECT * FROM \"YourTable\" WHERE \"YourTable\".column = 1337" [] --- --- = Identifier column names --- Each instance of 'QueryTable' also provides the name of the identifier column. Using this column --- name you can identify specific rows of a certain table. --- --- > TableIdentExp ::= '&' TypeName --- --- @&@ is also the operator for bitwise-AND. To resolve the ambiguity for expressions like @A&B@, --- simply reformat it to @A & B@ or @A&(B)@. --- --- > instance QueryTable YourType where --- > tableName _ = "YourTable" --- > tableIDName _ = "id" --- > --- > listIDs :: Query --- > listIDs = --- > [pgsq| SELECT &YourType FROM @YourType |] --- --- @listIDs@ is now a query which lists the IDs of each row. This is especially useful in --- combination with 'Reference'. --- --- > fetchIDs :: Errand [Reference YourType] --- > fetchIDs = --- > query [pgsq| SELECT &YourType FROM @YourType |] --- --- = Selectors --- 'mkTable' will automatically implement 'Result' and 'QueryTable' for you. This allows you to make --- use of the selector expander. --- --- > SelectorExp ::= '#' QualifiedTypeName --- --- @#@ is also the operator for bitwise-XOR. To resolve the ambiguity for expressions like @A#B@, --- simply reformat it to @A # B@ or @A#(B)@ or @A#\"B\"@. --- --- > data Actor = Actor { --- > actorName :: String, --- > actorAge :: Word --- > } deriving (Show, Eq, Ord) --- > --- > mkTable ''Actor [] --- > --- > fetchOldActors :: Errand [Actor] --- > fetchOldActors = --- > query [pgsq| SELECT #Actor FROM @Actor a WHERE a.actorAge >= $oldAge |] --- > where oldAge = 70 --- --- @#Actor@ will expand to a list of columns that are necessary to construct an instance of @Actor@. --- In this case it is equivalent to --- --- > @Actor.actorName, @Actor.actorAge -pgsq :: QuasiQuoter -pgsq = - QuasiQuoter { - quoteExp = parseStoreQueryE, - quotePat = const (fail "Cannot use 'pgsq' in pattern"), - quoteType = const (fail "Cannot use 'pgsq' in type"), - quoteDec = const (fail "Cannot use 'pgsq' in declaration") - } - --- | Parse quasi-quoted query but return only statement. -parseStoreStatementE :: String -> Q Exp -parseStoreStatementE code = do - case parseOnly (segments <* endOfInput) (T.pack code) of - Left msg -> - fail (show msg) - - Right xs -> do - [e| mconcat $(listE (runQueryBuilder_ (mapM_ reduceSegment xs))) |] - --- | Just like 'pgsq' but only produces the statement associated with the query. Referenced --- values are not inlined, they are simply dismissed. -pgss :: QuasiQuoter -pgss = - QuasiQuoter { - quoteExp = parseStoreStatementE, - quotePat = const (fail "Cannot use 'pgss' in pattern"), - quoteType = const (fail "Cannot use 'pgss' in type"), - quoteDec = const (fail "Cannot use 'pgss' in declaration") - } - --- | Internal state for every builder -data BuilderState s p = BuilderState s Word [p] - --- | -class QueryCode s where - type Code s - - appendCode :: s -> Code s -> s - - appendStringCode :: s -> String -> s - -instance QueryCode B.ByteString where - type Code B.ByteString = B.ByteString - - appendCode = B.append - - appendStringCode bs str = bs <> fromString str - -instance QueryCode [Q Exp] where - type Code [Q Exp] = Q Exp - - appendCode segments exp = segments ++ [exp] - - appendStringCode segments str = appendCode segments [e| fromString $(stringE str) |] - -instance QueryCode String where - type Code String = String - - appendCode segments code = segments ++ code - - appendStringCode = appendCode - --- | Can build @o@ using @s@ and @[p]@. -class QueryBuildable s p o | s p -> o where - buildQuery :: s -> [p] -> o - -instance QueryBuildable B.ByteString Value Query where - buildQuery = Query - -instance QueryBuildable String (Q Exp) (Q Exp) where - buildQuery code params = - [e| Query (fromString $(stringE code)) $(listE params) |] - -instance QueryBuildable [Q Exp] (Q Exp) (Q Exp) where - buildQuery codeSegments params = - [e| Query (B.concat $(listE codeSegments)) $(listE params) |] - --- | Query builder -type QueryBuilder s p = State (BuilderState s p) () - --- | Run query builder. -runQueryBuilder :: (QueryBuildable s p o, Monoid s) => QueryBuilder s p -> o -runQueryBuilder builder = - buildQuery code params - where - BuilderState code _ params = execState builder (BuilderState mempty 1 []) - --- | Run query builder, return only the statement. -runQueryBuilder_ :: (Monoid s) => QueryBuilder s p -> s -runQueryBuilder_ builder = - code - where - BuilderState code _ _ = execState builder (BuilderState mempty 1 []) - --- | Write code. -writeCode :: (QueryCode s) => Code s -> QueryBuilder s p -writeCode code = - modify $ \ (BuilderState stmt idx params) -> - BuilderState (appendCode stmt code) idx params - --- | Write string code. -writeStringCode :: (QueryCode s) => String -> QueryBuilder s p -writeStringCode code = - modify $ \ (BuilderState stmt idx params) -> - BuilderState (appendStringCode stmt code) idx params - --- | Add an identifier. -writeIdentifier :: (QueryCode s) => String -> QueryBuilder s p -writeIdentifier name = - writeStringCode (quoteIdentifier name) - --- | Add an absolute identifier. -writeAbsIdentifier :: (QueryCode s) => String -> String -> QueryBuilder s p -writeAbsIdentifier ns name = do - writeIdentifier ns - writeStringCode "." - writeIdentifier name - --- | Embed a parameter. -writeParam :: (QueryCode s) => p -> QueryBuilder s p -writeParam param = do - modify $ \ (BuilderState code idx params) -> - BuilderState (appendStringCode code ("$" ++ show idx)) (idx + 1) (params ++ [param]) - --- | Embed a value parameter. -writeColumn :: (Column p, QueryCode s) => p -> QueryBuilder s Value -writeColumn param = - writeParam (pack param) +import Database.PostgreSQL.Store.Types +import Database.PostgreSQL.Store.Query.Builder +import Database.PostgreSQL.Store.Query.TH --- | Do something between other builders. -intercalateBuilder :: QueryBuilder s p -> [QueryBuilder s p] -> QueryBuilder s p -intercalateBuilder x xs = - sequence_ (intersperse x xs) +-- | Cast the query's result type. +castQuery :: Query a -> Query b +castQuery (Query s p) = + Query s p diff --git a/src/Database/PostgreSQL/Store/Query/Builder.hs b/src/Database/PostgreSQL/Store/Query/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/Query/Builder.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeSynonymInstances, FlexibleInstances #-} + +-- | +-- Module: Database.PostgreSQL.Store.Query.Builder +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.Query.Builder ( + -- * Query Builder + QueryBuilder, + insertCode, + insertTypedValue, + insertValue, + insertValue', + insertQuote, + insertName, + + insertCommaSeperated, + + -- * Generalized Building + FromQueryBuilder (..) +) where + +import Control.Monad.State.Strict + +import Data.List +import qualified Data.ByteString as B + +import Database.PostgreSQL.LibPQ (invalidOid) + +import Database.PostgreSQL.Store.Types +import Database.PostgreSQL.Store.Utilities + +-- | Internal builder state +data BuilderState = BuilderState { + queryCode :: B.ByteString, + queryIndex :: Word, + queryValues :: [TypedValue] +} + +-- | Query builder +type QueryBuilder = State BuilderState () + +-- | Insert a piece of SQL. +insertCode :: B.ByteString -> QueryBuilder +insertCode code = + modify (\ state -> state {queryCode = B.append (queryCode state) code}) + +-- | 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] + } + +-- | Same as 'insertTypedValue' but untyped. +insertValue :: Value -> QueryBuilder +insertValue value = + insertTypedValue (TypedValue invalidOid (Just value)) + +-- | 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 ")" + +-- | 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]) + where + replaceDelim 39 = B.pack [39, 39] + replaceDelim x = B.singleton x + +-- | Join several builders into a comma-seperated list. +insertCommaSeperated :: [QueryBuilder] -> QueryBuilder +insertCommaSeperated bs = + sequence_ (intersperse (insertCode ",") bs) + +-- | Insert a name into the code. It will be surrounded by double quotes if necessary. +insertName :: B.ByteString -> QueryBuilder +insertName name = + if isAllowed then + insertCode name + else + insertCode (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' + || (b >= 65 && b <= 90) -- 'A' to 'Z' + || b == 95 -- '_' + + isAllowedBody b = + isAllowedHead b + || (b >= 48 && b <= 57) -- '0' to '9' + + isAllowed = + case B.uncons name of + Nothing -> True + Just (h, b) -> isAllowedHead h && B.all isAllowedBody b + +-- | @a@ can be instantiated using the query builder. +class FromQueryBuilder a where + buildQuery :: QueryBuilder -> a + +instance FromQueryBuilder QueryBuilder where + buildQuery = id + +instance FromQueryBuilder B.ByteString where + buildQuery builder = + queryCode (execState builder (BuilderState B.empty 1 [])) + +instance FromQueryBuilder (B.ByteString, [TypedValue]) where + buildQuery builder = + (code, values) + where BuilderState code _ values = execState builder (BuilderState B.empty 1 []) + +instance FromQueryBuilder (Query a) where + buildQuery builder = + Query code values + where BuilderState code _ values = execState builder (BuilderState B.empty 1 []) diff --git a/src/Database/PostgreSQL/Store/Query/TH.hs b/src/Database/PostgreSQL/Store/Query/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/Query/TH.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} + +-- | +-- Module: Database.PostgreSQL.Store.Query.TH +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.Query.TH ( + -- * Template Haskell + parseQuery, + pgsq +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.Meta.Parse + +import Control.Applicative + +import Data.List +import Data.Proxy +import Data.Char +import Data.Attoparsec.Text +import qualified Data.ByteString as B +import qualified Blaze.ByteString.Builder as B +import qualified Blaze.ByteString.Builder.Char.Utf8 as B +import qualified Data.Text as T + +import Database.PostgreSQL.Store.Utilities +import Database.PostgreSQL.Store.Entity +import Database.PostgreSQL.Store.Table +import Database.PostgreSQL.Store.Query.Builder + +-- | Name +valueName :: Parser String +valueName = + (:) <$> (letter <|> char '_') <*> many (satisfy isAlphaNum <|> char '_' <|> char '\'') + +-- | Type name +typeName :: Parser String +typeName = + (:) <$> satisfy isUpper <*> many (satisfy isAlphaNum <|> char '_' <|> char '\'') + +-- | Qualified type name +qualifiedTypeName :: Parser String +qualifiedTypeName = + intercalate "." <$> sepBy1 typeName (char '.') + +-- | Query segment +data QuerySegment + = QueryEntity String + | QueryEntityCode String + | QueryQuote Char String + | QueryOther String + | QueryTable String + | QuerySelector String + | QuerySelectorAlias String String + -- QueryIdentifier String + deriving (Show, Eq, Ord) + +-- | Table +tableSegment :: Parser QuerySegment +tableSegment = do + char '@' + QueryTable <$> qualifiedTypeName + +-- | Selector +selectorSegment :: Parser QuerySegment +selectorSegment = do + char '#' + QuerySelector <$> qualifiedTypeName + +-- | Selector alias +selectorAliasSegment :: Parser QuerySegment +selectorAliasSegment = do + char '#' + QuerySelectorAlias <$> qualifiedTypeName + <* char '(' + <*> valueName + <* char ')' + +-- -- | Identifier +-- identifierSegment :: Parser QuerySegment +-- identifierSegment = do +-- char '&' +-- QueryIdentifier <$> qualifiedTypeName + +-- | Entity +entityNameSegment :: Parser QuerySegment +entityNameSegment = do + char '$' + QueryEntity <$> valueName + +-- | Entity code +entityCodeSegment :: Parser QuerySegment +entityCodeSegment = + QueryEntityCode <$> (string "$(" *> insideCode <* char ')') + where + insideCode = + concat <$> many (choice [bracedCode, + quoteCode '\'', + quoteCode '\"', + some (satisfy (notInClass "\"'()"))]) + + bracedCode = + char '(' *> fmap (\ code -> '(' : code ++ ")") insideCode <* char ')' + + quoteCode delim = do + char delim + cnt <- many (choice [escapedDelim delim, notDelim delim]) + char delim + pure (delim : concat cnt ++ [delim]) + + escapedDelim delim = do + char '\\' + char delim + pure ['\\', delim] + + notDelim delim = + (: []) <$> notChar delim + +-- | Quotation +quoteSegment :: Char -> Parser QuerySegment +quoteSegment delim = do + char delim + cnt <- concat <$> many (choice [escapedDelim, notDelim]) + char delim + pure (QueryQuote delim cnt) + where + escapedDelim = char delim >> char delim >> pure [delim, delim] + notDelim = (: []) <$> notChar delim + +-- | Uninterpreted segment +otherSegment :: Parser QuerySegment +otherSegment = + QueryOther <$> some (satisfy (notInClass "\"'@#$")) + -- QueryOther <$> some (satisfy (notInClass "\"'@&#$")) + +-- | Segment that is part of the query +querySegment :: Parser QuerySegment +querySegment = + choice [quoteSegment '\'', + quoteSegment '"', + tableSegment, + selectorAliasSegment, + selectorSegment, + -- identifierSegment, + entityCodeSegment, + entityNameSegment, + otherSegment] + +-- | Pack 'String' code into a 'ByteString'. +packCode :: String -> B.ByteString +packCode code = + B.toByteString (B.fromString code) + +-- | Translate a "QuerySegment" to an expression. +translateSegment :: QuerySegment -> Q Exp +translateSegment segment = + case segment of + QueryTable stringName -> do + mbTypeName <- lookupTypeName stringName + case mbTypeName of + Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type") + Just typ -> + [e| insertName (tableName (describeTableType (Proxy :: Proxy $(conT typ)))) |] + + QuerySelector stringName -> do + mbTypeName <- lookupTypeName stringName + case mbTypeName of + Nothing -> fail ("'" ++ stringName ++ "' does not refer to a type") + Just typ -> + [e| insertColumns (describeTableType (Proxy :: Proxy $(conT typ))) |] + + QuerySelectorAlias stringName aliasName -> do + mbTypeName <- lookupTypeName stringName + case mbTypeName of + 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)) |] + + QueryEntity stringName -> do + mbValueName <- lookupValueName stringName + case mbValueName of + Nothing -> fail ("'" ++ stringName ++ "' does not refer to a value") + Just name -> + [e| insertEntity $(varE name) |] + + QueryEntityCode code -> + case parseExp code of + Left msg -> fail ("Error in code " ++ show code ++ ": " ++ msg) + Right expr -> + [e| insertEntity $(pure expr) |] + + QueryQuote delim code -> + [e| insertCode $(liftByteString (packCode (delim : code ++ [delim]))) |] + + QueryOther code -> + [e| insertCode $(liftByteString (packCode code)) |] + +-- | Parse a query string in order to produce a 'QueryBuilder' expression. +parseQuery :: String -> Q Exp +parseQuery code = + case parseOnly (many querySegment <* endOfInput) (T.strip (T.pack code)) of + Left msg -> + fail ("Query parser failed: " ++ msg) + + Right [] -> + [e| buildQuery (pure ()) |] + + Right segments -> + [e| buildQuery $(DoE . map NoBindS <$> mapM translateSegment segments) |] + +-- | Generate queries conveniently. See 'BuildQuery' to find out which types can be produced. +pgsq :: QuasiQuoter +pgsq = + 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") + } diff --git a/src/Database/PostgreSQL/Store/Result.hs b/src/Database/PostgreSQL/Store/Result.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Store/Result.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Module: Database.PostgreSQL.Store.Result --- Copyright: (c) Ole Krüger 2015-2016 --- License: BSD3 --- Maintainer: Ole Krüger -module Database.PostgreSQL.Store.Result ( - -- * Result processor - ResultError (..), - ResultProcessor, - processResult, - processOneResult, - - skipColumn, - unpackColumn -) where - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Except - -import qualified Database.PostgreSQL.LibPQ as P -import Database.PostgreSQL.Store.Columns - --- | Error that occured during result processing -data ResultError - = TooFewColumnsError P.Column - -- ^ Occurs when you're trying to access a column that does not exist. - | UnpackError P.Row P.Column P.Oid P.Format - -- ^ The value at a given row and column could not be unpacked. - deriving (Show, Eq) - --- | Result processor -newtype ResultProcessor a = - ResultProcessor (StateT P.Column (ReaderT (P.Result, P.Row, P.Column) (ExceptT ResultError IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadError ResultError) - --- | Move cursor to the next column. -skipColumn :: ResultProcessor () -skipColumn = - ResultProcessor (modify (+ 1)) - --- | Unpack the current column and move the cursor to the next column. -unpackColumn :: (Column a) => ResultProcessor a -unpackColumn = do - -- Gather information - col <- ResultProcessor get - (res, row, numCol) <- ResultProcessor ask - - -- Make sure we're not trying to unpack a non-existing column - when (col >= numCol) (throwError (TooFewColumnsError numCol)) - - -- Retrieve column-specific information - (typ, mbData) <- liftIO $ - (,) <$> P.ftype res col <*> P.getvalue' res row col - - -- Try to unpack the value - case unpack (maybe NullValue (Value typ) mbData) of - Just ret -> ResultProcessor (put (col + 1) >> pure ret) - Nothing -> throwError (UnpackError row col typ P.Text) - --- | Process the entire result set. -processResult :: P.Result -> ResultProcessor a -> ExceptT ResultError IO [a] -processResult res (ResultProcessor proc) = do - (rows, cols) <- liftIO ((,) <$> P.ntuples res <*> P.nfields res) - - -- Iterate over each row number and run the row processor - forM [0 .. rows - 1] $ \ row -> - runReaderT (evalStateT proc 0) (res, row, cols) - --- | Process one row of the result set. -processOneResult :: P.Result -> ResultProcessor a -> ExceptT ResultError IO (Maybe a) -processOneResult res (ResultProcessor proc) = do - (rows, cols) <- liftIO ((,) <$> P.ntuples res <*> P.nfields res) - - if rows > 0 then - Just <$> runReaderT (evalStateT proc 0) (res, 0, cols) - else - pure Nothing diff --git a/src/Database/PostgreSQL/Store/RowParser.hs b/src/Database/PostgreSQL/Store/RowParser.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/RowParser.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module: Database.PostgreSQL.Store.RowParser +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.RowParser ( + -- * Row Parser + RowParser, + RowErrorLocation (..), + RowErrorDetail (..), + RowError (..), + + rowNumber, + columnNumber, + columnsLeft, + + fetchColumn, + peekColumn, + parseColumn, + + peekContents, + fetchContents, + parseContents, + + skipColumn, + + -- * Result Parser + parseResult +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State.Strict + +import qualified Data.ByteString as B + +import qualified Database.PostgreSQL.LibPQ as P +import Database.PostgreSQL.Store.Types + +-- | Location of an error +data RowErrorLocation = RowErrorLocation P.Column P.Row + deriving (Show, Eq, Ord) + +-- | Errors that occur during row parsing +data RowErrorDetail + = TooFewColumns + -- ^ Underlying 'RowParser' wants more columns than are currently present. + | ColumnRejected TypedValue + -- ^ 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. +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) + +-- | Parse a single row. +parseRow :: RowParser a -> RowInput -> ExceptT RowError IO a +parseRow (RowParser parser) rowInfo = + evalStateT (runReaderT parser rowInfo) (P.Col 0) + +-- | Retrieve the current row number. +rowNumber :: RowParser P.Row +rowNumber = RowParser (asks (\ (RowInput _ row) -> row)) + +-- | Retrieve the current column number. +columnNumber :: RowParser P.Column +columnNumber = RowParser get + +-- | Retrieve the number of columns left. +columnsLeft :: RowParser P.Column +columnsLeft = RowParser $ do + RowInput (ResultInfo _ numCols) _ <- ask + curCol <- get + pure (numCols - curCol) + +-- | Advance to next column without checking. +nextColumn :: RowParser () +nextColumn = + RowParser (modify (+ 1)) + +-- | 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) + + if col < numColumns then + action result row col + else + throwError (RowError (RowErrorLocation col row) TooFewColumns) + +-- | 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) + +-- | 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 + +-- | 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)) + +-- | 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))) + +-- | Like 'peekContents' but moves the cell cursor to the next column. +fetchContents :: RowParser (Maybe B.ByteString) +fetchContents = + peekContents <* nextColumn + +-- | 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)) + +-- | Point cursor to the next column. +skipColumn :: RowParser () +skipColumn = do + (RowInput (ResultInfo _ numColumns) row, col) <- RowParser ((,) <$> ask <*> get) + + if col < numColumns then + nextColumn + else + throwError (RowError (RowErrorLocation col row) TooFewColumns) + +-- | 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) + + forM [0 .. numRows - 1] (parseRow parser . RowInput resultInfo) diff --git a/src/Database/PostgreSQL/Store/Table.hs b/src/Database/PostgreSQL/Store/Table.hs --- a/src/Database/PostgreSQL/Store/Table.hs +++ b/src/Database/PostgreSQL/Store/Table.hs @@ -1,444 +1,228 @@ -{-# LANGUAGE TemplateHaskell, BangPatterns #-} +{-# LANGUAGE OverloadedStrings, + ConstraintKinds, + DataKinds, + FlexibleContexts, + FlexibleInstances, + TypeFamilies, + TypeOperators, + TypeSynonymInstances, + UndecidableInstances, + ScopedTypeVariables, + QuasiQuotes, + DefaultSignatures +#-} -- | -- Module: Database.PostgreSQL.Store.Table --- Copyright: (c) Ole Krüger 2015-2016 +-- Copyright: (c) Ole Krüger 2016 -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store.Table ( - -- * Auxiliary data types - Reference (..), + -- * Columns + Column (..), + ColumnType (..), + ColumnEntity (..), - -- * Table types + -- * Table Table (..), - mkCreateQuery, - - -- * Table generation - TableConstraint (..), - mkTable -) where - -import Control.Monad -import Control.Monad.Except - -import Data.Int -import Data.List hiding (insert) -import Data.Proxy -import Data.String - -import qualified Data.ByteString as B - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Columns -import Database.PostgreSQL.Store.Result -import Database.PostgreSQL.Store.Errand - --- | Reference a row of type @a@. -newtype Reference a = Reference { referenceID :: Int64 } - deriving (Eq, Ord) - -instance Show (Reference a) where - show (Reference n) = show n - -instance (QueryTable a) => Column (Reference a) where - pack ref = pack (referenceID ref) - - unpack val = Reference <$> unpack val - - columnTypeName proxy = - "BIGINT REFERENCES " ++ quoteIdentifier (tableName tableProxy) ++ - " (" ++ quoteIdentifier (tableIDName tableProxy) ++ ")" - where - tableProxy = (const Proxy :: Proxy (Reference a) -> Proxy a) proxy - - columnAllowNull _ = False - -instance Result (Reference a) where - queryResultProcessor = Reference <$> unpackColumn - --- | Qualify @a@ as a table type. 'mkTable' can implement this class for you. -class Table a where - -- | Insert a row into the table and return a 'Reference' to the inserted row. - insert :: a -> Errand (Reference a) - - -- | Insert multiple rows into the table at once. - insertMany :: [a] -> Errand [Reference a] - insertMany = mapM insert - - -- | Find the row identified by the given reference. - find :: Reference a -> Errand a - - -- | Update an existing row. - update :: Reference a -> a -> Errand () - - -- | Delete a row from the table. - delete :: Reference a -> Errand () - - -- | Generate the query which creates this table inside the database. - -- Use 'mkCreateQuery' for convenience. - createTableQuery :: Proxy a -> Query - --- | Table field declaration -data TableField = TableField String Type Name - --- | Table type declaration -data TableDec = TableDec Name Name [TableField] Pat - --- | Generate an identifier for a table type. -tableIdentifier :: Name -> String -tableIdentifier name = quoteIdentifier (show name) - --- | Make a comma-seperated list of identifiers which correspond to given fields. -tableFieldIdentifiers :: [TableField] -> String -tableFieldIdentifiers fields = - intercalate ", " (map (\ (TableField name _ _) -> quoteIdentifier name) fields) - --- | Beginning of a insert statement. -tableInsertStatementBegin :: TableDec -> String -tableInsertStatementBegin (TableDec table _ fields _) = - "INSERT INTO " ++ - tableIdentifier table ++ - " (" ++ - tableFieldIdentifiers fields ++ - ") VALUES " - --- | End of a insert statement. -tableInsertStatementEnd :: String -tableInsertStatementEnd = - " RETURNING \"$id\"" - --- | Call a constructor with some variables. -callConstructor :: Name -> [Name] -> Exp -callConstructor ctor params = - foldl AppE (ConE ctor) (map VarE params) - --- | Generate the list of selectors. -makeQuerySelectors :: [TableField] -> Q Exp -makeQuerySelectors fields = - ListE <$> mapM (\ (TableField field _ _) -> [e| SelectorField $(stringE field) |]) fields - --- | Generate the result processor for a table. -makeResultProcessor :: TableDec -> Q Exp -makeResultProcessor (TableDec _ ctor fields _) = do - bindingNames <- mapM (\ (TableField name _ _) -> newName name) fields - pure (DoE (map makeBinding bindingNames ++ - [makeConstruction bindingNames])) - where - -- Bind expression 'name <- unpackColumn' - makeBinding name = - BindS (VarP name) (VarE 'unpackColumn) - - -- Last expression 'pure (ctor boundNames...)' - makeConstruction names = - NoBindS (AppE (VarE 'pure) (callConstructor ctor names)) + TableEntity (..), + buildTableSchema, --- | Generate the create query. -makeCreateQuery :: TableDec -> [TableConstraint] -> Q Exp -makeCreateQuery (TableDec table _ fields _) constraints = - runQueryBuilder $ do - writeStringCode "CREATE TABLE IF NOT EXISTS " :: QueryBuilder [Q Exp] (Q Exp) - writeIdentifier (show table) - writeStringCode " (" + insertColumns, + insertColumnsOn, - intercalateBuilder (writeStringCode ", ") $ - identDescription : - map describeField fields ++ - map describeConstraint constraints + GenericTable, + describeGenericTable, - writeStringCode ")" - where - identDescription = do - writeIdentifier "$id" - writeStringCode "BIGSERIAL NOT NULL PRIMARY KEY" + -- * Helpers + KColumns (..), + KTable (..), - describeField :: TableField -> QueryBuilder [Q Exp] (Q Exp) - describeField (TableField name typ _) = - writeCode [e| fromString (columnDescription (Proxy :: Proxy $(pure typ)) - $(stringE (quoteIdentifier name))) |] + GColumns (..), + GTable (..), - describeConstraint :: TableConstraint -> QueryBuilder [Q Exp] (Q Exp) - describeConstraint (Unique names) = do - writeStringCode "UNIQUE (" - intercalateBuilder (writeStringCode ", ") $ - map (writeIdentifier . nameBase) names - writeStringCode ")" + AnalyzeRecordRep, + AnalyzeTableRep, - describeConstraint (Check code) = do - writeStringCode "CHECK (" - writeStringCode code - writeStringCode ")" + AnalyzeTable +) where --- | Generate the query which insert a row. -makeInsertQuery :: TableDec -> Q Exp -makeInsertQuery (TableDec table _ fields _) = - runQueryBuilder $ do - writeCode "INSERT INTO " :: QueryBuilder String (Q Exp) - writeIdentifier (show table) - writeCode " (" - intercalateBuilder (writeCode ", ") $ - map (\ (TableField name _ _) -> writeIdentifier name) fields - writeCode ") VALUES (" - intercalateBuilder (writeCode ", ") $ - map (\ (TableField _ _ boundName) -> writeParam [e| pack $(varE boundName) |]) fields - writeCode ") RETURNING " - writeIdentifier "$id" +import GHC.Generics +import GHC.TypeLits --- | Generate the query which inserts multiple rows at once. -makeInsertManyQuery :: Name -> TableDec -> Q Exp -makeInsertManyQuery rows dec@(TableDec _ _ fields destructPat) = - [e| - let - writeTuple $(pure destructPat) = do - writeStringCode "(" :: QueryBuilder B.ByteString Value - intercalateBuilder (writeStringCode ",") $(ListE <$> mapM packColumn fields) - writeStringCode ")" - in runQueryBuilder $ do - writeStringCode $(stringE (tableInsertStatementBegin dec)) - intercalateBuilder (writeStringCode ",") (map writeTuple $(varE rows)) - writeStringCode $(stringE tableInsertStatementEnd) - |] - where - packColumn (TableField _ _ boundName) = [e| writeColumn $(varE boundName) |] +import Control.Monad --- | Generate the query for finding a row. -makeFindQuery :: Name -> TableDec -> Q Exp -makeFindQuery ref (TableDec table _ fields _) = - runQueryBuilder $ do - writeCode "SELECT " :: QueryBuilder String (Q Exp) - intercalateBuilder (writeCode ", ") $ - map (\ (TableField name _ _) -> writeIdentifier name) fields - writeCode " FROM " - writeIdentifier (show table) - writeCode " WHERE " - writeIdentifier "$id" - writeCode " = " - writeParam [e| pack $(varE ref) |] +import Data.Kind +import Data.Proxy --- | Generate the query for updating a row. -makeUpdateQuery :: Name -> TableDec -> Q Exp -makeUpdateQuery ref (TableDec table _ fields _) = - runQueryBuilder $ do - writeCode "UPDATE " :: QueryBuilder String (Q Exp) - writeIdentifier (show table) - writeCode " SET " - intercalateBuilder (writeCode ", ") $ - flip map fields $ \ (TableField name _ boundName) -> do - writeIdentifier name - writeCode " = " - writeParam [e| pack $(varE boundName) |] - writeCode " WHERE " - writeIdentifier "$id" - writeCode " = " - writeParam [e| pack $(varE ref) |] +import qualified Data.ByteString as B --- | Generate the query for deleting a row. -makeDeleteQuery :: Name -> Name -> Q Exp -makeDeleteQuery ref table = - runQueryBuilder $ do - writeCode "DELETE FROM " :: QueryBuilder String (Q Exp) - writeIdentifier (show table) - writeCode " WHERE " - writeIdentifier "$id" - writeCode " = " - writeParam [e| pack $(varE ref) |] +import Database.PostgreSQL.Store.Entity +import Database.PostgreSQL.Store.Utilities +import Database.PostgreSQL.Store.ColumnEntity +import Database.PostgreSQL.Store.Query.Builder --- | Implement relevant instances for the given table type. -implementClasses :: TableDec -> [TableConstraint] -> Q [Dec] -implementClasses dec@(TableDec table _ fields destructPat) constraints = - [d| - instance QueryTable $(conT table) where - tableName _ = $(stringE (show table)) - tableIDName _ = "$id" - tableSelectors _ = $(makeQuerySelectors fields) +-- | Type-level description of a record +data KColumns + = TCombine KColumns KColumns + | TSelector Symbol Type - instance Result $(conT table) where - queryResultProcessor = $(makeResultProcessor dec) +-- | Desciption of a column +data Column = Column { + -- | Column name + colName :: B.ByteString, - instance Table $(conT table) where - insert $(pure destructPat) = do - rs <- query $(makeInsertQuery dec) - case rs of - (ref : _) -> pure ref - _ -> throwError EmptyResult + -- | Column type + colType :: ColumnType +} - insertMany [] = pure [] - insertMany rows = - query $(makeInsertManyQuery 'rows dec) +-- | Provide the means to demote 'KColumns' to a value. +class GColumns (rec :: KColumns) where + -- | Instantiate singleton + gDescribeColumns :: proxy rec -> [Column] - find ref = do - rs <- query $(makeFindQuery 'ref dec) - case rs of - (row : _) -> pure row - _ -> throwError EmptyResult +instance (KnownSymbol name, ColumnEntity typ) => GColumns ('TSelector name typ) where + gDescribeColumns _ = + [Column (buildByteString (symbolVal (Proxy :: Proxy name))) + (describeColumnType (Proxy :: Proxy typ))] - update ref $(pure destructPat) = - query_ $(makeUpdateQuery 'ref dec) +instance (GColumns lhs, GColumns rhs) => GColumns ('TCombine lhs rhs) where + gDescribeColumns _ = + gDescribeColumns (Proxy :: Proxy lhs) + ++ gDescribeColumns (Proxy :: Proxy rhs) - delete ref = - query_ $(makeDeleteQuery 'ref table) +-- | Check the 'Generic' representation of a record in order to generate an instance of 'KColumns'. +type family AnalyzeRecordRep org (rec :: * -> *) :: KColumns where + -- Single record field + AnalyzeRecordRep org (S1 ('MetaSel ('Just name) m1 m2 m3) (Rec0 typ)) = + 'TSelector name typ - createTableQuery _ = - $(makeCreateQuery dec constraints) - |] + -- Non-record field + AnalyzeRecordRep org (S1 ('MetaSel 'Nothing m1 m2 m3) a) = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " must have a single record constructor") --- | Check that each field's type has an implementation of 'Column'. -checkRecordFields :: [VarBangType] -> Q [TableField] -checkRecordFields fields = - forM fields $ \ (name, _, typ) -> do - ii <- isInstance ''Column [typ] - unless ii $ - fail ("Type of field '" ++ show name ++ "' ('" ++ show typ ++ - "') type does not implement '" ++ show ''Column ++ "'") + -- Multiple fields + AnalyzeRecordRep org (lhs :*: rhs) = + 'TCombine (AnalyzeRecordRep org lhs) (AnalyzeRecordRep org rhs) - TableField (nameBase name) typ <$> newName (nameBase name) + -- Missing field(s) + AnalyzeRecordRep org U1 = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has one constructor, therefore that constructor must have \ + \at least one field") --- | Check that each constructor parameter type implements 'Column'. -checkNormalFields :: [BangType] -> Q [TableField] -checkNormalFields fields = do - forM (fields `zip` [1 .. length fields]) $ \ ((_, typ), idx) -> do - ii <- isInstance ''Column [typ] - unless ii $ - fail ("Type of constructor parameter #" ++ show idx ++ " ('" ++ show typ ++ - "') type does not implement '" ++ show ''Column ++ "'") + -- Something else + AnalyzeRecordRep org other = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " has a constructor with an invalid selector" + ':$$: 'ShowType other) - TableField ("column" ++ show idx) typ <$> newName ("column" ++ show idx) +-- | Type-level description of a table +data KTable = TTable Symbol KColumns --- | -makeCtorPattern :: Name -> [TableField] -> Pat -makeCtorPattern ctor fields = - ConP ctor (map (\ (TableField _ _ name) -> VarP name) fields) +-- | Description of a table +data Table = Table { + -- | Table name + tableName :: B.ByteString, --- | Verify that the given constructor is viable and construct a 'TableDec'. -checkTableCtor :: Name -> Con -> Q TableDec -checkTableCtor table (RecC ctor ctorFields) = do - when (length ctorFields < 1) - (fail ("'" ++ show ctor ++ "' must have at least one field")) + -- | Table columns + tableCols :: [Column] +} - fields <- checkRecordFields ctorFields - pure (TableDec table ctor fields (makeCtorPattern ctor fields)) +-- | Provide the means to demote 'KTable' to a value. +class GTable (tbl :: KTable) where + -- | Instantiate singleton + gDescribeTable :: proxy tbl -> Table -checkTableCtor table (NormalC ctor ctorFields) = do - when (length ctorFields < 1) - (fail ("'" ++ show ctor ++ "' must have at least one field")) +instance (KnownSymbol name, GColumns cols) => GTable ('TTable name cols) where + gDescribeTable _ = + Table (buildByteString (symbolVal (Proxy :: Proxy name))) + (gDescribeColumns (Proxy :: Proxy cols)) - fields <- checkNormalFields ctorFields - pure (TableDec table ctor fields (makeCtorPattern ctor fields)) +-- | Check the 'Generic' representation of a data type in order to generate an instance of 'KTable'. +type family AnalyzeTableRep org (dat :: * -> *) :: KTable where + -- Single constructor + AnalyzeTableRep org (D1 meta1 (C1 ('MetaCons name f 'True) sel)) = + 'TTable name (AnalyzeRecordRep org sel) -checkTableCtor table _ = - fail ("'" ++ show table ++ "' must have a normal or record constructor") + -- Data type with constructor(s) that does not match the given patterns + AnalyzeTableRep org (D1 meta other) = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " must have a single record constructor") --- | Make sure the given declaration can be used, then construct a 'TableDec'. -checkTableDec :: Name -> Dec -> Q TableDec -checkTableDec _ (DataD ctx tableName typeVars kind ctorNames _) = do - when (length ctx > 0) - (fail ("'" ++ show tableName ++ "' must not have a context")) + -- Something else + AnalyzeTableRep org other = + TypeError ('Text "Given type " + ':<>: 'ShowType org + ':<>: 'Text " is not a valid data type" + ':$$: 'ShowType other) - when (length typeVars > 0) - (fail ("'" ++ show tableName ++ "' must not use type variables")) +-- | Analyzes a type in order to retrieve its 'KTable' representation. +type AnalyzeTable a = AnalyzeTableRep a (Rep a) - when (length ctorNames /= 1) - (fail ("'" ++ show tableName ++ "' must have 1 constructor")) +-- | Constraint for generic tables +type GenericTable a = (Generic a, GTable (AnalyzeTable a)) - when (kind /= Nothing && kind /= Just StarT) - (fail ("'" ++ show tableName ++ "' must have kind *")) +-- | 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) - let [ctorName] = ctorNames +-- | Classify a type which can be used as a table. +class (Entity a) => TableEntity a where + -- | Describe the table type. + describeTableType :: proxy a -> Table - checkTableCtor tableName ctorName + default describeTableType :: (GenericTable a) => proxy a -> Table + describeTableType = describeGenericTable -checkTableDec tableName _ = - fail ("'" ++ show tableName ++ "' must declare a data type") +-- | Build SQL code which describes the column. +buildColumn :: Column -> QueryBuilder +buildColumn (Column name (ColumnType typeName notNull mbCheck)) = do + insertName name + insertCode " " + insertName typeName --- | Options to 'mkTable'. -data TableConstraint - = Unique [Name] - -- ^ A combination of fields must be unique. - -- @Unique ['name1, 'name2, ...]@ works analogous to the table constraint - -- @UNIQUE (name1, name2, ...)@ in SQL. - | Check String - -- ^ The given statement must evaluate to true. Just like @CHECK (statement)@ in SQL. - deriving (Show, Eq, Ord) + when notNull (insertCode " NOT NULL") --- | Implement the type classes 'QueryTable', 'Table' and 'Result' for the given type. --- --- The given type must fulfill these requirements: --- --- * Data type --- * No type context --- * No type variables --- * One record constructor with 1 or more fields --- * All field types must have an instance of 'Column' --- --- Example: --- --- @ --- {-\# LANGUAGE TemplateHaskell, QuasiQuotes \#-} --- module Movies where --- --- ... --- --- data Movie = Movie { --- movieTitle :: 'String', --- movieYear :: 'Int' --- } deriving 'Show' --- --- 'mkTable' ''Movie [] --- --- data Actor = Actor { --- actorName :: 'String', --- actorAge :: 'Int' --- } deriving 'Show' --- --- 'mkTable' ''Actor ['Unique' ['actorName], 'Check' ['pgss'| actorAge >= 18 |]] --- --- data MovieCast = MovieCast { --- movieCastMovie :: 'Reference' Movie, --- movieCastActor :: 'Reference' Actor --- } deriving 'Show' --- --- 'mkTable' ''MovieCast ['Unique' ['movieCastMovie, 'movieCastActor]] --- @ --- --- In this example, 'Reference' takes care of adding the @FOREIGN KEY@ constraint, so we don't have --- to. --- -mkTable :: Name -> [TableConstraint] -> Q [Dec] -mkTable name constraints = do - info <- reify name - case info of - TyConI dec -> do - tableDec <- checkTableDec name dec - implementClasses tableDec constraints + case mbCheck of + Just gen -> do + insertCode " CHECK(" + gen name + insertCode ")" - _ -> fail ("'" ++ show name ++ "' is not a type constructor") + Nothing -> pure () --- | Check if the given name refers to a type. -isType :: Name -> Q Bool -isType name = do - info <- reify name - pure $ case info of - TyConI _ -> True - _ -> False +-- | 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 ")" --- | Generate a 'Query' expression which will create the table described by the given type. --- --- Example: --- --- @ --- data Table = Table { myField :: Int } --- 'mkTable' ''Table [] --- ... --- 'query_' $('mkCreateQuery' ''Table) --- @ --- -mkCreateQuery :: Name -> Q Exp -mkCreateQuery name = do - -- Is the given name a type? - it <- isType name - unless it (fail "Given name does not refer to a type.") +-- | 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 - -- Actual splice - [e| createTableQuery (Proxy :: Proxy $(pure (ConT name))) |] +-- | 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 diff --git a/src/Database/PostgreSQL/Store/Types.hs b/src/Database/PostgreSQL/Store/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/Types.hs @@ -0,0 +1,28 @@ +-- | +-- Module: Database.PostgreSQL.Store.Types +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.Types ( + -- * General + Value (..), + TypedValue (..), + Query (..) +) where + +import qualified Data.ByteString as B +import qualified Database.PostgreSQL.LibPQ as P + +-- | Value of a cell in the result set +newtype Value = Value { valueData :: B.ByteString } + deriving (Show, Eq, Ord) + +-- | Value and type 'P.Oid' of a cell in the result set +data TypedValue = TypedValue P.Oid (Maybe Value) + deriving (Show, Eq, Ord) + +-- | Query +data Query a = Query { + queryStatement :: B.ByteString, + queryParams :: [TypedValue] +} deriving (Show, Eq, Ord) diff --git a/src/Database/PostgreSQL/Store/Utilities.hs b/src/Database/PostgreSQL/Store/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/Utilities.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: Database.PostgreSQL.Store.Utilities +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.Utilities ( + showByteString, + readByteString, + buildByteString, + liftByteString +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Data.ByteString as B +import qualified Blaze.ByteString.Builder as B +import qualified Blaze.ByteString.Builder.Char.Utf8 as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Text.Read (readMaybe) + +-- | Show as 'ByteString' +showByteString :: (Show a) => a -> B.ByteString +showByteString = + B.toByteString . B.fromString . show + +-- | Read as 'ByteString' +readByteString :: (Read a) => B.ByteString -> Maybe a +readByteString = + readMaybe . T.unpack . T.decodeUtf8 + +-- | UTF-8 correct alternative to 'fromString'. +buildByteString :: String -> B.ByteString +buildByteString = + B.toByteString . B.fromString + +-- | Lift 'ByteString'. +liftByteString :: B.ByteString -> Q Exp +liftByteString bs = + [e| B.pack $(lift (B.unpack bs)) |] diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Main (main) where - -import Test.Hspec -import Test.Database.PostgreSQL.Store - -import Data.String - -import qualified Database.PostgreSQL.LibPQ as P - -import System.Environment - -connectMaybe :: String -> IO (Maybe P.Connection) -connectMaybe info = do - con <- P.connectdb (fromString info) - status <- P.status con - - pure $ - if status == P.ConnectionOk then - Just con - else - Nothing - --- | Test entry point -main :: IO () -main = do - mbInfo <- lookupEnv "PGINFO" - mbCon <- maybe (pure Nothing) connectMaybe mbInfo - - hspec (allSpecs mbCon) diff --git a/tests/Test/Database/PostgreSQL/Store.hs b/tests/Test/Database/PostgreSQL/Store.hs deleted file mode 100644 --- a/tests/Test/Database/PostgreSQL/Store.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Test.Database.PostgreSQL.Store ( - allSpecs -) where - -import Test.Hspec - -import Test.Database.PostgreSQL.Store.Columns -import Test.Database.PostgreSQL.Store.Query -import Test.Database.PostgreSQL.Store.Table - -import qualified Database.PostgreSQL.LibPQ as P - -allSpecs :: Maybe P.Connection -> Spec -allSpecs mbCon = do - allColumnsSpecs mbCon - allTableSpecs mbCon - allQuerySpecs diff --git a/tests/Test/Database/PostgreSQL/Store/Columns.hs b/tests/Test/Database/PostgreSQL/Store/Columns.hs deleted file mode 100644 --- a/tests/Test/Database/PostgreSQL/Store/Columns.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} - -module Test.Database.PostgreSQL.Store.Columns ( - allColumnsSpecs -) where - -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Monadic - -import Control.Monad.Trans - -import Data.Int -import Data.Word -import Data.Proxy - -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Columns -import Database.PostgreSQL.Store.Result -import Database.PostgreSQL.Store.Errand - -import qualified Database.PostgreSQL.LibPQ as P - -testLivePackUnpack :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> P.Connection -> Property -testLivePackUnpack proxy con = - property $ coerceParam proxy $ \ value -> monadicIO $ do - lift $ do - res <- runErrand con (queryWith (Query "SELECT $1" [pack value]) unpackColumn) - - shouldBe res (Right [value]) - where - coerceParam :: Proxy a -> (a -> b) -> a -> b - coerceParam _ f x = f x - -testPackUnpack :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> Property -testPackUnpack proxy = - property (compare proxy) - where - compare :: (Column a, Eq a) => Proxy a -> a -> Bool - compare _ x = unpack (pack x) == Just x - -allColumnsSpecs :: Maybe P.Connection -> Spec -allColumnsSpecs mbCon = do - describe "Database.PostgreSQL.Store.Columns" $ do - describe "instance (Column a) => Column (Maybe a)" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy (Maybe Bool))) - - describe "instance Column Bool" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Bool)) - - describe "instance Column Int" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int)) - - describe "instance Column Int8" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int8)) - - describe "instance Column Int16" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int16)) - - describe "instance Column Int32" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int32)) - - describe "instance Column Int64" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int64)) - - describe "instance Column Word" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word)) - - describe "instance Column Word8" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word8)) - - describe "instance Column Word16" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word16)) - - describe "instance Column Word32" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word32)) - - describe "instance Column Word64" $ - it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word64)) - - maybe (pure ()) liveSpecs mbCon - -liveSpecs :: P.Connection -> Spec -liveSpecs con = - describe "Database.PostgreSQL.Store.Columns (live)" $ do - describe "instance Column Bool" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Bool) con) - - describe "instance Column Int" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int) con) - - describe "instance Column Int8" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int8) con) - - describe "instance Column Int16" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int16) con) - - describe "instance Column Int32" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int32) con) - - describe "instance Column Int64" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int64) con) - - describe "instance Column Word" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word) con) - - describe "instance Column Word8" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word8) con) - - describe "instance Column Word16" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word16) con) - - describe "instance Column Word32" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word32) con) - - describe "instance Column Word64" $ - it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word64) con) diff --git a/tests/Test/Database/PostgreSQL/Store/Query.hs b/tests/Test/Database/PostgreSQL/Store/Query.hs deleted file mode 100644 --- a/tests/Test/Database/PostgreSQL/Store/Query.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} - -module Test.Database.PostgreSQL.Store.Query ( - allQuerySpecs -) where - -import Test.Hspec - -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Columns - -data TestTable = TestTable - deriving (Show, Eq, Ord) - -instance QueryTable TestTable where - tableName _ = "T" - tableIDName _ = "a" - tableSelectors _ = [SelectorField "b", SelectorField "c"] - -testVariable :: Int -testVariable = 1337 - -allQuerySpecs :: Spec -allQuerySpecs = - describe "Database.PostgreSQL.Store.Query" $ - describe "pgsq" $ do - it "resolves table names" $ do - shouldBe [pgsq|@TestTable|] (Query "\"T\"" []) - shouldBe [pgsq|@Test.Database.PostgreSQL.Store.Query.TestTable|] [pgsq|@TestTable|] - shouldBe [pgsq|@TestTable.b|] (Query "\"T\".b" []) - shouldBe [pgsq|@TestTable."b"|] (Query "\"T\".\"b\"" []) - - it "resolves identifier fields" $ do - shouldBe [pgsq|&TestTable|] (Query "\"T\".\"a\"" []) - shouldBe [pgsq|&Test.Database.PostgreSQL.Store.Query.TestTable|] [pgsq|&TestTable|] - - it "resolves selectors" $ do - shouldBe [pgsq|#TestTable|] (Query "\"T\".\"b\", \"T\".\"c\"" []) - shouldBe [pgsq|#TestTable|] [pgsq|#Test.Database.PostgreSQL.Store.Query.TestTable|] - - it "embeds variables" $ do - let i = testVariable - shouldBe [pgsq|$testVariable $i|] (Query "$1 $2" [pack testVariable, pack i]) - - it "ignores operator #" $ do - shouldBe [pgsq|1 # 2|] (Query "1 # 2" []) - shouldBe [pgsq|a # b|] (Query "a # b" []) - shouldBe [pgsq|a # T|] (Query "a # T" []) - shouldBe [pgsq|a # T.a|] (Query "a # T.a" []) - shouldBe [pgsq|a # "T"|] (Query "a # \"T\"" []) - shouldBe [pgsq|a # "T"."a"|] (Query "a # \"T\".\"a\"" []) - shouldBe [pgsq|1#2|] (Query "1#2" []) - shouldBe [pgsq|a#b|] (Query "a#b" []) - shouldBe [pgsq|a#(T)|] (Query "a#(T)" []) - shouldBe [pgsq|a#(T.a)|] (Query "a#(T.a)" []) - shouldBe [pgsq|a#"T"|] (Query "a#\"T\"" []) - shouldBe [pgsq|a#"T"."a"|] (Query "a#\"T\".\"a\"" []) - - it "ignores operator &" $ do - shouldBe [pgsq|1 & 2|] (Query "1 & 2" []) - shouldBe [pgsq|a & b|] (Query "a & b" []) - shouldBe [pgsq|a & T|] (Query "a & T" []) - shouldBe [pgsq|a & T.a|] (Query "a & T.a" []) - shouldBe [pgsq|a & "T"|] (Query "a & \"T\"" []) - shouldBe [pgsq|a & "T"."a"|] (Query "a & \"T\".\"a\"" []) - shouldBe [pgsq|1&2|] (Query "1&2" []) - shouldBe [pgsq|a&b|] (Query "a&b" []) - shouldBe [pgsq|a&(T)|] (Query "a&(T)" []) - shouldBe [pgsq|a&(T.a)|] (Query "a&(T.a)" []) - shouldBe [pgsq|a&"T"|] (Query "a&\"T\"" []) - shouldBe [pgsq|a&"T"."a"|] (Query "a&\"T\".\"a\"" []) - - it "ignores operator @" $ do - shouldBe [pgsq|@-5|] (Query "@-5" []) - shouldBe [pgsq|@(-5)|] (Query "@(-5)" []) - shouldBe [pgsq|@a|] (Query "@a" []) - shouldBe [pgsq|@(a)|] (Query "@(a)" []) - shouldBe [pgsq|@(T)|] (Query "@(T)" []) - shouldBe [pgsq|@(T.a)|] (Query "@(T.a)" []) - shouldBe [pgsq|@"a"|] (Query "@\"a\"" []) - shouldBe [pgsq|@"T"|] (Query "@\"T\"" []) - shouldBe [pgsq|@"T"."a"|] (Query "@\"T\".\"a\"" []) - - it "ignores bad use of $" $ do - shouldBe [pgsq|$1|] (Query "$1" []) - shouldBe [pgsq|$(1)|] (Query "$(1)" []) - shouldBe [pgsq|$(a)|] (Query "$(a)" []) - shouldBe [pgsq|$(T)|] (Query "$(T)" []) - shouldBe [pgsq|$(T.a)|] (Query "$(T.a)" []) - shouldBe [pgsq|$"a"|] (Query "$\"a\"" []) - shouldBe [pgsq|$"T"|] (Query "$\"T\"" []) - shouldBe [pgsq|$"T"."a"|] (Query "$\"T\".\"a\"" []) diff --git a/tests/Test/Database/PostgreSQL/Store/Table.hs b/tests/Test/Database/PostgreSQL/Store/Table.hs deleted file mode 100644 --- a/tests/Test/Database/PostgreSQL/Store/Table.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} - -module Test.Database.PostgreSQL.Store.Table ( - allTableSpecs -) where - -import Test.Hspec - -import Data.Proxy - -import Database.PostgreSQL.Store.Table -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Errand - -import qualified Database.PostgreSQL.LibPQ as P - -data OnlyEvens = OnlyEvens { - value :: Int -} deriving (Show, Eq) - -mkTable ''OnlyEvens - [Unique ['value], - Check [pgss| value % 2 = 0 |]] - -allTableSpecs :: Maybe P.Connection -> Spec -allTableSpecs mbCon = do - maybe (pure ()) liveSpecs mbCon - -dropTable :: P.Connection -> IO () -dropTable con = - () <$ runErrand con (query_ [pgsq| DROP TABLE @OnlyEvens |]) - -clearTable :: P.Connection -> IO () -clearTable con = - () <$ runErrand con (query_ [pgsq| DELETE FROM @OnlyEvens |]) - -liveSpecs :: P.Connection -> Spec -liveSpecs con = - describe "Database.PostgreSQL.Store.Table (live)" $ - afterAll_ (dropTable con) $ describe "auto-generated instance Table" $ - after_ (clearTable con) $ do - it "creates tables" $ do - res1 <- runErrand con $ - query_ $(mkCreateQuery ''OnlyEvens) - shouldBe res1 (Right ()) - - -- Table exists now - let table = tableName (Proxy :: Proxy OnlyEvens) - res2 <- runErrand con $ - query [pgsq| SELECT COUNT(*) FROM pg_tables WHERE tablename = $table |] - shouldBe res2 (Right [Single (1 :: Int)]) - - it "inserts a rows" $ do - res1 <- runErrand con (insert (OnlyEvens 2)) - shouldSatisfy res1 $ \ r -> - case r of - Right (Reference _) -> True - _ -> False - - -- Has been inserted correctly - res2 <- runErrand con $ - query [pgsq| SELECT #OnlyEvens FROM @OnlyEvens |] - shouldBe res2 (Right [OnlyEvens 2]) - - it "respects constraints while inserting" $ do - -- Violate UNIQUE - res3 <- runErrand con $ do - insert (OnlyEvens 2) - insert (OnlyEvens 2) - shouldSatisfy res3 $ \ r -> - case r of - Left (ExecError _ UniqueViolation _ _ _) -> True - _ -> False - - -- Violate CHECK - res4 <- runErrand con (insert (OnlyEvens 1)) - shouldSatisfy res4 $ \ r -> - case r of - Left (ExecError _ CheckViolation _ _ _) -> True - _ -> False - - it "inserts many rows" $ do - res1 <- runErrand con (insertMany (map OnlyEvens [2, 4 .. 100])) - shouldSatisfy res1 $ \ r -> - case r of - Right xs -> length xs == 50 - _ -> False - - -- Verify that there are actually 50 present - res2 <- runErrand con $ - query [pgsq| SELECT COUNT(*) FROM @OnlyEvens |] - shouldBe res2 (Right [Single (50 :: Int)]) - - it "finds a row" $ do - res1 <- runErrand con $ do - ref <- insert (OnlyEvens 4) - find ref - shouldBe res1 (Right (OnlyEvens 4)) - - it "finds many rows" $ - pendingWith "Not yet implemented" - - it "updates a row" $ do - res1 <- runErrand con $ do - ref <- insert (OnlyEvens 4) - update ref (OnlyEvens 6) - find ref - shouldBe res1 (Right (OnlyEvens 6)) - - it "respects constraints while updating" $ do - -- Violate UNIQUE - res1 <- runErrand con $ do - insert (OnlyEvens 2) - ref <- insert (OnlyEvens 4) - update ref (OnlyEvens 2) - shouldSatisfy res1 $ \ r -> - case r of - Left (ExecError _ UniqueViolation _ _ _) -> True - _ -> False - - -- Vioate CHECK - res2 <- runErrand con $ do - ref <- insert (OnlyEvens 6) - update ref (OnlyEvens 7) - shouldSatisfy res2 $ \ r -> - case r of - Left (ExecError _ CheckViolation _ _ _) -> True - _ -> False - - it "updates many rows" $ - pendingWith "Not yet implemented" - - it "deletes a row" $ do - res1 <- runErrand con $ do - ref <- insert (OnlyEvens 2) - delete ref - shouldBe res1 (Right ()) - - it "deletes many rows" $ - pendingWith "Not yet implemented"