packages feed

pg-store (empty) → 0.0.1

raw patch · 13 files changed

+1798/−0 lines, 13 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bytestring, hspec, pg-store, postgresql-libpq, template-haskell, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,12 @@+Copyright (c) 2015, Ole Krüger+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pg-store.cabal view
@@ -0,0 +1,44 @@+name:                pg-store+version:             0.0.1+category:            Database+synopsis:            Dead simple storage interface to PostgreSQL+description:         Dead simple storage interface to PostgreSQL+homepage:            https://github.com/vapourismo/pg-store+license:             BSD3+license-file:        LICENSE+author:              Ole Krüger <ole@vprsm.de>+maintainer:          Ole Krüger <ole@vprsm.de>+copyright:           (c) Ole Krüger 2015+build-type:          Simple+cabal-version:       >= 1.10++source-repository head+  type:     git+  location: https://github.com/vapourismo/pg-store.git++library+  ghc-options:      -Wall -fprof-auto -fno-warn-unused-do-bind -fno-warn-tabs+                    -fno-warn-name-shadowing+  default-language: Haskell2010+  build-depends:    base >= 4.8.2.0 && < 5,+                    template-haskell, bytestring, text, postgresql-libpq, transformers,+                    attoparsec+  hs-source-dirs:   src+  exposed-modules:  Database.PostgreSQL.Store,+                    Database.PostgreSQL.Store.Table,+                    Database.PostgreSQL.Store.Columns,+                    Database.PostgreSQL.Store.Query,+                    Database.PostgreSQL.Store.Result,+                    Database.PostgreSQL.Store.Errand++test-suite tests+  type:             exitcode-stdio-1.0+  ghc-options:      -Wall -fprof-auto -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+  hs-source-dirs:   tests+  other-modules:    Database.PostgreSQL.Store.ColumnsSpec,+                    Database.PostgreSQL.Store.TableSpec,+                    Database.PostgreSQL.Store.QuerySpec+  main-is:          Main.hs
+ src/Database/PostgreSQL/Store.hs view
@@ -0,0 +1,34 @@+-- |+-- Module:     Database.PostgreSQL.Store+-- Copyright:  (c) Ole Krüger 2015-2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store (+	-- * Tables+	TableConstraint (..),+	mkTable,+	Row (..),+	Reference (..),++	-- * Queries+	Query (..),+	pgsq,+	mkCreateQuery,++	-- * Errands+	ResultError (..),+	ErrandError (..),+	Errand,+	runErrand,+	query,+	query_,+	insert,+	find,+	update,+	delete+) where++import Database.PostgreSQL.Store.Table+import Database.PostgreSQL.Store.Query+import Database.PostgreSQL.Store.Errand+import Database.PostgreSQL.Store.Result
+ src/Database/PostgreSQL/Store/Columns.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}++-- |+-- Module:     Database.PostgreSQL.Store.Columns+-- Copyright:  (c) Ole Krüger 2015-2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Columns (+	-- *+	Value (..),++	-- *+	ColumnDescription (..),+	makeColumnDescription,++	-- *+	sanitizeName,+	sanitizeName',+	identField,+	identField',++	-- *+	Column (..),+) where++import           Language.Haskell.TH++import           Data.Int+import           Data.Word+import           Data.Bits+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.Text.Lazy.Encoding as TL+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import           Data.ByteString.Builder+import           Data.Attoparsec.ByteString+import           Data.Attoparsec.ByteString.Char8 (signed, decimal)++import qualified Database.PostgreSQL.LibPQ as P++-- | 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 :: P.Oid,++		-- | Data value+		valueData :: B.ByteString,++		-- | Data format+		valueFormat :: P.Format+	}+	| NullValue+	deriving (Show, Eq, Ord)++-- | Description of a column+data ColumnDescription = ColumnDescription {+	-- | Type name (e.g. bool, integer)+	columnTypeName :: String,++	-- | Can the column be null?+	columnTypeNull :: Bool+} deriving (Show, Eq, Ord)++-- | Generate column description in SQL. Think @CREATE TABLE@.+makeColumnDescription :: ColumnDescription -> String+makeColumnDescription ColumnDescription {..} =+	columnTypeName ++ (if columnTypeNull then "" else " NOT NULL")++-- | Generate the sanitized representation of a name.+sanitizeName :: Name -> String+sanitizeName = show++-- | Similiar to "sanitizeName" but encloses the name in quotes.+sanitizeName' :: Name -> String+sanitizeName' name = "\"" ++ sanitizeName name ++ "\""++-- | Generate the name for the identifying field.+identField :: Name -> String+identField name = show name ++ "$id"++-- | Similiar to "identField" but encloses the name in quotes.+identField' :: Name -> String+identField' name = "\"" ++ identField name ++ "\""++-- | Column type+class Column a where+	-- | Pack column value.+	pack :: a -> Value++	-- | Unpack column value.+	unpack :: Value -> Maybe a++	-- | Descripe the column type.+	describeColumn :: Proxy a -> ColumnDescription++instance (Column a) => Column (Maybe a) where+	pack = maybe NullValue pack++	unpack NullValue = Just Nothing+	unpack val       = fmap Just (unpack val)++	describeColumn proxy =+		(describeColumn (transformProxy proxy)) {columnTypeNull = True}+		where+			transformProxy :: Proxy (Maybe a) -> Proxy a+			transformProxy _ = Proxy++instance Column Bool where+	pack v =+		Value {+			valueType   = P.Oid 16,+			valueData   = if v then "true" else "false",+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 16) "true" P.Text) = Just True+	unpack (Value (P.Oid 16) "TRUE" P.Text) = Just True+	unpack (Value (P.Oid 16) "t"    P.Text) = Just True+	unpack (Value (P.Oid 16) "y"    P.Text) = Just True+	unpack (Value (P.Oid 16) "yes"  P.Text) = Just True+	unpack (Value (P.Oid 16) "on"   P.Text) = Just True+	unpack (Value (P.Oid 16) "1"    P.Text) = Just True+	unpack (Value (P.Oid 16) _      P.Text) = Just False+	unpack _                                = Nothing++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "bool",+			columnTypeNull = False+		}++instance Column Int where+	pack n =+		Value {+			valueType   = P.Oid 23,+			valueData   = buildByteString intDec n,+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat+	unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat+	unpack _                             = Nothing++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "integer",+			columnTypeNull = False+		}++instance Column Int8 where+	pack n =+		Value {+			valueType   = P.Oid 21,+			valueData   = buildByteString int8Dec n,+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat+	unpack _                             = Nothing++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "smallint",+			columnTypeNull = False+		}++instance Column Int16 where+	pack n =+		Value {+			valueType   = P.Oid 21,+			valueData   = buildByteString int16Dec n,+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat+	unpack _                             = Nothing++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "smallint",+			columnTypeNull = False+		}++instance Column Int32 where+	pack n =+		Value {+			valueType   = P.Oid 23,+			valueData   = buildByteString int32Dec n,+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat+	unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat+	unpack _                             = Nothing+++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "integer",+			columnTypeNull = False+		}++instance Column Int64 where+	pack n =+		Value {+			valueType   = P.Oid 20,+			valueData   = buildByteString int64Dec n,+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 20) dat P.Text) = parseMaybe (signed decimal) dat+	unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat+	unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat+	unpack _                             = Nothing++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "bigint",+			columnTypeNull = False+		}++instance Column [Char] where+	pack str =+		pack (buildByteString stringUtf8 str)++	unpack val =+		T.unpack . T.decodeUtf8 <$> unpack val++	describeColumn _ =+		describeColumn (Proxy :: Proxy B.ByteString)++instance Column T.Text where+	pack txt =+		pack (T.encodeUtf8 txt)++	unpack val =+		T.decodeUtf8 <$> unpack val++	describeColumn _ =+		describeColumn (Proxy :: Proxy B.ByteString)++instance Column TL.Text where+	pack txt =+		pack (TL.encodeUtf8 txt)++	unpack val =+		TL.decodeUtf8 <$> unpack val++	describeColumn _ =+		describeColumn (Proxy :: Proxy BL.ByteString)++instance Column B.ByteString where+	pack bs =+		Value {+			valueType   = P.Oid 17,+			valueData   = toTextByteArray bs,+			valueFormat = P.Text+		}++	unpack (Value (P.Oid 17) dat P.Binary) = pure dat+	unpack (Value (P.Oid 17) dat P.Text)   = fromTextByteArray dat+	unpack _                               = Nothing++	describeColumn _ =+		ColumnDescription {+			columnTypeName = "bytea",+			columnTypeNull = False+		}++instance Column BL.ByteString where+	pack bs =+		pack (BL.toStrict bs)++	unpack val =+		BL.fromStrict <$> unpack val++	describeColumn _ =+		describeColumn (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.+fromTextByteArray :: B.ByteString -> Maybe B.ByteString+fromTextByteArray 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.+toTextByteArray :: B.ByteString -> B.ByteString+toTextByteArray 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))
+ src/Database/PostgreSQL/Store/Errand.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module:     Database.PostgreSQL.Store.Errand+-- Copyright:  (c) Ole Krüger 2015-2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Errand (+	ErrandError (..),+	Errand,+	runErrand,+	raiseErrandError,+	executeQuery,+	query,+	query_+) where++import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Reader++import qualified Data.ByteString           as B++import qualified Database.PostgreSQL.LibPQ as P+import           Database.PostgreSQL.Store.Query+import           Database.PostgreSQL.Store.Result+import           Database.PostgreSQL.Store.Columns++-- | Error during errand+data ErrandError+	= NoResult+	| ExecError P.ExecStatus (Maybe B.ByteString)+	| ResultError ResultError+	| UnexpectedEmptyResult+	| UserError String+	deriving (Show, Eq)++-- | An interaction with the database+type Errand = ReaderT P.Connection (ExceptT ErrandError IO)++-- | Run an errand.+runErrand :: P.Connection -> Errand a -> IO (Either ErrandError a)+runErrand con errand =+	runExceptT (runReaderT errand con)++-- | Raise an error.+raiseErrandError :: ErrandError -> Errand a+raiseErrandError err =+	lift (ExceptT (pure (Left err)))++-- | Execute a query and return its result.+executeQuery :: Query -> Errand P.Result+executeQuery (Query statement params) = do+	con <- ask+	lift $ do+		res <- ExceptT (transformResult <$> P.execParams con statement transformedParams P.Text)+		status <- lift (P.resultStatus res)++		case status of+			P.CommandOk -> pure res+			P.TuplesOk  -> pure res++			other -> do+				msg <- lift (P.resultErrorMessage res)+				throwE (ExecError other msg)++	where+		transformResult =+			maybe (Left NoResult) pure++		transformParam Value {..} = Just (valueType, valueData, valueFormat)+		transformParam NullValue  = Nothing++		transformedParams =+			map transformParam params++-- | Execute a query and process its result set.+-- It is essential that all fields required by the underlying result parser are present.+query :: (Result a) => Query -> Errand [a]+query qry = do+	result <- executeQuery qry+	lift (withExceptT ResultError (runResultProcessor result resultProcessor))++-- | Execute a query.+query_ :: Query -> Errand ()+query_ qry =+	() <$ executeQuery qry+
+ src/Database/PostgreSQL/Store/Query.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, BangPatterns #-}++-- |+-- Module:     Database.PostgreSQL.Store.Query+-- Copyright:  (c) Ole Krüger 2015-2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Query (+	-- * Tables+	TableDescription (..),+	DescribableTable (..),++	-- * Querying+	Query (..),+	pgsq+) where++import           Language.Haskell.TH+import           Language.Haskell.TH.Quote++import           Control.Applicative+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.State++import           Data.Char+import           Data.String+import           Data.Typeable+import           Data.Attoparsec.Text+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as B++import           Database.PostgreSQL.Store.Columns++-- | Description of a table type+data TableDescription = TableDescription {+	-- | Table name+	tableName :: String,++	-- | Identifier column name+	tableIdentifier :: String+} deriving (Show, Eq, Ord)++-- | Attach meta data to a table type+class DescribableTable a where+	-- | Describe the table.+	describeTable :: Proxy a -> TableDescription+	describeTable proxy =+		TableDescription {+			tableName = describeTableName proxy,+			tableIdentifier = describeTableIdentifier proxy+		}++	-- | Describe table name.+	describeTableName :: Proxy a -> String+	describeTableName proxy =+		tableName (describeTable proxy)++	-- | Describe table identifier.+	describeTableIdentifier :: Proxy a -> String+	describeTableIdentifier proxy =+		tableIdentifier (describeTable proxy)++-- | 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)++-- | Generate a 'Query' from a SQL statement.+--+-- = Table and column names+--+-- All plain identifiers will be treated as Haskell names. They are going to be resolved to their+-- fully-qualified and quoted version. Beware, the use of names which don't refer to a table type+-- or field will likely result in unknown table or column errors. The associated table name of a+-- type is retrieved using 'describeTableName'.+-- If you don't want a name to be resolved use a quoted identifier.+--+-- Example:+--+-- @+-- {-\# LANGUAGE QuasiQuotes \#-}+-- module MyModule where+--+-- ...+--+-- data Table = Table { myField :: Int }+-- 'mkTable' ''Table []+--+-- myQuery :: 'Query'+-- myQuery = ['pgsq'| SELECT * FROM Table WHERE myField > 1337 |]+-- @+--+-- The SQL statement associated with @myQuery@ will be:+--+-- > SELECT * FROM "MyModule.Table" WHERE "MyModule.myField" > 1337+--+-- = Variables+--+-- You can use reference variables with @$myVariable@. The variable's type has to be an instance of+-- 'Column', otherwise it cannot be attached as query parameter.+--+-- Example:+--+-- @+-- magicNumber :: Int+-- magicNumber = 1337+--+-- myQuery :: 'Query'+-- myQuery = ['pgsq'| SELECT * FROM Table WHERE myField > $magicNumber |]+-- @+--+-- = Row identifiers+--+-- Each instance of @('Table' a) => 'Row' a@, @('Table' a) => 'Reference' a@ and each row of the actual table inside the database+-- has an identifier value. These identifiers are used to reference specific rows. The identifier+-- column is exposed via the @&MyTable@ pattern. Identifier field names are resolved using+-- 'describeTableIdentifier'.+--+-- Example:+--+-- @+-- ['pgsq'| SELECT *+--        FROM TableA, TableB+--        WHERE refToB = &TableB |]+-- @+--+-- Note @refToB@ is a field of @TableA@.+-- In different circumstances one would write such query as follows.+--+-- > SELECT *+-- > FROM TableA a, Table b+-- > WHERE a.refToB = b.id+--+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")+	}++-- | List of relevant SQL keywords+reservedSQLKeywords :: [T.Text]+reservedSQLKeywords =+	["ABS", "ABSOLUTE", "ACTION", "ADD", "ALL", "ALLOCATE", "ALTER", "ANALYSE", "ANALYZE", "AND",+	 "ANY", "ARE", "ARRAY", "ARRAY_AGG", "ARRAY_MAX_CARDINALITY", "AS", "ASC", "ASENSITIVE",+	 "ASSERTION", "ASYMMETRIC", "AT", "ATOMIC", "AUTHORIZATION", "AVG", "BEGIN", "BEGIN_FRAME",+	 "BEGIN_PARTITION", "BETWEEN", "BIGINT", "BINARY", "BIT", "BIT_LENGTH", "BLOB", "BOOLEAN",+	 "BOTH", "BY", "CALL", "CALLED", "CARDINALITY", "CASCADE", "CASCADED", "CASE", "CAST", "CATALOG",+	 "CEIL", "CEILING", "CHAR", "CHARACTER", "CHARACTER_LENGTH", "CHAR_LENGTH", "CHECK", "CLOB",+	 "CLOSE", "COALESCE", "COLLATE", "COLLATION", "COLLECT", "COLUMN", "COMMIT", "CONCURRENTLY",+	 "CONDITION", "CONNECT", "CONNECTION", "CONSTRAINT", "CONSTRAINTS", "CONTAINS", "CONTINUE",+	 "CONVERT", "CORR", "CORRESPONDING", "COUNT", "COVAR_POP", "COVAR_SAMP", "CREATE", "CROSS",+	 "CUBE", "CUME_DIST", "CURRENT", "CURRENT_CATALOG", "CURRENT_DATE",+	 "CURRENT_DEFAULT_TRANSFORM_GROUP", "CURRENT_PATH", "CURRENT_ROLE",+	 "CURRENT_ROW", "CURRENT_SCHEMA", "CURRENT_TIME", "CURRENT_TIMESTAMP",+	 "CURRENT_TRANSFORM_GROUP_FOR_TYPE", "CURRENT_USER", "CURSOR", "CYCLE", "DATALINK", "DATE",+	 "DAY", "DEALLOCATE", "DEC", "DECIMAL", "DECLARE", "DEFAULT", "DEFERRABLE", "DEFERRED", "DELETE",+	 "DENSE_RANK", "DEREF", "DESC", "DESCRIBE", "DESCRIPTOR", "DETERMINISTIC", "DIAGNOSTICS",+	 "DISCONNECT", "DISTINCT", "DLNEWCOPY", "DLPREVIOUSCOPY", "DLURLCOMPLETE", "DLURLCOMPLETEONLY",+	 "DLURLCOMPLETEWRITE", "DLURLPATH", "DLURLPATHONLY", "DLURLPATHWRITE", "DLURLSCHEME",+	 "DLURLSERVER", "DLVALUE", "DO", "DOMAIN", "DOUBLE", "DROP", "DYNAMIC", "EACH", "ELEMENT",+	 "ELSE", "END", "END", "END_FRAME", "END_PARTITION", "EQUALS", "ESCAPE", "EVERY", "EXCEPT",+	 "EXCEPTION", "EXEC", "EXECUTE", "EXISTS", "EXP", "EXTERNAL", "EXTRACT", "FALSE", "FETCH",+	 "FILTER", "FIRST", "FIRST_VALUE", "FLOAT", "FLOOR", "FOR", "FOREIGN", "FOUND", "FRAME_ROW",+	 "FREE", "FREEZE", "FROM", "FULL", "FUNCTION", "FUSION", "GET", "GLOBAL", "GO", "GOTO", "GRANT",+	 "GROUP", "GROUPING", "GROUPS", "HAVING", "HOLD", "HOUR", "IDENTITY", "ILIKE", "IMMEDIATE",+	 "IMPORT", "IN", "INDICATOR", "INITIALLY", "INNER", "INOUT", "INPUT", "INSENSITIVE", "INSERT",+	 "INT", "INTEGER", "INTERSECT", "INTERSECTION", "INTERVAL", "INTO", "IS", "ISNULL", "ISOLATION",+	 "JOIN", "KEY", "LAG", "LANGUAGE", "LARGE", "LAST", "LAST_VALUE", "LATERAL", "LEAD", "LEADING",+	 "LEFT", "LEVEL", "LIKE", "LIKE_REGEX", "LIMIT", "LN", "LOCAL", "LOCALTIME", "LOCALTIMESTAMP",+	 "LOWER", "MATCH", "MAX", "MAX_CARDINALITY", "MEMBER", "MERGE", "METHOD", "MIN", "MINUTE", "MOD",+	 "MODIFIES", "MODULE", "MONTH", "MULTISET", "NAMES", "NATIONAL", "NATURAL", "NCHAR", "NCLOB",+	 "NEW", "NEXT", "NO", "NONE", "NORMALIZE", "NOT", "NOTNULL", "NTH_VALUE", "NTILE", "NULL",+	 "NULLIF", "NUMERIC", "OCCURRENCES_REGEX", "OCTET_LENGTH", "OF", "OFFSET", "OLD", "ON", "ONLY",+	 "OPEN", "OPTION", "OR", "ORDER", "OUT", "OUTER", "OUTPUT", "OVER", "OVERLAPS", "OVERLAY", "PAD",+	 "PARAMETER", "PARTIAL", "PARTITION", "PERCENT", "PERCENTILE_CONT", "PERCENTILE_DISC",+	 "PERCENT_RANK", "PERIOD", "PLACING", "PORTION", "POSITION", "POSITION_REGEX", "POWER",+	 "PRECEDES", "PRECISION", "PREPARE", "PRESERVE", "PRIMARY", "PRIOR", "PRIVILEGES", "PROCEDURE",+	 "PUBLIC", "RANGE", "RANK", "READ", "READS", "REAL", "RECURSIVE", "REF", "REFERENCES",+	 "REFERENCING", "REGR_AVGX", "REGR_AVGY", "REGR_COUNT", "REGR_INTERCEPT", "REGR_R2",+	 "REGR_SLOPE", "REGR_SXX", "REGR_SXY", "REGR_SYY", "RELATIVE", "RELEASE", "RESTRICT", "RESULT",+	 "RETURN", "RETURNING", "RETURNS", "REVOKE", "RIGHT", "ROLLBACK", "ROLLUP", "ROW", "ROWS",+	 "ROW_NUMBER", "SAVEPOINT", "SCHEMA", "SCOPE", "SCROLL", "SEARCH", "SECOND", "SECTION", "SELECT",+	 "SENSITIVE", "SESSION", "SESSION_USER", "SET", "SIMILAR", "SIZE", "SMALLINT", "SOME", "SPACE",+	 "SPECIFIC", "SPECIFICTYPE", "SQL", "SQLCODE", "SQLERROR", "SQLEXCEPTION", "SQLSTATE",+	 "SQLWARNING", "SQRT", "START", "STATIC", "STDDEV_POP", "STDDEV_SAMP", "SUBMULTISET",+	 "SUBSTRING", "SUBSTRING_REGEX", "SUCCEEDS", "SUM", "SYMMETRIC", "SYSTEM", "SYSTEM_TIME",+	 "SYSTEM_USER", "TABLE", "TABLESAMPLE", "TEMPORARY", "THEN", "TIME", "TIMESTAMP",+	 "TIMEZONE_HOUR", "TIMEZONE_MINUTE", "TO", "TRAILING", "TRANSACTION", "TRANSLATE",+	 "TRANSLATE_REGEX", "TRANSLATION", "TREAT", "TRIGGER", "TRIM", "TRIM_ARRAY", "TRUE", "TRUNCATE",+	 "UESCAPE", "UNION", "UNIQUE", "UNKNOWN", "UNNEST", "UPDATE", "UPPER", "USAGE", "USER", "USING",+	 "VALUE", "VALUES", "VALUE_OF", "VARBINARY", "VARCHAR", "VARIADIC", "VARYING", "VAR_POP",+	 "VAR_SAMP", "VERBOSE", "VERSIONING", "VIEW", "WHEN", "WHENEVER", "WHERE", "WIDTH_BUCKET",+	 "WINDOW", "WITH", "WITHIN", "WITHOUT", "WORK", "WRITE", "XML", "XMLAGG", "XMLATTRIBUTES",+	 "XMLBINARY", "XMLCAST", "XMLCOMMENT", "XMLCONCAT", "XMLDOCUMENT", "XMLELEMENT", "XMLEXISTS",+	 "XMLFOREST", "XMLITERATE", "XMLNAMESPACES", "XMLPARSE", "XMLPI", "XMLQUERY", "XMLSERIALIZE",+	 "XMLTABLE", "XMLTEXT", "XMLVALIDATE", "YEAR", "ZONE"]++-- | Query segment+data Segment+	= Keyword T.Text+	| PossibleName T.Text+	| Variable T.Text+	| Identifier T.Text+	| Quote Char T.Text+	| Other Char++-- | SQL keyword+keyword :: Parser Segment+keyword =+	Keyword <$> choice (asciiCI <$> reservedSQLKeywords)++-- | Alpha numeric character+alphaNum :: Parser Char+alphaNum = satisfy isAlphaNum++-- | Underscore+underscore :: Parser Char+underscore = char '_'++-- | Dot+dot :: Parser Char+dot = char '.'++-- | Name+name :: Parser T.Text+name =+	bake <$> (letter <|> underscore) <*> many (alphaNum <|> underscore <|> dot)+	where+		bake h t = T.pack (h : t)++-- | Possible name+possibleName :: Parser Segment+possibleName =+	PossibleName <$> name++-- | Variable+variable :: Parser Segment+variable = do+	char '$'+	Variable <$> name++-- | Identifier+identifier :: Parser Segment+identifier = do+	char '&'+	Identifier <$> name++-- | Quote+quote :: Char -> Parser Segment+quote delim = do+	char delim+	cnt <- scan (False, T.empty) scanner+	char delim+	pure (Quote delim cnt)+	where+		scanner (False, _) chr | chr == delim = Nothing+		scanner (esc, cnt) chr = Just (not esc && chr == '\\', cnt `T.snoc` chr)++-- | Segments+segments :: Parser [Segment]+segments =+	many (choice [+		quote '"',+		quote '\'',+		variable,+		identifier,+		keyword,+		possibleName,+		Other <$> anyChar+	])++-- | Turn "Text" into a UTF-8-encoded "ByteString" expression.+textE :: T.Text -> StateT (Int, [Exp]) Q Exp+textE txt =+	lift (stringE (T.unpack txt))++-- | Reduce segments in order to resolve names and collect query parameters.+reduceSegment :: Segment -> StateT (Int, [Exp]) Q Exp+reduceSegment seg =+	case seg of+		Keyword kw ->+			textE kw++		Other o ->+			lift (stringE [o])++		Quote delim cnt ->+			lift (stringE (delim : T.unpack cnt ++ [delim]))++		Variable varName -> do+			mbName <- lift (lookupValueName (T.unpack varName))+			case mbName of+				Just name -> do+					-- Generate the pack expression+					lit <- lift [e| pack $(varE name) |]++					-- Register parameter+					(numParams, params) <- get+					put (numParams + 1, params ++ [lit])++					lift (stringE ("$" ++ show (numParams + 1)))++				Nothing ->+					lift (fail ("\ESC[34m" ++ T.unpack varName +++					            "\ESC[0m does not refer to anything"))++		PossibleName posName -> do+			let strName = T.unpack posName+			mbName <- lift ((,) <$> lookupTypeName strName <*> lookupValueName strName)+			case mbName of+				(Just typName, _) ->+					lift [e| "\"" ++ describeTableName (Proxy :: Proxy $(conT typName)) ++ "\"" |]++				(_, Just varName) ->+					lift (stringE (sanitizeName' varName))++				_ -> textE posName++		Identifier idnName -> do+			mbName <- lift (lookupTypeName (T.unpack idnName))+			case mbName of+				Just name ->+					lift [e| "\"" ++ describeTableIdentifier (Proxy :: Proxy $(conT name)) ++ "\"" |]++				Nothing ->+					lift (fail ("\ESC[34m" ++ T.unpack idnName +++					            "\ESC[0m does not refer to anything"))++-- | Parse quasi-quoted PG Store Query.+parseStoreQueryE :: String -> Q Exp+parseStoreQueryE code = do+	case parseOnly segments (fromString code) of+		Left msg ->+			fail msg++		Right xs -> do+			(parts, (_, params)) <- runStateT (mapM reduceSegment xs) (0, [])+			[e| Query {+			        queryStatement = T.encodeUtf8 (T.pack (concat $(pure (ListE parts)))),+			        queryParams    = $(pure (ListE params))+			    } |]
+ src/Database/PostgreSQL/Store/Result.hs view
@@ -0,0 +1,192 @@+-- |+-- Module:     Database.PostgreSQL.Store.Result+-- Copyright:  (c) Ole Krüger 2015-2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Result (+	-- *+	ResultError (..),+	ResultProcessor,+	ColumnInfo,+	runResultProcessor,+	columnNumber,+	columnType,+	columnFormat,+	columnInfo,+	foreachRow,+	cellValue,+	unpackCellValue,++	-- * Result+	Result (..),+	RawRow (..)+) where++import           Control.Monad+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Except++import           Data.List+import           Data.Typeable+import qualified Data.ByteString           as B++import qualified Database.PostgreSQL.LibPQ as P+import           Database.PostgreSQL.Store.Columns++-- | Error that occured during result processing+data ResultError+	= ColumnMissing B.ByteString+	| ValueError P.Row P.Column P.Oid P.Format ColumnDescription+	deriving (Show, Eq)++-- | Result processor+type ResultProcessor = ReaderT P.Result (ExceptT ResultError IO)++-- | Column information+type ColumnInfo = (P.Column, P.Oid, P.Format)++-- | Process the result.+runResultProcessor :: P.Result -> ResultProcessor a -> ExceptT ResultError IO a+runResultProcessor = flip runReaderT++-- | Get the number of columns.+numColumns :: ResultProcessor P.Column+numColumns = do+	result <- ask+	lift (lift (P.nfields result))++-- | Get the column number for a column name.+columnNumber :: B.ByteString -> ResultProcessor P.Column+columnNumber name = do+	result <- ask+	lift (ExceptT (maybe (Left (ColumnMissing name)) pure <$> P.fnumber result name))++-- | Get the type of a column.+columnType :: P.Column -> ResultProcessor P.Oid+columnType col = do+	result <- ask+	lift (lift (P.ftype result col))++-- | Get the format of a column.+columnFormat :: P.Column -> ResultProcessor P.Format+columnFormat col = do+	result <- ask+	lift (lift (P.fformat result col))++-- | Get information about a column.+columnInfo :: B.ByteString -> ResultProcessor ColumnInfo+columnInfo name = do+	col <- columnNumber name+	(,,) col <$> columnType col <*> columnFormat col++-- | Do something for each row.+foreachRow :: (P.Row -> ResultProcessor a) -> ResultProcessor [a]+foreachRow rowProcessor = do+	result <- ask+	numRows <- lift (lift (P.ntuples result))+	mapM rowProcessor [0 .. numRows - 1]++-- | Get cell value.+cellValue :: P.Row -> ColumnInfo -> ResultProcessor Value+cellValue row (col, oid, fmt) = do+	result <- ask+	value <- lift (lift (P.getvalue' result row col))++	case value of+		Just dat -> pure (Value oid dat fmt)+		Nothing  -> pure NullValue++-- | Get cell value.+cellValue' :: P.Row -> P.Column -> ResultProcessor Value+cellValue' row col = do+	result <- ask+	(oid, fmt, value) <- lift (lift ((,,) <$> P.ftype result col+	                                      <*> P.fformat result col+	                                      <*> P.getvalue' result row col))++	case value of+		Just dat -> pure (Value oid dat fmt)+		Nothing  -> pure NullValue+++-- | Unpack cell value.+unpackCellValue :: (Column a) => P.Row -> ColumnInfo -> ResultProcessor a+unpackCellValue row info =+	withProxy Proxy+	where+		withProxy :: (Column a) => Proxy a -> ResultProcessor a+		withProxy proxy = do+			value <- cellValue row info+			lift (ExceptT (make (describeColumn proxy) (unpack value)))++		(col, oid, fmt) = info++		valueError desc =+			pure (Left (ValueError row col oid fmt desc))++		make desc =+			maybe (valueError desc) (pure . pure)++-- | Result row+class Result a where+	-- | Extract rows from the given result.+	resultProcessor :: ResultProcessor [a]++instance Result () where+	resultProcessor = foreachRow (const (pure ()))++instance (Result a, Result b) => Result (a, b) where+	resultProcessor =+		zip <$> resultProcessor+		    <*> resultProcessor++instance (Result a, Result b, Result c) => Result (a, b, c) where+	resultProcessor =+		zip3 <$> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor++instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where+	resultProcessor =+		zip4 <$> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor++instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where+	resultProcessor =+		zip5 <$> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor++instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where+	resultProcessor =+		zip6 <$> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor++instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where+	resultProcessor =+		zip7 <$> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor+		     <*> resultProcessor++-- | A row containing all a list of all column values.+newtype RawRow = RawRow [Value]+	deriving (Show, Eq, Ord)++instance Result RawRow where+	resultProcessor = do+		ncols <- numColumns+		foreachRow $ \ row ->+			RawRow <$> forM [0 .. ncols - 1] (cellValue' row)
+ src/Database/PostgreSQL/Store/Table.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns #-}++-- |+-- Module:     Database.PostgreSQL.Store.Table+-- Copyright:  (c) Ole Krüger 2015-2016+-- License:    BSD3+-- Maintainer: Ole Krüger <ole@vprsm.de>+module Database.PostgreSQL.Store.Table (+	TableDescription (..),+	Table (..),+	Row (..),+	Reference (..),+	HasID (..),+	TableConstraint (..),+	mkTable,+	mkCreateQuery+) where++import Control.Monad+import Control.Monad.Trans.Class++import Data.Int+import Data.List+import Data.String+import Data.Typeable++import Language.Haskell.TH++import Database.PostgreSQL.Store.Query+import Database.PostgreSQL.Store.Columns+import Database.PostgreSQL.Store.Result+import Database.PostgreSQL.Store.Errand++-- | Resolved row+data Row a = Row {+	-- | Identifier+	rowID :: !Int64,++	-- | Value+	rowValue :: !a+} deriving (Show, Eq, Ord)++-- | Reference to a row+newtype Reference a = Reference Int64+	deriving (Show, Eq, Ord)++instance (Table a) => Column (Reference a) where+	pack ref =+		pack (referenceID ref)++	unpack val =+		Reference <$> unpack val++	describeColumn proxy =+		ColumnDescription {+			columnTypeName = "bigint references \"" ++ tableName ++ "\" (\"" ++ tableIdentifier ++ "\")",+			columnTypeNull = False+		}+		where+			coerceProxy :: Proxy (Reference a) -> Proxy a+			coerceProxy _ = Proxy++			TableDescription {..} =+				describeTable (coerceProxy proxy)++class (DescribableTable a) => Table a where+	-- | Insert a row into the table and return a 'Reference' to the inserted row.+	insert :: a -> Errand (Reference a)++	-- | Find the row identified by the given reference.+	find :: (HasID i) => i a -> Errand (Row a)++	-- | Update an existing row.+	update :: (HasID i) => i a -> a -> Errand ()++	-- | Delete a row from the table.+	delete :: (HasID i) => i a -> Errand ()++	-- | Generate the query which creates this table inside the database.+	-- Use @mkCreateQuery@ for convenience.+	createQuery :: Proxy a -> Query++	-- | Extract rows from a result set.+	tableResultProcessor :: ResultProcessor [Row a]++	-- | Extract only a 'Reference' to each row.+	tableRefResultProcessor :: ResultProcessor [Reference a]++instance (Table a) => Result (Row a) where+	resultProcessor = tableResultProcessor++instance (Table a) => Result (Reference a) where+	resultProcessor = tableRefResultProcessor++-- | A value of that type contains an ID.+class HasID a where+	-- | Retrieve the underlying ID.+	referenceID :: a b -> Int64++instance HasID Row where+	referenceID (Row rid _) = rid++instance HasID Reference where+	referenceID (Reference rid) = rid++-- | Unqualify a name.+unqualifyName :: Name -> Name+unqualifyName = mkName . nameBase++-- | Generate the insert query for a table.+insertQueryE :: Name -> [Name] -> Q Exp+insertQueryE name fields =+	[e| fromString $(stringE query) |]+	where+		query =+			"INSERT INTO " ++ sanitizeName' name ++ " (" +++				intercalate ", " columns +++			") VALUES (" +++				intercalate ", " values +++			") RETURNING " ++ identField' name++		columns =+			map (\ nm -> "\"" ++ sanitizeName nm ++ "\"") fields++		values =+			map (\ idx -> "$" ++ show idx) [1 .. length fields]++-- | Generate the select query for a table row.+findQueryE :: Name -> Q Exp+findQueryE name =+	[e| fromString $(stringE query) |]+	where+		query =+			"SELECT * FROM " ++ sanitizeName' name +++			" WHERE " ++ identField' name ++ " = $1 LIMIT 1"++-- | Generate the update query for a table.+updateQueryE :: Name -> [Name] -> Q Exp+updateQueryE name fields =+	[e| fromString $(stringE query) |]+	where+		query =+			"UPDATE " ++ sanitizeName' name +++			" SET " ++ intercalate ", " values +++			" WHERE " ++ identField' name ++ " = $1"++		values =+			map (\ (nm, idx) -> sanitizeName' nm ++ " = $" ++ show idx)+			    (zip fields [2 .. length fields + 1])++-- | Generate the delete query for a table.+deleteQueryE :: Name -> Q Exp+deleteQueryE name =+	[e| fromString $(stringE query) |]+	where+		query =+			"DELETE FROM " ++ sanitizeName' name +++			" WHERE " ++ identField' name ++ " = $1"++-- | Generate the create query for a table.+createQueryE :: Name -> [(Name, Type)] -> [TableConstraint] -> Q Exp+createQueryE name fields constraints =+	[e| fromString ($(stringE queryBegin) +++	                intercalate ", " ($(stringE anchorDescription) :+	                                  $fieldList +++	                                  $constraintList) +++	                $(stringE queryEnd)) |]+	where+		queryBegin = "CREATE TABLE IF NOT EXISTS " ++ sanitizeName' name ++ " ("+		queryEnd = ")"++		anchorDescription =+			identField' name ++ " BIGSERIAL NOT NULL PRIMARY KEY"++		fieldList =+			ListE <$> mapM describeField fields++		describeField (fname, ftype) =+			[e| $(stringE (sanitizeName' fname)) ++ " " +++			    makeColumnDescription (describeColumn (Proxy :: Proxy $(pure ftype))) |]++		constraintList =+			ListE <$> mapM describeConstraint constraints++		describeConstraint cont =+			case cont of+				Unique names ->+					stringE ("UNIQUE (" ++ intercalate ", " (map sanitizeName' names) ++ ")")++				ForeignKey names table tableNames ->+					stringE ("FOREIGN KEY (" ++ intercalate ", " (map sanitizeName' names) +++					         ") REFERENCES " ++ sanitizeName' table +++					         "(" ++ intercalate ", " (map sanitizeName' tableNames) ++ ")")++-- | Generate an expression which gathers all records from a type and packs them into a list.+-- `packParamsE 'row ['field1, 'field2]` generates `[pack (field1 row), pack (field2 row)]`+packParamsE :: Name -> [Name] -> Q Exp+packParamsE row fields =+	ListE <$> mapM extract fields+	where+		extract name =+			[e| pack ($(varE name) $(varE row)) |]++-- | Generate an expression which gathers information about a column.+columnInfoE :: Name -> Q Exp+columnInfoE name =+	[e| columnInfo (fromString $(stringE (sanitizeName' name))) |]++-- | Generate a query which binds information about a column to the column's info name.+bindColumnInfoS :: Name -> Q Stmt+bindColumnInfoS name =+	BindS (VarP (columnInfoName name)) <$> columnInfoE name++-- | Generate a name which is reserved for information about a column.+columnInfoName :: Name -> Name+columnInfoName name =+	mkName (nameBase name ++ "_info")++-- | Generate an expression which unpacks a column at a given row.+unpackColumnE :: Name -> Name -> Q Exp+unpackColumnE row name =+	[e| unpackCellValue $(varE row) $(varE (columnInfoName name)) |]++-- | Generate a query which binds the unpacked data for a column at a given row to the column's name.+bindColumnS :: Name -> Name -> Q Stmt+bindColumnS row name =+	BindS (VarP (unqualifyName name)) <$> unpackColumnE row name++-- | Generate an expression which uses a record constructor with variables that correspond to its fields.+constructRecordE :: Name -> [Name] -> Q Exp+constructRecordE ctor fields =+	[e| lift (pure $(pure construction)) |]+	where+		construction = RecConE ctor (map (\ n -> (n, VarE (unqualifyName n))) fields)++-- | Generate an expression which unpacks a table instance from a given row.+unpackRowE :: Name -> Name -> [Name] -> Q Exp+unpackRowE ctor row fields = do+	boundFields <- mapM (bindColumnS row) fields+	unboundConstruction <- constructRecordE ctor fields+	pure (DoE (boundFields ++ [NoBindS unboundConstruction]))++-- | Generate an expression which traverses all rows in order to unpack table instances from them.+unpackRowsE :: Name -> Name -> [Name] -> Q Exp+unpackRowsE table ctor fields =+	[e| do idNfo <- columnInfo (fromString $(stringE (identField' table)))+	       foreachRow $ \ row ->+	           Row <$> unpackCellValue row idNfo+	               <*> $(unpackRowE ctor 'row fields) |]++-- | Generate an expression which retrieves a table instance from each row.+tableResultProcessorE :: Name -> Name -> [Name] -> Q Exp+tableResultProcessorE table ctor fields = do+	infoBinds <- mapM bindColumnInfoS fields+	rowTraversal <- unpackRowsE table ctor fields+	pure (DoE (infoBinds ++ [NoBindS rowTraversal]))++-- | Generate an expression which retrieves a reference to each row.+tableRefResultProcessorE :: Name -> Q Exp+tableRefResultProcessorE table =+	[e| do idNfo <- columnInfo (fromString $(stringE (identField' table)))+	       foreachRow (\ row -> Reference <$> unpackCellValue row idNfo) |]++-- | Implement an instance 'Table' for the given type.+implementTableD :: Name -> Name -> [(Name, Type)] -> [TableConstraint] -> Q [Dec]+implementTableD table ctor fields constraints =+	[d| instance DescribableTable $(conT table) where+	        describeTableName _ =+	            $(stringE (sanitizeName table))++	        describeTableIdentifier _ =+	            $(stringE (identField table))++	    instance Table $(conT table) where+	        insert row = do+	            rs <- query Query {+	                queryStatement = $(insertQueryE table fieldNames),+	                queryParams    = $(packParamsE 'row fieldNames)+	            }++	            case rs of+	                (ref : _) -> pure ref+	                _         -> raiseErrandError UnexpectedEmptyResult++	        find ref = do+	            rs <- query Query {+	                queryStatement = $(findQueryE table),+	                queryParams    = [pack (referenceID ref)]+	            }++	            case rs of+	                (row : _) -> pure row+	                _         -> raiseErrandError UnexpectedEmptyResult++	        update ref row =+	            query_ Query {+	                queryStatement = $(updateQueryE table fieldNames),+	                queryParams    = pack (referenceID ref) : $(packParamsE 'row fieldNames)+	            }++	        delete ref =+	            query_ Query {+	                queryStatement = $(deleteQueryE table),+	                queryParams    = [pack (referenceID ref)]+	            }++	        createQuery _ =+	            Query {+	                queryStatement = $(createQueryE table fields constraints),+	                queryParams    = []+	            }++	        tableResultProcessor =+	            $(tableResultProcessorE table ctor fieldNames)++	        tableRefResultProcessor =+	            $(tableRefResultProcessorE table) |]+	where+		fieldNames = map fst fields++-- | Check that all field types have an instance of Column.+validateFields :: [(Name, Type)] -> Q ()+validateFields fields =+	forM_ fields $ \ (name, typ) -> do+		ii <- isInstance ''Column [typ]+		unless ii $+			fail ("\ESC[35m" ++ show name ++ "\ESC[0m's type does not have an instance of \ESC[34mColumn\ESC[0m")++-- | Options to 'mkTable'.+data TableConstraint+	= Unique [Name]+	  -- ^ A combination of fields must be unique.+	  --   @Unique ['name1, 'name2, ...]@ works analogous to the following table constraint:+	  --   @UNIQUE (name1, name2, ...)@+	| ForeignKey [Name] Name [Name]+	  -- ^ A combination of fields references another combination of fields from a different table.+	  --   @ForeignKey ['name1, 'name2, ...] ''RefTable ['refname1, 'refname2, ...]@ works like this+	  --   table constraint in SQL:+	  --   @FOREIGN KEY (name1, name2, ...) REFERENCES RefTable(refname1, refname2, ...)@+	deriving (Show, Eq, Ord)++-- | Implement 'Table' for a data 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 \#-}+-- 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 []+--+-- data MovieCast = MovieCast {+--     movieCastMovie :: 'Reference' Movie,+--     movieCastActor :: 'Reference' Actor+-- } deriving Show+--+-- 'mkTable' ''MovieCast []+-- @+--+mkTable :: Name -> [TableConstraint] -> Q [Dec]+mkTable name constraints = do+	info <- reify name+	case info of+		TyConI dec ->+			case dec of+				DataD [] _ [] [RecC ctor records@(_ : _)] _ -> do+					let fields = map (\ (fn, _, ft) -> (fn, ft)) records+					validateFields fields+					implementTableD name ctor fields constraints++				DataD (_ : _) _ _ _ _ ->+					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has a context")++				DataD _ _ (_ : _) _ _ ->+					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has one or more type variables")++				DataD _ _ _ [] _ ->+					fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a constructor")++				DataD _ _ _ (_ : _ : _) _ ->+					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has more than one constructor")++				DataD _ _ _ [RecC _ []] _ ->+					fail ("\ESC[34m" ++ show name ++ "\ESC[0m has an empty record constructor")++				DataD _ _ _ [_] _ ->+					fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a record constructor")++				_ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not an eligible data type")++		_ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not a type constructor")++-- | 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++-- | Generate a 'Query' which will create the table described my 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.")++	-- Actual splice+	[e| createQuery (Proxy :: Proxy $(pure (ConT name))) |]
+ tests/Database/PostgreSQL/Store/ColumnsSpec.hs view
@@ -0,0 +1,121 @@+module Database.PostgreSQL.Store.ColumnsSpec (columnsSpec) where++import           Data.Int+import           Data.Typeable+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import           Test.QuickCheck+import           Test.Hspec++import           Database.PostgreSQL.Store.Columns++-- | Pack and unpack value to test if the input value is the same as the output value.+testColumnIsomorphism :: (Column a, Show a, Eq a) => a -> Expectation+testColumnIsomorphism val =+	shouldBe (unpack (pack val)) (Just val)++-- | Quick check an instance of Column to see if it behaves isomorphic.+propColumnIsomorphism :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> Property+propColumnIsomorphism proxy =+	property (compare proxy)+	where+		compare :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> a -> Bool+		compare _ x =+			unpack (pack x) == Just x++-- | Quick check an instance of Column which has to be generated first, because it does not have an+--   instance of Arbitrary.+propColumnIsomorphism' :: (Arbitrary b, Show b, Column a, Eq a, Show a) => ([b] -> a) -> Property+propColumnIsomorphism' make =+	property (\ xs -> unpack (pack (make xs)) == Just (make xs))++-- | Test for instances of Column+columnsSpec :: Spec+columnsSpec = do+	describe "instance Column Bool" $+		it "must behave isomorphic" $ do+			testColumnIsomorphism True+			testColumnIsomorphism False++	describe "instance Column Int" $ do+		it "must behave isomorphic" $ do+			testColumnIsomorphism (minBound :: Int)+			testColumnIsomorphism (0 :: Int)+			testColumnIsomorphism (maxBound :: Int)++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism (Proxy :: Proxy Int)++	describe "instance Column Int8" $ do+		it "must behave isomorphic" $ do+			testColumnIsomorphism (minBound :: Int8)+			testColumnIsomorphism (0 :: Int8)+			testColumnIsomorphism (maxBound :: Int8)++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism (Proxy :: Proxy Int8)++	describe "instance Column Int16" $ do+		it "must behave isomorphic" $ do+			testColumnIsomorphism (minBound :: Int16)+			testColumnIsomorphism (0 :: Int16)+			testColumnIsomorphism (maxBound :: Int16)++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism (Proxy :: Proxy Int16)++	describe "instance Column Int32" $ do+		it "must behave isomorphic" $ do+			testColumnIsomorphism (minBound :: Int32)+			testColumnIsomorphism (0 :: Int32)+			testColumnIsomorphism (maxBound :: Int32)++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism (Proxy :: Proxy Int32)++	describe "instance Column Int64" $ do+		it "must behave isomorphic" $ do+			testColumnIsomorphism (minBound :: Int64)+			testColumnIsomorphism (0 :: Int64)+			testColumnIsomorphism (maxBound :: Int64)++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism (Proxy :: Proxy Int64)++	describe "instance Column [Char]" $ do+		it "must behave isomorphic" $+			testColumnIsomorphism ([] :: [Char])++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism (Proxy :: Proxy [Char])++	describe "instance Column B.ByteString" $ do+		it "must behave isomorphic" $+			testColumnIsomorphism B.empty++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism' B.pack++	describe "instance Column BL.ByteString" $ do+		it "must behave isomorphic" $+			testColumnIsomorphism BL.empty++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism' BL.pack++	describe "instance Column T.Text" $ do+		it "must behave isomorphic" $+			testColumnIsomorphism T.empty++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism' T.pack++	describe "instance Column TL.Text" $ do+		it "must behave isomorphic" $+			testColumnIsomorphism TL.empty++		it "must behave isomorphic (using QuickCheck)" $+			propColumnIsomorphism' TL.pack
+ tests/Database/PostgreSQL/Store/QuerySpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}++module Database.PostgreSQL.Store.QuerySpec (querySpec) where++import Test.Hspec++import Data.String+import Data.Typeable++import Database.PostgreSQL.Store+import Database.PostgreSQL.Store.Query+import Database.PostgreSQL.Store.Columns++data MyType = MyConstructor Int+	deriving (Show)++instance DescribableTable MyType where+	describeTableName _ = "InsertTableName"+	describeTableIdentifier _ = "InsertTableIdentifier"++testValue :: Int+testValue = 1337++querySpec :: Spec+querySpec =+	describe "parseStoreQueryE" $ do+		it "must resolve tables names correctly" $+			queryStatement [pgsq|MyType|]+				`shouldBe` fromString ("\"" ++ describeTableName (Proxy :: Proxy MyType) ++ "\"")++		it "must resolve identifier column names correctly" $+			queryStatement [pgsq|&MyType|]+				`shouldBe` fromString ("\"" ++ describeTableIdentifier (Proxy :: Proxy MyType) ++ "\"")++		it "must insert and pack variables correctly" $+			[pgsq|$testValue|] `shouldBe` Query "$1" [pack testValue]
+ tests/Database/PostgreSQL/Store/TableSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-}++module Database.PostgreSQL.Store.TableSpec (tableSpec) where++import           Test.Hspec+import           Test.QuickCheck+import           Test.QuickCheck.Monadic++import           Data.Int+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+import qualified Database.PostgreSQL.LibPQ as P++data TestTable = TestTable {+	ttBool           :: Bool,+	ttInt            :: Int,+	ttInt8           :: Int8,+	ttInt16          :: Int16,+	ttInt32          :: Int32,+	ttInt64          :: Int64,+	ttString         :: String,+	ttText           :: T.Text,+	ttLazyText       :: TL.Text,+	ttByteString     :: B.ByteString,+	ttLazyByteString :: BL.ByteString,+	ttMaybeInt       :: Maybe Int+} deriving (Show, Eq, Ord)++instance Arbitrary TestTable where+	arbitrary =+		TestTable <$> arbitrary+		          <*> arbitrary+		          <*> arbitrary+		          <*> arbitrary+		          <*> arbitrary+		          <*> arbitrary+		          <*> arbitrary+		          <*> fmap T.pack arbitrary+		          <*> fmap TL.pack arbitrary+		          <*> fmap B.pack arbitrary+		          <*> fmap BL.pack arbitrary+		          <*> arbitrary++mkTable ''TestTable []++tableSpec :: P.Connection -> Spec+tableSpec con = do+	describe "Table" $ do+		it "create" $ do+			result <- runErrand con (query_ $(mkCreateQuery ''TestTable)) :: IO (Either ErrandError ())+			result `shouldBe` Right ()++	describe "Row" $ do+		it "insert/find/update/find/delete" $ monadicIO $ do+			row1 <- pick arbitrary :: PropertyM IO TestTable+			eRef <- run (runErrand con (insert row1))++			assert $+				case eRef of+					Right (Reference _) -> True+					_                   -> False++			let Right ref = eRef+			eRow1 <- run (runErrand con (find ref))++			assert $+				case eRow1 of+					Right (Row _ row1') -> row1' == row1+					_                   -> False++			row2 <- pick arbitrary :: PropertyM IO TestTable+			eUpdate <- run (runErrand con (update ref row2))++			assert (eUpdate == Right ())++			eRow2 <- run (runErrand con (find ref))++			assert $+				case eRow2 of+					Right (Row _ row2') -> row2' == row2+					_                   -> False++			eDelete <- run (runErrand con (delete ref))++			assert (eDelete == Right ())++	describe "Table" $ do+		it "drop" $ do+			result <- runErrand con (query_ [pgsq| DROP TABLE TestTable |]) :: IO (Either ErrandError ())+			result `shouldBe` Right ()
+ tests/Main.hs view
@@ -0,0 +1,40 @@+module Main (main) where++import           Test.Hspec++import           Control.Monad++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import           Database.PostgreSQL.Store.ColumnsSpec+import           Database.PostgreSQL.Store.TableSpec+import           Database.PostgreSQL.Store.QuerySpec+import qualified Database.PostgreSQL.LibPQ as P++import           System.Environment++-- | Test which will only be executed if 'PGINFO' environment variable is set+liveTests :: String -> Spec+liveTests pgInfo = do+	(con, status) <- runIO $ do+		con <- P.connectdb (T.encodeUtf8 (T.pack pgInfo))+		status <- P.status con+		pure (con, status)++	describe "Database connection" $+		it "must be established" $+			status `shouldBe` P.ConnectionOk++	when (status == P.ConnectionOk) (afterAll_ (P.finish con) (tableSpec con))++-- | Test entry point+main :: IO ()+main = hspec $ do+	columnsSpec+	querySpec++	mbPGInfo <- runIO (lookupEnv "PGINFO")+	case mbPGInfo of+		Just pgInfo -> liveTests pgInfo+		Nothing     -> runIO (putStrLn "Environment variable 'PGINFO' is missing")