diff --git a/.gitignore b/.gitignore index 9b1c8b1..9ef9cf4 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,8 @@ /dist +/.stack-work/ +/errcodes +/errcodes.hi +/errcodes.o +/.ghc.environment.* +/result* +/dist* diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..9debdb8 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,3 @@ +language: nix +script: + - nix-build nix/release.nix diff --git a/COPYING b/COPYING index 8437b9f..95909fc 100644 --- a/COPYING +++ b/COPYING @@ -1,4 +1,5 @@ -Copyright (c) 2010, 2011, Chris Forno +Copyright (c) 2014-2017, Dylan Simon +Portions Copyright (c) 2010, 2011, Chris Forno All rights reserved. Redistribution and use in source and binary forms, with or without @@ -8,9 +9,9 @@ modification, are permitted provided that the following conditions are met: * 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. - * Neither the name of Chris Forno nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. + * Neither the name of postgresql-typed 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 diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs new file mode 100644 index 0000000..2844dcf --- /dev/null +++ b/Database/PostgreSQL/Typed.hs @@ -0,0 +1,218 @@ +-- Copyright 2010, 2011, 2012, 2013 Chris Forno +-- Copyright 2014-2015 Dylan Simon + +module Database.PostgreSQL.Typed + ( + -- *Introduction + -- $intro + + PGError(..) + + -- *Usage + -- $usage + + -- **Connections + -- $connect + + , PGDatabase(..) + , defaultPGDatabase + , PGConnection + , pgConnect + , pgDisconnect + , useTPGDatabase + + -- **Queries + -- $query + + -- ***Compile time + -- $compile + , pgSQL + + -- ***Runtime + -- $run + , pgQuery + , pgExecute + , pgTransaction + + -- **TemplatePG compatibility + -- $templatepg + + -- *Advanced usage + + -- **Types + -- $types + + -- **A Note About NULL + -- $nulls + + -- *Caveats + -- $caveats + + -- **Tips + -- $tips + + ) where + +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.Query + +-- $intro +-- PostgreSQL-Typed is designed with 2 goals in mind: safety and performance. The +-- primary focus is on safety. +-- +-- To help ensure safety, it uses the PostgreSQL server to parse every query +-- and statement in your code to infer types at compile-time. This means that +-- in theory you cannot get a syntax error at runtime. Getting proper types at +-- compile time has the nice side-effect that it eliminates run-time type +-- casting and usually results in less code. This approach was inspired by +-- MetaHDBC () and PG'OCaml +-- (). +-- +-- While compile-time query analysis eliminates many errors, it doesn't +-- eliminate all of them. If you modify the database without recompilation or +-- have an error in a trigger or function, for example, you can still trigger a +-- 'PGError' or other failure (if types change). Also, nullable result fields resulting from outer joins are not +-- detected and need to be handled explicitly. +-- +-- Based originally on Chris Forno's TemplatePG library. +-- A compatibility interface for that library is provided by "Database.PostgreSQL.Typed.TemplatePG" which can basically function as a drop-in replacement (and also provides an alternative interface with some additional features). + +-- $usage +-- Basic usage consists of calling 'pgConnect', 'pgSQL' (Template Haskell quasi-quotation), 'pgQuery', and 'pgDisconnect': +-- You must enable TemplateHaskell and/or QuasiQuotes language extensions. +-- +-- > c <- pgConnect +-- > let name = "Joe" +-- > people :: [Int32] <- pgQuery c [pgSQL|SELECT id FROM people WHERE name = ${name}|] +-- > pgDisconnect c + +-- $connect +-- All database access requires a 'PGConnection' that is created at runtime using 'pgConnect', and should be explicitly be closed with 'pgDisconnect' when finished. +-- +-- However, at compile time, PostgreSQL-Typed needs to make its own connection to the database in order to describe queries. +-- By default, it will use the following environment variables: +-- +-- [@TPG_DB@] the database name to use (default: same as user) +-- +-- [@TPG_USER@] the username to connect as (default: @$USER@ or @postgres@) +-- +-- [@TPG_PASS@] the password to use (default: /empty/) +-- +-- [@TPG_HOST@] the host to connect to (default: @localhost@) +-- +-- [@TPG_PORT@ or @TPG_SOCK@] the port number or local socket path to connect on (default: @5432@) +-- +-- If you'd like to specify what connection to use directly, use 'useTPGDatabase' at the top level: +-- +-- > useTPGDatabase PGDatabase{ ... } +-- +-- Note that due to TH limitations, the database must be in-line or in a different module. This call must be processed by the compiler before (above) any other TH calls. +-- +-- You can set @TPG_DEBUG@ at compile or runtime to get a protocol-level trace. + +-- $query +-- There are two steps to running a query: a Template Haskell quasiquoter to perform type-inference at compile time and create a 'PGQuery'; and a run-time function to execute the query ('pgRunQuery', 'pgQuery', 'pgExecute'). + +-- $compile +-- Both TH functions take a single SQL string, which may contain in-line placeholders of the form @${expr}@ (where @expr@ is any valid Haskell expression) and/or PostgreSQL placeholders of the form @$1@, @$2@, etc. +-- +-- > let q = [pgSQL|SELECT id, name, address FROM people WHERE name LIKE ${query++"%"} OR email LIKE $1|] :: PGSimpleQuery [(Int32, String, Maybe String)] +-- +-- Expression placeholders are substituted with PostgreSQL ones in left-to-right order starting with 1, so must be in places that PostgreSQL allows them (e.g., not identifiers, table names, column names, operators, etc.) +-- However, this does mean that you can repeat expressions using the corresponding PostgreSQL placeholder as above. +-- If there are extra PostgreSQL parameters the may be passed as arguments: +-- +-- > [pgSQL|SELECT id FROM people WHERE name = $1|] :: String -> PGSimpleQuery [Int32] +-- +-- To produce 'PGPreparedQuery' objects instead of 'PGSimpleQuery', put a single @$@ at the beginning of the query. +-- You can also create queries at run-time using 'rawPGSimpleQuery' or 'rawPGPreparedQuery'. + +-- $run +-- There are multiple ways to run a 'PGQuery' once it's created ('pgQuery', 'pgExecute'), and you can also write your own, but they all reduce to 'pgRunQuery'. +-- These all take a 'PGConnection' and a 'PGQuery', and return results. +-- How they work depends on the type of query. +-- +-- 'PGSimpleQuery' simply substitutes the placeholder values literally into into the SQL statement. This should be safe for all currently-supported types. +-- +-- 'PGPreparedQuery' is a bit more complex: the first time any given prepared query is run on a given connection, the query is prepared. Every subsequent time, the previously-prepared query is re-used and the new placeholder values are bound to it. +-- Queries are identified by the text of the SQL statement with PostgreSQL placeholders in-place, so the exact parameter values do not matter (but the exact SQL statement, whitespace, etc. does). +-- (Prepared queries are released automatically at 'pgDisconnect', but may be closed early using 'Database.PostgreSQL.Typed.Protocol.pgCloseQuery'.) + +-- $templatepg +-- There is also an older, simpler interface based on TemplatePG that combines both the compile and runtime steps. +-- 'Database.PostgreSQL.Typed.TemplatePG.queryTuples' does all the work ('Database.PostgreSQL.Typed.TemplatePG.queryTuple' and 'Database.PostgreSQL.Typed.TemplatePG.execute' are convenience +-- functions). +-- +-- It's a Template Haskell function, so you need to splice it into your program +-- with @$()@. It requires a 'PGConnection' to a PostgreSQL server, but can't be +-- given one at compile-time, so you need to pass it after the splice: +-- +-- > h <- pgConnect ... +-- > tuples <- $(queryTuples "SELECT * FROM pg_database") h +-- +-- To pass parameters to a query, include them in the string with {}. Most +-- Haskell expressions should work. For example: +-- +-- > let owner = 33 :: Int32 +-- > tuples <- $(queryTuples "SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int64}") h +-- +-- TemplatePG provides 'Database.PostgreSQL.Typed.TemplatePG.withTransaction', 'Database.PostgreSQL.Typed.TemplatePG.rollback', and 'Database.PostgreSQL.Typed.TemplatePG.insertIgnore', but they've +-- not been thoroughly tested, so use them at your own risk. + +-- $types +-- Most builtin types are already supported. +-- For the most part, exactly equivalent types are all supported (e.g., 'Int32' for int4) as well as other safe equivalents, but you cannot, for example, pass an 'Integer' as a @smallint@. +-- To achieve this flexibility, the exact types of all parameters and results must be fully known (e.g., numeric literals will not work). +-- +-- However you can add support for your own types or add flexibility to existing types by creating new instances of 'Database.PostgreSQL.Typed.Types.PGParameter' (for encoding) and 'Database.PostgreSQL.Typed.Types.PGColumn' (for decoding). +-- +-- > instance PGType "mytype" +-- > instance PGParameter "mytype" MyType where +-- > pgEncode _ (v :: MyType) = ... :: ByteString +-- > instance PGColumn "mytype" MyType where +-- > pgDecode _ (s :: ByteString) = ... :: MyType +-- +-- You can make as many 'PGParameter' and 'PGColumn' instances as you want if you want to support different representations of your type. +-- If you want to use any of the functions in "Database.PostgreSQL.Typed.Dynamic", however, such as 'Database.PostgreSQL.Typed.Dynamic.pgSafeLiteral', you must define a default representation: +-- +-- > instance PGRep MyType where type PGRepType MyType = "mytype" +-- +-- If you want to support arrays of your new type, you should also provide a 'Database.PostgreSQL.Typed.Array.PGArrayType' instance (or 'Database.PostgreSQL.Typed.Range.PGRangeType' for new ranges). +-- Currently only 1-dimensional arrays are supported. +-- +-- > instance PGType "mytype[]" +-- > instance PGArrayType "mytype[]" "mytype" +-- +-- Required language extensions: FlexibleInstances, MultiParamTypeClasses, DataKinds + +-- $nulls +-- Sometimes PostgreSQL cannot automatically determine whether or not a result field can +-- potentially be @NULL@. In those cases it will assume that it can. Basically, +-- any time a result field is not immediately traceable to an originating table +-- and column (such as when a function is applied to a result column), it's +-- assumed to be nullable and will be returned as a 'Maybe' value. Other values may be decoded without the 'Maybe' wrapper. +-- +-- You can use @NULL@ values in parameters as well by using 'Maybe'. + +-- $caveats +-- The types of all parameters and results must be fully known. This may +-- require explicit casts in some cases (especially with numeric literals). +-- +-- You cannot construct queries at run-time, since they +-- wouldn't be available to be analyzed at compile time (but you can construct them at compile time by writing your own TH functions). +-- +-- Because of how PostgreSQL handles placeholders, they cannot be used in place of lists (such as @IN (?)@). You must replace such cases with equivalent arrays (@= ANY (?)@). +-- +-- For the most part, any code must be compiled and run against databases that are at least structurally identical. +-- Furthermore, prepared queries also store OIDs for user types, so the generated 'PGPreparedQuery' can only be run on the exact same database or one restored from a dump with OIDs (@pg_dump -o@). If this is a concern, only use built-in types in prepared queries. +-- (This requirement could be weakened with some work, if there were need.) + +-- $tips +-- If you find yourself pattern matching on result tuples just to pass them on +-- to functions, you can use @uncurryN@ from the tuple package. The following +-- examples are equivalent. +-- +-- > (a, b, c) <- $(queryTuple "SELECT a, b, c FROM table LIMIT 1") +-- > someFunction a b c +-- > uncurryN someFunction `liftM` $(queryTuple "SELECT a, b, c FROM table LIMIT 1") diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs new file mode 100644 index 0000000..2c39c3b --- /dev/null +++ b/Database/PostgreSQL/Typed/Array.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, OverloadedStrings, TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#endif +-- | +-- Module: Database.PostgreSQL.Typed.Array +-- Copyright: 2015 Dylan Simon +-- +-- Representaion of PostgreSQL's array type. +-- Currently this only supports one-dimensional arrays. +-- PostgreSQL arrays in theory can dynamically be any (rectangular) shape. + +module Database.PostgreSQL.Typed.Array where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (*>), (<*)) +#endif +import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as BSC +import Data.Char (toLower) +import Data.List (intersperse) +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat) +#endif +import GHC.TypeLits (Symbol) + +import Database.PostgreSQL.Typed.Types + +-- |The cannonical representation of a PostgreSQL array of any type, which may always contain NULLs. +-- Currenly only one-dimetional arrays are supported, although in PostgreSQL, any array may be of any dimentionality. +type PGArray a = [Maybe a] + +-- |Class indicating that the first PostgreSQL type is an array of the second. +-- This implies 'PGParameter' and 'PGColumn' instances that will work for any type using comma as a delimiter (i.e., anything but @box@). +-- This will only work with 1-dimensional arrays. +class (PGType t, PGType (PGElemType t)) => PGArrayType t where + type PGElemType t :: Symbol + pgArrayElementType :: PGTypeID t -> PGTypeID (PGElemType t) + pgArrayElementType PGTypeProxy = PGTypeProxy + -- |The character used as a delimeter. The default @,@ is correct for all standard types (except @box@). + pgArrayDelim :: PGTypeID t -> Char + pgArrayDelim _ = ',' + +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + (PGArrayType t, PGParameter (PGElemType t) a) => PGParameter t (PGArray a) where + pgEncode ta l = buildPGValue $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where + el Nothing = BSB.string7 "null" + el (Just e) = pgDQuoteFrom (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e +#if __GLASGOW_HASKELL__ >= 710 +-- |Allow entirely non-null arrays as parameter inputs only. +-- (Only supported on ghc >= 7.10 due to instance overlap.) +instance {-# OVERLAPPABLE #-} (PGArrayType t, PGParameter (PGElemType t) a) => PGParameter t [a] where + pgEncode ta = pgEncode ta . map Just +#endif +instance (PGArrayType t, PGColumn (PGElemType t) a) => PGColumn t (PGArray a) where + pgDecode ta a = either (error . ("pgDecode array (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly pa a where + pa = P.char '{' *> P.sepBy (P.skipSpace *> el <* P.skipSpace) (P.char (pgArrayDelim ta)) <* P.char '}' <* P.endOfInput + el = fmap (pgDecode (pgArrayElementType ta)) <$> + parsePGDQuote False (pgArrayDelim ta : "{}") (("null" ==) . BSC.map toLower) + +-- Just a dump of pg_type: +instance PGType "boolean" => PGType "boolean[]" where + type PGVal "boolean[]" = PGArray (PGVal "boolean") +instance PGType "boolean" => PGArrayType "boolean[]" where + type PGElemType "boolean[]" = "boolean" +instance PGType "bytea" => PGType "bytea[]" where + type PGVal "bytea[]" = PGArray (PGVal "bytea") +instance PGType "bytea" => PGArrayType "bytea[]" where + type PGElemType "bytea[]" = "bytea" +instance PGType "\"char\"" => PGType "\"char\"[]" where + type PGVal "\"char\"[]" = PGArray (PGVal "\"char\"") +instance PGType "\"char\"" => PGArrayType "\"char\"[]" where + type PGElemType "\"char\"[]" = "\"char\"" +instance PGType "name" => PGType "name[]" where + type PGVal "name[]" = PGArray (PGVal "name") +instance PGType "name" => PGArrayType "name[]" where + type PGElemType "name[]" = "name" +instance PGType "bigint" => PGType "bigint[]" where + type PGVal "bigint[]" = PGArray (PGVal "bigint") +instance PGType "bigint" => PGArrayType "bigint[]" where + type PGElemType "bigint[]" = "bigint" +instance PGType "smallint" => PGType "smallint[]" where + type PGVal "smallint[]" = PGArray (PGVal "smallint") +instance PGType "smallint" => PGArrayType "smallint[]" where + type PGElemType "smallint[]" = "smallint" +instance PGType "int2vector" => PGType "int2vector[]" where + type PGVal "int2vector[]" = PGArray (PGVal "int2vector") +instance PGType "int2vector" => PGArrayType "int2vector[]" where + type PGElemType "int2vector[]" = "int2vector" +instance PGType "integer" => PGType "integer[]" where + type PGVal "integer[]" = PGArray (PGVal "integer") +instance PGType "integer" => PGArrayType "integer[]" where + type PGElemType "integer[]" = "integer" +instance PGType "regproc" => PGType "regproc[]" where + type PGVal "regproc[]" = PGArray (PGVal "regproc") +instance PGType "regproc" => PGArrayType "regproc[]" where + type PGElemType "regproc[]" = "regproc" +instance PGType "text" => PGType "text[]" where + type PGVal "text[]" = PGArray (PGVal "text") +instance PGType "text" => PGArrayType "text[]" where + type PGElemType "text[]" = "text" +instance PGType "oid" => PGType "oid[]" where + type PGVal "oid[]" = PGArray (PGVal "oid") +instance PGType "oid" => PGArrayType "oid[]" where + type PGElemType "oid[]" = "oid" +instance PGType "tid" => PGType "tid[]" where + type PGVal "tid[]" = PGArray (PGVal "tid") +instance PGType "tid" => PGArrayType "tid[]" where + type PGElemType "tid[]" = "tid" +instance PGType "xid" => PGType "xid[]" where + type PGVal "xid[]" = PGArray (PGVal "xid") +instance PGType "xid" => PGArrayType "xid[]" where + type PGElemType "xid[]" = "xid" +instance PGType "cid" => PGType "cid[]" where + type PGVal "cid[]" = PGArray (PGVal "cid") +instance PGType "cid" => PGArrayType "cid[]" where + type PGElemType "cid[]" = "cid" +instance PGType "oidvector" => PGType "oidvector[]" where + type PGVal "oidvector[]" = PGArray (PGVal "oidvector") +instance PGType "oidvector" => PGArrayType "oidvector[]" where + type PGElemType "oidvector[]" = "oidvector" +instance PGType "json" => PGType "json[]" where + type PGVal "json[]" = PGArray (PGVal "json") +instance PGType "json" => PGArrayType "json[]" where + type PGElemType "json[]" = "json" +instance PGType "xml" => PGType "xml[]" where + type PGVal "xml[]" = PGArray (PGVal "xml") +instance PGType "xml" => PGArrayType "xml[]" where + type PGElemType "xml[]" = "xml" +instance PGType "point" => PGType "point[]" where + type PGVal "point[]" = PGArray (PGVal "point") +instance PGType "point" => PGArrayType "point[]" where + type PGElemType "point[]" = "point" +instance PGType "lseg" => PGType "lseg[]" where + type PGVal "lseg[]" = PGArray (PGVal "lseg") +instance PGType "lseg" => PGArrayType "lseg[]" where + type PGElemType "lseg[]" = "lseg" +instance PGType "path" => PGType "path[]" where + type PGVal "path[]" = PGArray (PGVal "path") +instance PGType "path" => PGArrayType "path[]" where + type PGElemType "path[]" = "path" +instance PGType "box" => PGType "box[]" where + type PGVal "box[]" = PGArray (PGVal "box") +instance PGType "box" => PGArrayType "box[]" where + type PGElemType "box[]" = "box" + pgArrayDelim _ = ';' +instance PGType "polygon" => PGType "polygon[]" where + type PGVal "polygon[]" = PGArray (PGVal "polygon") +instance PGType "polygon" => PGArrayType "polygon[]" where + type PGElemType "polygon[]" = "polygon" +instance PGType "line" => PGType "line[]" where + type PGVal "line[]" = PGArray (PGVal "line") +instance PGType "line" => PGArrayType "line[]" where + type PGElemType "line[]" = "line" +instance PGType "cidr" => PGType "cidr[]" where + type PGVal "cidr[]" = PGArray (PGVal "cidr") +instance PGType "cidr" => PGArrayType "cidr[]" where + type PGElemType "cidr[]" = "cidr" +instance PGType "real" => PGType "real[]" where + type PGVal "real[]" = PGArray (PGVal "real") +instance PGType "real" => PGArrayType "real[]" where + type PGElemType "real[]" = "real" +instance PGType "double precision" => PGType "double precision[]" where + type PGVal "double precision[]" = PGArray (PGVal "double precision") +instance PGType "double precision" => PGArrayType "double precision[]" where + type PGElemType "double precision[]" = "double precision" +instance PGType "abstime" => PGType "abstime[]" where + type PGVal "abstime[]" = PGArray (PGVal "abstime") +instance PGType "abstime" => PGArrayType "abstime[]" where + type PGElemType "abstime[]" = "abstime" +instance PGType "reltime" => PGType "reltime[]" where + type PGVal "reltime[]" = PGArray (PGVal "reltime") +instance PGType "reltime" => PGArrayType "reltime[]" where + type PGElemType "reltime[]" = "reltime" +instance PGType "tinterval" => PGType "tinterval[]" where + type PGVal "tinterval[]" = PGArray (PGVal "tinterval") +instance PGType "tinterval" => PGArrayType "tinterval[]" where + type PGElemType "tinterval[]" = "tinterval" +instance PGType "circle" => PGType "circle[]" where + type PGVal "circle[]" = PGArray (PGVal "circle") +instance PGType "circle" => PGArrayType "circle[]" where + type PGElemType "circle[]" = "circle" +instance PGType "money" => PGType "money[]" where + type PGVal "money[]" = PGArray (PGVal "money") +instance PGType "money" => PGArrayType "money[]" where + type PGElemType "money[]" = "money" +instance PGType "macaddr" => PGType "macaddr[]" where + type PGVal "macaddr[]" = PGArray (PGVal "macaddr") +instance PGType "macaddr" => PGArrayType "macaddr[]" where + type PGElemType "macaddr[]" = "macaddr" +instance PGType "inet" => PGType "inet[]" where + type PGVal "inet[]" = PGArray (PGVal "inet") +instance PGType "inet" => PGArrayType "inet[]" where + type PGElemType "inet[]" = "inet" +instance PGType "aclitem" => PGType "aclitem[]" where + type PGVal "aclitem[]" = PGArray (PGVal "aclitem") +instance PGType "aclitem" => PGArrayType "aclitem[]" where + type PGElemType "aclitem[]" = "aclitem" +instance PGType "bpchar" => PGType "bpchar[]" where + type PGVal "bpchar[]" = PGArray (PGVal "bpchar") +instance PGType "bpchar" => PGArrayType "bpchar[]" where + type PGElemType "bpchar[]" = "bpchar" +instance PGType "character varying" => PGType "character varying[]" where + type PGVal "character varying[]" = PGArray (PGVal "character varying") +instance PGType "character varying" => PGArrayType "character varying[]" where + type PGElemType "character varying[]" = "character varying" +instance PGType "date" => PGType "date[]" where + type PGVal "date[]" = PGArray (PGVal "date") +instance PGType "date" => PGArrayType "date[]" where + type PGElemType "date[]" = "date" +instance PGType "time without time zone" => PGType "time without time zone[]" where + type PGVal "time without time zone[]" = PGArray (PGVal "time without time zone") +instance PGType "time without time zone" => PGArrayType "time without time zone[]" where + type PGElemType "time without time zone[]" = "time without time zone" +instance PGType "timestamp without time zone" => PGType "timestamp without time zone[]" where + type PGVal "timestamp without time zone[]" = PGArray (PGVal "timestamp without time zone") +instance PGType "timestamp without time zone" => PGArrayType "timestamp without time zone[]" where + type PGElemType "timestamp without time zone[]" = "timestamp without time zone" +instance PGType "timestamp with time zone" => PGType "timestamp with time zone[]" where + type PGVal "timestamp with time zone[]" = PGArray (PGVal "timestamp with time zone") +instance PGType "timestamp with time zone" => PGArrayType "timestamp with time zone[]" where + type PGElemType "timestamp with time zone[]" = "timestamp with time zone" +instance PGType "interval" => PGType "interval[]" where + type PGVal "interval[]" = PGArray (PGVal "interval") +instance PGType "interval" => PGArrayType "interval[]" where + type PGElemType "interval[]" = "interval" +instance PGType "time with time zone" => PGType "time with time zone[]" where + type PGVal "time with time zone[]" = PGArray (PGVal "time with time zone") +instance PGType "time with time zone" => PGArrayType "time with time zone[]" where + type PGElemType "time with time zone[]" = "time with time zone" +instance PGType "bit" => PGType "bit[]" where + type PGVal "bit[]" = PGArray (PGVal "bit") +instance PGType "bit" => PGArrayType "bit[]" where + type PGElemType "bit[]" = "bit" +instance PGType "varbit" => PGType "varbit[]" where + type PGVal "varbit[]" = PGArray (PGVal "varbit") +instance PGType "varbit" => PGArrayType "varbit[]" where + type PGElemType "varbit[]" = "varbit" +instance PGType "numeric" => PGType "numeric[]" where + type PGVal "numeric[]" = PGArray (PGVal "numeric") +instance PGType "numeric" => PGArrayType "numeric[]" where + type PGElemType "numeric[]" = "numeric" +instance PGType "refcursor" => PGType "refcursor[]" where + type PGVal "refcursor[]" = PGArray (PGVal "refcursor") +instance PGType "refcursor" => PGArrayType "refcursor[]" where + type PGElemType "refcursor[]" = "refcursor" +instance PGType "regprocedure" => PGType "regprocedure[]" where + type PGVal "regprocedure[]" = PGArray (PGVal "regprocedure") +instance PGType "regprocedure" => PGArrayType "regprocedure[]" where + type PGElemType "regprocedure[]" = "regprocedure" +instance PGType "regoper" => PGType "regoper[]" where + type PGVal "regoper[]" = PGArray (PGVal "regoper") +instance PGType "regoper" => PGArrayType "regoper[]" where + type PGElemType "regoper[]" = "regoper" +instance PGType "regoperator" => PGType "regoperator[]" where + type PGVal "regoperator[]" = PGArray (PGVal "regoperator") +instance PGType "regoperator" => PGArrayType "regoperator[]" where + type PGElemType "regoperator[]" = "regoperator" +instance PGType "regclass" => PGType "regclass[]" where + type PGVal "regclass[]" = PGArray (PGVal "regclass") +instance PGType "regclass" => PGArrayType "regclass[]" where + type PGElemType "regclass[]" = "regclass" +instance PGType "regtype" => PGType "regtype[]" where + type PGVal "regtype[]" = PGArray (PGVal "regtype") +instance PGType "regtype" => PGArrayType "regtype[]" where + type PGElemType "regtype[]" = "regtype" +instance PGType "record" => PGType "record[]" where + type PGVal "record[]" = PGArray (PGVal "record") +instance PGType "record" => PGArrayType "record[]" where + type PGElemType "record[]" = "record" +instance PGType "cstring" => PGType "cstring[]" where + type PGVal "cstring[]" = PGArray (PGVal "cstring") +instance PGType "cstring" => PGArrayType "cstring[]" where + type PGElemType "cstring[]" = "cstring" +instance PGType "uuid" => PGType "uuid[]" where + type PGVal "uuid[]" = PGArray (PGVal "uuid") +instance PGType "uuid" => PGArrayType "uuid[]" where + type PGElemType "uuid[]" = "uuid" +instance PGType "txid_snapshot" => PGType "txid_snapshot[]" where + type PGVal "txid_snapshot[]" = PGArray (PGVal "txid_snapshot") +instance PGType "txid_snapshot" => PGArrayType "txid_snapshot[]" where + type PGElemType "txid_snapshot[]" = "txid_snapshot" +instance PGType "tsvector" => PGType "tsvector[]" where + type PGVal "tsvector[]" = PGArray (PGVal "tsvector") +instance PGType "tsvector" => PGArrayType "tsvector[]" where + type PGElemType "tsvector[]" = "tsvector" +instance PGType "tsquery" => PGType "tsquery[]" where + type PGVal "tsquery[]" = PGArray (PGVal "tsquery") +instance PGType "tsquery" => PGArrayType "tsquery[]" where + type PGElemType "tsquery[]" = "tsquery" +instance PGType "gtsvector" => PGType "gtsvector[]" where + type PGVal "gtsvector[]" = PGArray (PGVal "gtsvector") +instance PGType "gtsvector" => PGArrayType "gtsvector[]" where + type PGElemType "gtsvector[]" = "gtsvector" +instance PGType "regconfig" => PGType "regconfig[]" where + type PGVal "regconfig[]" = PGArray (PGVal "regconfig") +instance PGType "regconfig" => PGArrayType "regconfig[]" where + type PGElemType "regconfig[]" = "regconfig" +instance PGType "regdictionary" => PGType "regdictionary[]" where + type PGVal "regdictionary[]" = PGArray (PGVal "regdictionary") +instance PGType "regdictionary" => PGArrayType "regdictionary[]" where + type PGElemType "regdictionary[]" = "regdictionary" +instance PGType "int4range" => PGType "int4range[]" where + type PGVal "int4range[]" = PGArray (PGVal "int4range") +instance PGType "int4range" => PGArrayType "int4range[]" where + type PGElemType "int4range[]" = "int4range" +instance PGType "numrange" => PGType "numrange[]" where + type PGVal "numrange[]" = PGArray (PGVal "numrange") +instance PGType "numrange" => PGArrayType "numrange[]" where + type PGElemType "numrange[]" = "numrange" +instance PGType "tsrange" => PGType "tsrange[]" where + type PGVal "tsrange[]" = PGArray (PGVal "tsrange") +instance PGType "tsrange" => PGArrayType "tsrange[]" where + type PGElemType "tsrange[]" = "tsrange" +instance PGType "tstzrange" => PGType "tstzrange[]" where + type PGVal "tstzrange[]" = PGArray (PGVal "tstzrange") +instance PGType "tstzrange" => PGArrayType "tstzrange[]" where + type PGElemType "tstzrange[]" = "tstzrange" +instance PGType "daterange" => PGType "daterange[]" where + type PGVal "daterange[]" = PGArray (PGVal "daterange") +instance PGType "daterange" => PGArrayType "daterange[]" where + type PGElemType "daterange[]" = "daterange" +instance PGType "int8range" => PGType "int8range[]" where + type PGVal "int8range[]" = PGArray (PGVal "int8range") +instance PGType "int8range" => PGArrayType "int8range[]" where + type PGElemType "int8range[]" = "int8range" + diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs new file mode 100644 index 0000000..ae0ef58 --- /dev/null +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +-- | +-- Module: Database.PostgreSQL.Typed.Dynamic +-- Copyright: 2015 Dylan Simon +-- +-- Automatic (dynamic) marshalling of PostgreSQL values based on Haskell types (not SQL statements). +-- This is intended for direct construction of queries and query data, bypassing the normal SQL type inference. + +module Database.PostgreSQL.Typed.Dynamic + ( PGRep(..) + , pgTypeOf + , pgTypeOfProxy + , pgEncodeRep + , pgDecodeRep + , pgLiteralRep + , pgLiteralString + , pgSafeLiteral + , pgSafeLiteralString + , pgSubstituteLiterals + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +#ifdef VERSION_aeson +import qualified Data.Aeson as JSON +#endif +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Lazy as BSL +import Data.Int +import Data.Monoid ((<>)) +import Data.Proxy (Proxy) +#ifdef VERSION_scientific +import Data.Scientific (Scientific) +#endif +import Data.String (fromString) +#ifdef VERSION_text +import qualified Data.Text as T +#endif +import qualified Data.Time as Time +#ifdef VERSION_uuid +import qualified Data.UUID as UUID +#endif +import GHC.TypeLits (Symbol) +import Language.Haskell.Meta.Parse (parseExp) +import qualified Language.Haskell.TH as TH + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.SQLToken + +-- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling. +class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where + -- |The PostgreSOL type that this type should be converted to. + type PGRepType a :: Symbol + +pgTypeOf :: a -> PGTypeID (PGRepType a) +pgTypeOf _ = PGTypeProxy + +pgTypeOfProxy :: Proxy a -> PGTypeID (PGRepType a) +pgTypeOfProxy _ = PGTypeProxy + +-- |Encode a value using 'pgEncodeValue'. +pgEncodeRep :: PGRep a => a -> PGValue +pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x + +-- |Produce a literal value for interpolation in a SQL statement using 'pgLiteral'. Using 'pgSafeLiteral' is usually safer as it includes type cast. +pgLiteralRep :: PGRep a => a -> BS.ByteString +pgLiteralRep x = pgLiteral (pgTypeOf x) x + +-- |Decode a value using 'pgDecodeValue'. +pgDecodeRep :: forall a . PGRep a => PGValue -> a +pgDecodeRep = pgDecodeValue unknownPGTypeEnv (PGTypeProxy :: PGTypeID (PGRepType a)) + +-- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement. +pgLiteralString :: PGRep a => a -> String +pgLiteralString = BSC.unpack . pgLiteralRep + +-- |Produce a safely type-cast literal value for interpolation in a SQL statement, e.g., "'123'::integer". +pgSafeLiteral :: PGRep a => a -> BS.ByteString +pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> pgNameBS (pgTypeName (pgTypeOf x)) + +-- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. +pgSafeLiteralString :: PGRep a => a -> String +pgSafeLiteralString x = pgLiteralString x ++ "::" ++ map w2c (pgNameBytes (pgTypeName (pgTypeOf x))) + +instance PGRep a => PGRep (Maybe a) where + type PGRepType (Maybe a) = PGRepType a + +instance PGRep () where + type PGRepType () = "void" +instance PGRep Bool where + type PGRepType Bool = "boolean" +instance PGRep OID where + type PGRepType OID = "oid" +instance PGRep Int16 where + type PGRepType Int16 = "smallint" +instance PGRep Int32 where + type PGRepType Int32 = "integer" +instance PGRep Int64 where + type PGRepType Int64 = "bigint" +instance PGRep Float where + type PGRepType Float = "real" +instance PGRep Double where + type PGRepType Double = "double precision" +instance PGRep Char where + type PGRepType Char = "\"char\"" +instance PGRep String where + type PGRepType String = "text" +instance PGRep BS.ByteString where + type PGRepType BS.ByteString = "text" +instance PGRep PGName where + type PGRepType PGName = "text" -- superset of "name" +#ifdef VERSION_text +instance PGRep T.Text where + type PGRepType T.Text = "text" +#endif +instance PGRep Time.Day where + type PGRepType Time.Day = "date" +instance PGRep Time.TimeOfDay where + type PGRepType Time.TimeOfDay = "time without time zone" +instance PGRep (Time.TimeOfDay, Time.TimeZone) where + type PGRepType (Time.TimeOfDay, Time.TimeZone) = "time with time zone" +instance PGRep Time.LocalTime where + type PGRepType Time.LocalTime = "timestamp without time zone" +instance PGRep Time.UTCTime where + type PGRepType Time.UTCTime = "timestamp with time zone" +instance PGRep Time.DiffTime where + type PGRepType Time.DiffTime = "interval" +instance PGRep Rational where + type PGRepType Rational = "numeric" +#ifdef VERSION_scientific +instance PGRep Scientific where + type PGRepType Scientific = "numeric" +#endif +#ifdef VERSION_uuid +instance PGRep UUID.UUID where + type PGRepType UUID.UUID = "uuid" +#endif +#ifdef VERSION_aeson +instance PGRep JSON.Value where + type PGRepType JSON.Value = "jsonb" +#endif + +-- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@, producing a lazy 'BSL.ByteString'. +-- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries, for example when using 'Database.PostgreSQL.Typed.Protocol.pgSimpleQuery' or 'Database.PostgreSQL.Typed.Protocol.pgSimpleQueries_'. +-- Unlike most other TH functions, this does not require any database connection. +pgSubstituteLiterals :: String -> TH.ExpQ +pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BSL.fromChunks) . TH.ListE <$> mapM sst (sqlTokens sql) where + sst (SQLExpr e) = do + v <- either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e + return $ TH.VarE 'pgSafeLiteral `TH.AppE` v + sst t = return $ TH.VarE 'fromString `TH.AppE` TH.LitE (TH.StringL $ show t) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs new file mode 100644 index 0000000..8bbec8f --- /dev/null +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +-- | +-- Module: Database.PostgreSQL.Typed.Enum +-- Copyright: 2015 Dylan Simon +-- +-- Support for PostgreSQL enums. + +module Database.PostgreSQL.Typed.Enum + ( PGEnum(..) + , dataPGEnum + ) where + +import Control.Arrow ((&&&)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Ix (Ix) +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple (swap) +import Data.Typeable (Typeable) +import qualified Language.Haskell.TH as TH + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TypeCache +import Database.PostgreSQL.Typed.TH + +-- |A type based on a PostgreSQL enum. Automatically instantiated by 'dataPGEnum'. +class (Eq a, Ord a, Enum a, Bounded a, PGRep a) => PGEnum a where + {-# MINIMAL pgEnumName | pgEnumValues #-} + -- |The database name of a value. + pgEnumName :: a -> PGName + pgEnumName a = fromJust $ lookup a pgEnumValues + -- |Lookup a value matching the given database name. + pgEnumValue :: PGName -> Maybe a + pgEnumValue n = lookup n $ map swap pgEnumValues + -- |List of all the values in the enum along with their database names. + pgEnumValues :: [(a, PGName)] + pgEnumValues = map (id &&& pgEnumName) $ enumFromTo minBound maxBound + +-- |Create a new enum type corresponding to the given PostgreSQL enum type. +-- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\')@, then +-- @dataPGEnum \"Foo\" \"foo\" (\"Foo_\"++)@ will be equivalent to: +-- +-- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable) +-- > instance PGType "foo" where PGVal "foo" = Foo +-- > instance PGParameter "foo" Foo where ... +-- > instance PGColumn "foo" Foo where ... +-- > instance PGRep Foo where PGRepType = "foo" +-- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] +-- +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies +dataPGEnum :: String -- ^ Haskell type to create + -> PGName -- ^ PostgreSQL enum type name + -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ (input is 'pgNameString') + -> TH.DecsQ +dataPGEnum typs pgenum valnf = do + (pgid, vals) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do + vals <- map (\([eo, v]) -> (pgDecodeRep eo, pgDecodeRep v)) . snd + <$> pgSimpleQuery (pgConnection tpg) (BSL.fromChunks + [ "SELECT enumtypid, enumlabel" + , " FROM pg_catalog.pg_enum" + , " WHERE enumtypid = ", pgLiteralRep pgenum, "::regtype" + , " ORDER BY enumsortorder" + ]) + case vals of + [] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ show pgenum ++ ": no values found" + (eo, _):_ -> do + et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ show pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return + =<< lookupPGType tpg eo + return (et, map snd vals) + let valn = map (TH.mkName . valnf . pgNameString &&& map (TH.IntegerL . fromIntegral) . pgNameBytes) vals + typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) + dv <- TH.newName "x" + return $ + [ TH.DataD [] typn [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + (map (\(n, _) -> TH.NormalC n []) valn) $ +#if MIN_VERSION_template_haskell(2,11,0) +#if MIN_VERSION_template_haskell(2,12,0) + return $ TH.DerivClause Nothing $ +#endif + map TH.ConT +#endif + [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] + , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) + [ tySynInstD ''PGVal typl typt + ] + , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) + [ TH.FunD 'pgEncode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.NormalB $ TH.VarE 'pgNameBS `TH.AppE` (TH.VarE 'pgEnumName `TH.AppE` TH.VarE dv)) + []] + ] + , instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) + [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.NormalB $ TH.VarE 'fromMaybe + `TH.AppE` (TH.AppE (TH.VarE 'error) $ + TH.InfixE (Just $ TH.LitE (TH.StringL ("pgEnumValue " ++ show pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) + `TH.AppE` (TH.VarE 'pgEnumValue `TH.AppE` (TH.ConE 'PGName + `TH.AppE` (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv)))) + []] + ] + , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) + [ tySynInstD ''PGRepType typt typl + ] + , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) + [ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [conP n []] + (TH.NormalB $ namelit l) + []) valn + , TH.FunD 'pgEnumValue $ map (\(n, l) -> + TH.Clause [conP 'PGName [TH.ListP (map TH.LitP l)]] + (TH.NormalB $ TH.ConE 'Just `TH.AppE` TH.ConE n) + []) valn + ++ [TH.Clause [TH.WildP] (TH.NormalB $ TH.ConE 'Nothing) []] + , TH.FunD 'pgEnumValues [TH.Clause [] + (TH.NormalB $ TH.ListE $ map (\(n, l) -> + TH.ConE '(,) `TH.AppE` TH.ConE n `TH.AppE` namelit l) valn) + []] + ] + , TH.PragmaD $ TH.AnnP (TH.TypeAnnotation typn) $ namelit $ map (TH.IntegerL . fromIntegral) $ pgNameBytes pgid + ] + ++ map (\(n, l) -> + TH.PragmaD $ TH.AnnP (TH.ValueAnnotation n) $ namelit l) valn + where + typn = TH.mkName typs + typt = TH.ConT typn + instanceD = TH.InstanceD +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + tySynInstD c l t = TH.TySynInstD +#if MIN_VERSION_template_haskell(2,15,0) + $ TH.TySynEqn Nothing (TH.AppT (TH.ConT c) l) +#else + c $ TH.TySynEqn [l] +#endif + t + namelit l = TH.ConE 'PGName `TH.AppE` TH.ListE (map TH.LitE l) + conP n p = TH.ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + p diff --git a/Database/PostgreSQL/Typed/ErrCodes.hs b/Database/PostgreSQL/Typed/ErrCodes.hs new file mode 100644 index 0000000..b047922 --- /dev/null +++ b/Database/PostgreSQL/Typed/ErrCodes.hs @@ -0,0 +1,1633 @@ +-- Automatically generated from /src/postgresql-12.0/src/src/backend/utils/errcodes.txt using errcodes 2019-10-05 16:38:46.694932074 UTC. +{-# LANGUAGE OverloadedStrings #-} +-- |PostgreSQL error codes. +module Database.PostgreSQL.Typed.ErrCodes (names + -- * Class 00 - Successful Completion + , successful_completion + -- * Class 01 - Warning + , warning + , warning_dynamic_result_sets_returned + , warning_implicit_zero_bit_padding + , warning_null_value_eliminated_in_set_function + , warning_privilege_not_granted + , warning_privilege_not_revoked + , warning_string_data_right_truncation + , warning_deprecated_feature + -- * Class 02 - No Data (this is also a warning class per the SQL standard) + , no_data + , no_additional_dynamic_result_sets_returned + -- * Class 03 - SQL Statement Not Yet Complete + , sql_statement_not_yet_complete + -- * Class 08 - Connection Exception + , connection_exception + , connection_does_not_exist + , connection_failure + , sqlclient_unable_to_establish_sqlconnection + , sqlserver_rejected_establishment_of_sqlconnection + , transaction_resolution_unknown + , protocol_violation + -- * Class 09 - Triggered Action Exception + , triggered_action_exception + -- * Class 0A - Feature Not Supported + , feature_not_supported + -- * Class 0B - Invalid Transaction Initiation + , invalid_transaction_initiation + -- * Class 0F - Locator Exception + , locator_exception + , invalid_locator_specification + -- * Class 0L - Invalid Grantor + , invalid_grantor + , invalid_grant_operation + -- * Class 0P - Invalid Role Specification + , invalid_role_specification + -- * Class 0Z - Diagnostics Exception + , diagnostics_exception + , stacked_diagnostics_accessed_without_active_handler + -- * Class 20 - Case Not Found + , case_not_found + -- * Class 21 - Cardinality Violation + , cardinality_violation + -- * Class 22 - Data Exception + , data_exception + , _ARRAY_ELEMENT_ERROR + , array_subscript_error + , character_not_in_repertoire + , datetime_field_overflow + , _DATETIME_VALUE_OUT_OF_RANGE + , division_by_zero + , error_in_assignment + , escape_character_conflict + , indicator_overflow + , interval_field_overflow + , invalid_argument_for_logarithm + , invalid_argument_for_ntile_function + , invalid_argument_for_nth_value_function + , invalid_argument_for_power_function + , invalid_argument_for_width_bucket_function + , invalid_character_value_for_cast + , invalid_datetime_format + , invalid_escape_character + , invalid_escape_octet + , invalid_escape_sequence + , nonstandard_use_of_escape_character + , invalid_indicator_parameter_value + , invalid_parameter_value + , invalid_preceding_or_following_size + , invalid_regular_expression + , invalid_row_count_in_limit_clause + , invalid_row_count_in_result_offset_clause + , invalid_tablesample_argument + , invalid_tablesample_repeat + , invalid_time_zone_displacement_value + , invalid_use_of_escape_character + , most_specific_type_mismatch + , null_value_not_allowed + , null_value_no_indicator_parameter + , numeric_value_out_of_range + , sequence_generator_limit_exceeded + , string_data_length_mismatch + , string_data_right_truncation + , substring_error + , trim_error + , unterminated_c_string + , zero_length_character_string + , floating_point_exception + , invalid_text_representation + , invalid_binary_representation + , bad_copy_file_format + , untranslatable_character + , not_an_xml_document + , invalid_xml_document + , invalid_xml_content + , invalid_xml_comment + , invalid_xml_processing_instruction + , duplicate_json_object_key_value + , invalid_json_text + , invalid_sql_json_subscript + , more_than_one_sql_json_item + , no_sql_json_item + , non_numeric_sql_json_item + , non_unique_keys_in_a_json_object + , singleton_sql_json_item_required + , sql_json_array_not_found + , sql_json_member_not_found + , sql_json_number_not_found + , sql_json_object_not_found + , too_many_json_array_elements + , too_many_json_object_members + , sql_json_scalar_required + -- * Class 23 - Integrity Constraint Violation + , integrity_constraint_violation + , restrict_violation + , not_null_violation + , foreign_key_violation + , unique_violation + , check_violation + , exclusion_violation + -- * Class 24 - Invalid Cursor State + , invalid_cursor_state + -- * Class 25 - Invalid Transaction State + , invalid_transaction_state + , active_sql_transaction + , branch_transaction_already_active + , held_cursor_requires_same_isolation_level + , inappropriate_access_mode_for_branch_transaction + , inappropriate_isolation_level_for_branch_transaction + , no_active_sql_transaction_for_branch_transaction + , read_only_sql_transaction + , schema_and_data_statement_mixing_not_supported + , no_active_sql_transaction + , in_failed_sql_transaction + , idle_in_transaction_session_timeout + -- * Class 26 - Invalid SQL Statement Name + , invalid_sql_statement_name + -- * Class 27 - Triggered Data Change Violation + , triggered_data_change_violation + -- * Class 28 - Invalid Authorization Specification + , invalid_authorization_specification + , invalid_password + -- * Class 2B - Dependent Privilege Descriptors Still Exist + , dependent_privilege_descriptors_still_exist + , dependent_objects_still_exist + -- * Class 2D - Invalid Transaction Termination + , invalid_transaction_termination + -- * Class 2F - SQL Routine Exception + , sql_routine_exception + , s_r_e_function_executed_no_return_statement + , s_r_e_modifying_sql_data_not_permitted + , s_r_e_prohibited_sql_statement_attempted + , s_r_e_reading_sql_data_not_permitted + -- * Class 34 - Invalid Cursor Name + , invalid_cursor_name + -- * Class 38 - External Routine Exception + , external_routine_exception + , e_r_e_containing_sql_not_permitted + , e_r_e_modifying_sql_data_not_permitted + , e_r_e_prohibited_sql_statement_attempted + , e_r_e_reading_sql_data_not_permitted + -- * Class 39 - External Routine Invocation Exception + , external_routine_invocation_exception + , e_r_i_e_invalid_sqlstate_returned + , e_r_i_e_null_value_not_allowed + , e_r_i_e_trigger_protocol_violated + , e_r_i_e_srf_protocol_violated + , e_r_i_e_event_trigger_protocol_violated + -- * Class 3B - Savepoint Exception + , savepoint_exception + , invalid_savepoint_specification + -- * Class 3D - Invalid Catalog Name + , invalid_catalog_name + -- * Class 3F - Invalid Schema Name + , invalid_schema_name + -- * Class 40 - Transaction Rollback + , transaction_rollback + , transaction_integrity_constraint_violation + , serialization_failure + , statement_completion_unknown + , deadlock_detected + -- * Class 42 - Syntax Error or Access Rule Violation + , syntax_error_or_access_rule_violation + , syntax_error + , insufficient_privilege + , cannot_coerce + , grouping_error + , windowing_error + , invalid_recursion + , invalid_foreign_key + , invalid_name + , name_too_long + , reserved_name + , datatype_mismatch + , indeterminate_datatype + , collation_mismatch + , indeterminate_collation + , wrong_object_type + , generated_always + , undefined_column + , _UNDEFINED_CURSOR + , _UNDEFINED_DATABASE + , undefined_function + , _UNDEFINED_PSTATEMENT + , _UNDEFINED_SCHEMA + , undefined_table + , undefined_parameter + , undefined_object + , duplicate_column + , duplicate_cursor + , duplicate_database + , duplicate_function + , duplicate_prepared_statement + , duplicate_schema + , duplicate_table + , duplicate_alias + , duplicate_object + , ambiguous_column + , ambiguous_function + , ambiguous_parameter + , ambiguous_alias + , invalid_column_reference + , invalid_column_definition + , invalid_cursor_definition + , invalid_database_definition + , invalid_function_definition + , invalid_prepared_statement_definition + , invalid_schema_definition + , invalid_table_definition + , invalid_object_definition + -- * Class 44 - WITH CHECK OPTION Violation + , with_check_option_violation + -- * Class 53 - Insufficient Resources + , insufficient_resources + , disk_full + , out_of_memory + , too_many_connections + , configuration_limit_exceeded + -- * Class 54 - Program Limit Exceeded + , program_limit_exceeded + , statement_too_complex + , too_many_columns + , too_many_arguments + -- * Class 55 - Object Not In Prerequisite State + , object_not_in_prerequisite_state + , object_in_use + , cant_change_runtime_param + , lock_not_available + , unsafe_new_enum_value_usage + -- * Class 57 - Operator Intervention + , operator_intervention + , query_canceled + , admin_shutdown + , crash_shutdown + , cannot_connect_now + , database_dropped + -- * Class 58 - System Error (errors external to PostgreSQL itself) + , system_error + , io_error + , undefined_file + , duplicate_file + -- * Class 72 - Snapshot Failure + , snapshot_too_old + -- * Class F0 - Configuration File Error + , config_file_error + , lock_file_exists + -- * Class HV - Foreign Data Wrapper Error (SQL/MED) + , fdw_error + , fdw_column_name_not_found + , fdw_dynamic_parameter_value_needed + , fdw_function_sequence_error + , fdw_inconsistent_descriptor_information + , fdw_invalid_attribute_value + , fdw_invalid_column_name + , fdw_invalid_column_number + , fdw_invalid_data_type + , fdw_invalid_data_type_descriptors + , fdw_invalid_descriptor_field_identifier + , fdw_invalid_handle + , fdw_invalid_option_index + , fdw_invalid_option_name + , fdw_invalid_string_length_or_buffer_length + , fdw_invalid_string_format + , fdw_invalid_use_of_null_pointer + , fdw_too_many_handles + , fdw_out_of_memory + , fdw_no_schemas + , fdw_option_name_not_found + , fdw_reply_handle + , fdw_schema_not_found + , fdw_table_not_found + , fdw_unable_to_create_execution + , fdw_unable_to_create_reply + , fdw_unable_to_establish_connection + -- * Class P0 - PL/pgSQL Error + , plpgsql_error + , raise_exception + , no_data_found + , too_many_rows + , assert_failure + -- * Class XX - Internal Error + , internal_error + , data_corrupted + , index_corrupted +) where + +import Data.ByteString (ByteString) +import Data.Map.Strict (Map, fromDistinctAscList) + +-- |@SUCCESSFUL_COMPLETION@: 00000 (Success) +successful_completion :: ByteString +successful_completion = "00000" + +-- |@WARNING@: 01000 (Warning) +warning :: ByteString +warning = "01000" + +-- |@WARNING_DYNAMIC_RESULT_SETS_RETURNED@: 0100C (Warning) +warning_dynamic_result_sets_returned :: ByteString +warning_dynamic_result_sets_returned = "0100C" + +-- |@WARNING_IMPLICIT_ZERO_BIT_PADDING@: 01008 (Warning) +warning_implicit_zero_bit_padding :: ByteString +warning_implicit_zero_bit_padding = "01008" + +-- |@WARNING_NULL_VALUE_ELIMINATED_IN_SET_FUNCTION@: 01003 (Warning) +warning_null_value_eliminated_in_set_function :: ByteString +warning_null_value_eliminated_in_set_function = "01003" + +-- |@WARNING_PRIVILEGE_NOT_GRANTED@: 01007 (Warning) +warning_privilege_not_granted :: ByteString +warning_privilege_not_granted = "01007" + +-- |@WARNING_PRIVILEGE_NOT_REVOKED@: 01006 (Warning) +warning_privilege_not_revoked :: ByteString +warning_privilege_not_revoked = "01006" + +-- |@WARNING_STRING_DATA_RIGHT_TRUNCATION@: 01004 (Warning) +warning_string_data_right_truncation :: ByteString +warning_string_data_right_truncation = "01004" + +-- |@WARNING_DEPRECATED_FEATURE@: 01P01 (Warning) +warning_deprecated_feature :: ByteString +warning_deprecated_feature = "01P01" + +-- |@NO_DATA@: 02000 (Warning) +no_data :: ByteString +no_data = "02000" + +-- |@NO_ADDITIONAL_DYNAMIC_RESULT_SETS_RETURNED@: 02001 (Warning) +no_additional_dynamic_result_sets_returned :: ByteString +no_additional_dynamic_result_sets_returned = "02001" + +-- |@SQL_STATEMENT_NOT_YET_COMPLETE@: 03000 (Error) +sql_statement_not_yet_complete :: ByteString +sql_statement_not_yet_complete = "03000" + +-- |@CONNECTION_EXCEPTION@: 08000 (Error) +connection_exception :: ByteString +connection_exception = "08000" + +-- |@CONNECTION_DOES_NOT_EXIST@: 08003 (Error) +connection_does_not_exist :: ByteString +connection_does_not_exist = "08003" + +-- |@CONNECTION_FAILURE@: 08006 (Error) +connection_failure :: ByteString +connection_failure = "08006" + +-- |@SQLCLIENT_UNABLE_TO_ESTABLISH_SQLCONNECTION@: 08001 (Error) +sqlclient_unable_to_establish_sqlconnection :: ByteString +sqlclient_unable_to_establish_sqlconnection = "08001" + +-- |@SQLSERVER_REJECTED_ESTABLISHMENT_OF_SQLCONNECTION@: 08004 (Error) +sqlserver_rejected_establishment_of_sqlconnection :: ByteString +sqlserver_rejected_establishment_of_sqlconnection = "08004" + +-- |@TRANSACTION_RESOLUTION_UNKNOWN@: 08007 (Error) +transaction_resolution_unknown :: ByteString +transaction_resolution_unknown = "08007" + +-- |@PROTOCOL_VIOLATION@: 08P01 (Error) +protocol_violation :: ByteString +protocol_violation = "08P01" + +-- |@TRIGGERED_ACTION_EXCEPTION@: 09000 (Error) +triggered_action_exception :: ByteString +triggered_action_exception = "09000" + +-- |@FEATURE_NOT_SUPPORTED@: 0A000 (Error) +feature_not_supported :: ByteString +feature_not_supported = "0A000" + +-- |@INVALID_TRANSACTION_INITIATION@: 0B000 (Error) +invalid_transaction_initiation :: ByteString +invalid_transaction_initiation = "0B000" + +-- |@LOCATOR_EXCEPTION@: 0F000 (Error) +locator_exception :: ByteString +locator_exception = "0F000" + +-- |@L_E_INVALID_SPECIFICATION@: 0F001 (Error) +invalid_locator_specification :: ByteString +invalid_locator_specification = "0F001" + +-- |@INVALID_GRANTOR@: 0L000 (Error) +invalid_grantor :: ByteString +invalid_grantor = "0L000" + +-- |@INVALID_GRANT_OPERATION@: 0LP01 (Error) +invalid_grant_operation :: ByteString +invalid_grant_operation = "0LP01" + +-- |@INVALID_ROLE_SPECIFICATION@: 0P000 (Error) +invalid_role_specification :: ByteString +invalid_role_specification = "0P000" + +-- |@DIAGNOSTICS_EXCEPTION@: 0Z000 (Error) +diagnostics_exception :: ByteString +diagnostics_exception = "0Z000" + +-- |@STACKED_DIAGNOSTICS_ACCESSED_WITHOUT_ACTIVE_HANDLER@: 0Z002 (Error) +stacked_diagnostics_accessed_without_active_handler :: ByteString +stacked_diagnostics_accessed_without_active_handler = "0Z002" + +-- |@CASE_NOT_FOUND@: 20000 (Error) +case_not_found :: ByteString +case_not_found = "20000" + +-- |@CARDINALITY_VIOLATION@: 21000 (Error) +cardinality_violation :: ByteString +cardinality_violation = "21000" + +-- |@DATA_EXCEPTION@: 22000 (Error) +data_exception :: ByteString +data_exception = "22000" + +-- |@ARRAY_ELEMENT_ERROR@: 2202E (Error) +_ARRAY_ELEMENT_ERROR :: ByteString +_ARRAY_ELEMENT_ERROR = "2202E" + +-- |@ARRAY_SUBSCRIPT_ERROR@: 2202E (Error) +array_subscript_error :: ByteString +array_subscript_error = "2202E" + +-- |@CHARACTER_NOT_IN_REPERTOIRE@: 22021 (Error) +character_not_in_repertoire :: ByteString +character_not_in_repertoire = "22021" + +-- |@DATETIME_FIELD_OVERFLOW@: 22008 (Error) +datetime_field_overflow :: ByteString +datetime_field_overflow = "22008" + +-- |@DATETIME_VALUE_OUT_OF_RANGE@: 22008 (Error) +_DATETIME_VALUE_OUT_OF_RANGE :: ByteString +_DATETIME_VALUE_OUT_OF_RANGE = "22008" + +-- |@DIVISION_BY_ZERO@: 22012 (Error) +division_by_zero :: ByteString +division_by_zero = "22012" + +-- |@ERROR_IN_ASSIGNMENT@: 22005 (Error) +error_in_assignment :: ByteString +error_in_assignment = "22005" + +-- |@ESCAPE_CHARACTER_CONFLICT@: 2200B (Error) +escape_character_conflict :: ByteString +escape_character_conflict = "2200B" + +-- |@INDICATOR_OVERFLOW@: 22022 (Error) +indicator_overflow :: ByteString +indicator_overflow = "22022" + +-- |@INTERVAL_FIELD_OVERFLOW@: 22015 (Error) +interval_field_overflow :: ByteString +interval_field_overflow = "22015" + +-- |@INVALID_ARGUMENT_FOR_LOG@: 2201E (Error) +invalid_argument_for_logarithm :: ByteString +invalid_argument_for_logarithm = "2201E" + +-- |@INVALID_ARGUMENT_FOR_NTILE@: 22014 (Error) +invalid_argument_for_ntile_function :: ByteString +invalid_argument_for_ntile_function = "22014" + +-- |@INVALID_ARGUMENT_FOR_NTH_VALUE@: 22016 (Error) +invalid_argument_for_nth_value_function :: ByteString +invalid_argument_for_nth_value_function = "22016" + +-- |@INVALID_ARGUMENT_FOR_POWER_FUNCTION@: 2201F (Error) +invalid_argument_for_power_function :: ByteString +invalid_argument_for_power_function = "2201F" + +-- |@INVALID_ARGUMENT_FOR_WIDTH_BUCKET_FUNCTION@: 2201G (Error) +invalid_argument_for_width_bucket_function :: ByteString +invalid_argument_for_width_bucket_function = "2201G" + +-- |@INVALID_CHARACTER_VALUE_FOR_CAST@: 22018 (Error) +invalid_character_value_for_cast :: ByteString +invalid_character_value_for_cast = "22018" + +-- |@INVALID_DATETIME_FORMAT@: 22007 (Error) +invalid_datetime_format :: ByteString +invalid_datetime_format = "22007" + +-- |@INVALID_ESCAPE_CHARACTER@: 22019 (Error) +invalid_escape_character :: ByteString +invalid_escape_character = "22019" + +-- |@INVALID_ESCAPE_OCTET@: 2200D (Error) +invalid_escape_octet :: ByteString +invalid_escape_octet = "2200D" + +-- |@INVALID_ESCAPE_SEQUENCE@: 22025 (Error) +invalid_escape_sequence :: ByteString +invalid_escape_sequence = "22025" + +-- |@NONSTANDARD_USE_OF_ESCAPE_CHARACTER@: 22P06 (Error) +nonstandard_use_of_escape_character :: ByteString +nonstandard_use_of_escape_character = "22P06" + +-- |@INVALID_INDICATOR_PARAMETER_VALUE@: 22010 (Error) +invalid_indicator_parameter_value :: ByteString +invalid_indicator_parameter_value = "22010" + +-- |@INVALID_PARAMETER_VALUE@: 22023 (Error) +invalid_parameter_value :: ByteString +invalid_parameter_value = "22023" + +-- |@INVALID_PRECEDING_OR_FOLLOWING_SIZE@: 22013 (Error) +invalid_preceding_or_following_size :: ByteString +invalid_preceding_or_following_size = "22013" + +-- |@INVALID_REGULAR_EXPRESSION@: 2201B (Error) +invalid_regular_expression :: ByteString +invalid_regular_expression = "2201B" + +-- |@INVALID_ROW_COUNT_IN_LIMIT_CLAUSE@: 2201W (Error) +invalid_row_count_in_limit_clause :: ByteString +invalid_row_count_in_limit_clause = "2201W" + +-- |@INVALID_ROW_COUNT_IN_RESULT_OFFSET_CLAUSE@: 2201X (Error) +invalid_row_count_in_result_offset_clause :: ByteString +invalid_row_count_in_result_offset_clause = "2201X" + +-- |@INVALID_TABLESAMPLE_ARGUMENT@: 2202H (Error) +invalid_tablesample_argument :: ByteString +invalid_tablesample_argument = "2202H" + +-- |@INVALID_TABLESAMPLE_REPEAT@: 2202G (Error) +invalid_tablesample_repeat :: ByteString +invalid_tablesample_repeat = "2202G" + +-- |@INVALID_TIME_ZONE_DISPLACEMENT_VALUE@: 22009 (Error) +invalid_time_zone_displacement_value :: ByteString +invalid_time_zone_displacement_value = "22009" + +-- |@INVALID_USE_OF_ESCAPE_CHARACTER@: 2200C (Error) +invalid_use_of_escape_character :: ByteString +invalid_use_of_escape_character = "2200C" + +-- |@MOST_SPECIFIC_TYPE_MISMATCH@: 2200G (Error) +most_specific_type_mismatch :: ByteString +most_specific_type_mismatch = "2200G" + +-- |@NULL_VALUE_NOT_ALLOWED@: 22004 (Error) +null_value_not_allowed :: ByteString +null_value_not_allowed = "22004" + +-- |@NULL_VALUE_NO_INDICATOR_PARAMETER@: 22002 (Error) +null_value_no_indicator_parameter :: ByteString +null_value_no_indicator_parameter = "22002" + +-- |@NUMERIC_VALUE_OUT_OF_RANGE@: 22003 (Error) +numeric_value_out_of_range :: ByteString +numeric_value_out_of_range = "22003" + +-- |@SEQUENCE_GENERATOR_LIMIT_EXCEEDED@: 2200H (Error) +sequence_generator_limit_exceeded :: ByteString +sequence_generator_limit_exceeded = "2200H" + +-- |@STRING_DATA_LENGTH_MISMATCH@: 22026 (Error) +string_data_length_mismatch :: ByteString +string_data_length_mismatch = "22026" + +-- |@STRING_DATA_RIGHT_TRUNCATION@: 22001 (Error) +string_data_right_truncation :: ByteString +string_data_right_truncation = "22001" + +-- |@SUBSTRING_ERROR@: 22011 (Error) +substring_error :: ByteString +substring_error = "22011" + +-- |@TRIM_ERROR@: 22027 (Error) +trim_error :: ByteString +trim_error = "22027" + +-- |@UNTERMINATED_C_STRING@: 22024 (Error) +unterminated_c_string :: ByteString +unterminated_c_string = "22024" + +-- |@ZERO_LENGTH_CHARACTER_STRING@: 2200F (Error) +zero_length_character_string :: ByteString +zero_length_character_string = "2200F" + +-- |@FLOATING_POINT_EXCEPTION@: 22P01 (Error) +floating_point_exception :: ByteString +floating_point_exception = "22P01" + +-- |@INVALID_TEXT_REPRESENTATION@: 22P02 (Error) +invalid_text_representation :: ByteString +invalid_text_representation = "22P02" + +-- |@INVALID_BINARY_REPRESENTATION@: 22P03 (Error) +invalid_binary_representation :: ByteString +invalid_binary_representation = "22P03" + +-- |@BAD_COPY_FILE_FORMAT@: 22P04 (Error) +bad_copy_file_format :: ByteString +bad_copy_file_format = "22P04" + +-- |@UNTRANSLATABLE_CHARACTER@: 22P05 (Error) +untranslatable_character :: ByteString +untranslatable_character = "22P05" + +-- |@NOT_AN_XML_DOCUMENT@: 2200L (Error) +not_an_xml_document :: ByteString +not_an_xml_document = "2200L" + +-- |@INVALID_XML_DOCUMENT@: 2200M (Error) +invalid_xml_document :: ByteString +invalid_xml_document = "2200M" + +-- |@INVALID_XML_CONTENT@: 2200N (Error) +invalid_xml_content :: ByteString +invalid_xml_content = "2200N" + +-- |@INVALID_XML_COMMENT@: 2200S (Error) +invalid_xml_comment :: ByteString +invalid_xml_comment = "2200S" + +-- |@INVALID_XML_PROCESSING_INSTRUCTION@: 2200T (Error) +invalid_xml_processing_instruction :: ByteString +invalid_xml_processing_instruction = "2200T" + +-- |@DUPLICATE_JSON_OBJECT_KEY_VALUE@: 22030 (Error) +duplicate_json_object_key_value :: ByteString +duplicate_json_object_key_value = "22030" + +-- |@INVALID_JSON_TEXT@: 22032 (Error) +invalid_json_text :: ByteString +invalid_json_text = "22032" + +-- |@INVALID_SQL_JSON_SUBSCRIPT@: 22033 (Error) +invalid_sql_json_subscript :: ByteString +invalid_sql_json_subscript = "22033" + +-- |@MORE_THAN_ONE_SQL_JSON_ITEM@: 22034 (Error) +more_than_one_sql_json_item :: ByteString +more_than_one_sql_json_item = "22034" + +-- |@NO_SQL_JSON_ITEM@: 22035 (Error) +no_sql_json_item :: ByteString +no_sql_json_item = "22035" + +-- |@NON_NUMERIC_SQL_JSON_ITEM@: 22036 (Error) +non_numeric_sql_json_item :: ByteString +non_numeric_sql_json_item = "22036" + +-- |@NON_UNIQUE_KEYS_IN_A_JSON_OBJECT@: 22037 (Error) +non_unique_keys_in_a_json_object :: ByteString +non_unique_keys_in_a_json_object = "22037" + +-- |@SINGLETON_SQL_JSON_ITEM_REQUIRED@: 22038 (Error) +singleton_sql_json_item_required :: ByteString +singleton_sql_json_item_required = "22038" + +-- |@SQL_JSON_ARRAY_NOT_FOUND@: 22039 (Error) +sql_json_array_not_found :: ByteString +sql_json_array_not_found = "22039" + +-- |@SQL_JSON_MEMBER_NOT_FOUND@: 2203A (Error) +sql_json_member_not_found :: ByteString +sql_json_member_not_found = "2203A" + +-- |@SQL_JSON_NUMBER_NOT_FOUND@: 2203B (Error) +sql_json_number_not_found :: ByteString +sql_json_number_not_found = "2203B" + +-- |@SQL_JSON_OBJECT_NOT_FOUND@: 2203C (Error) +sql_json_object_not_found :: ByteString +sql_json_object_not_found = "2203C" + +-- |@TOO_MANY_JSON_ARRAY_ELEMENTS@: 2203D (Error) +too_many_json_array_elements :: ByteString +too_many_json_array_elements = "2203D" + +-- |@TOO_MANY_JSON_OBJECT_MEMBERS@: 2203E (Error) +too_many_json_object_members :: ByteString +too_many_json_object_members = "2203E" + +-- |@SQL_JSON_SCALAR_REQUIRED@: 2203F (Error) +sql_json_scalar_required :: ByteString +sql_json_scalar_required = "2203F" + +-- |@INTEGRITY_CONSTRAINT_VIOLATION@: 23000 (Error) +integrity_constraint_violation :: ByteString +integrity_constraint_violation = "23000" + +-- |@RESTRICT_VIOLATION@: 23001 (Error) +restrict_violation :: ByteString +restrict_violation = "23001" + +-- |@NOT_NULL_VIOLATION@: 23502 (Error) +not_null_violation :: ByteString +not_null_violation = "23502" + +-- |@FOREIGN_KEY_VIOLATION@: 23503 (Error) +foreign_key_violation :: ByteString +foreign_key_violation = "23503" + +-- |@UNIQUE_VIOLATION@: 23505 (Error) +unique_violation :: ByteString +unique_violation = "23505" + +-- |@CHECK_VIOLATION@: 23514 (Error) +check_violation :: ByteString +check_violation = "23514" + +-- |@EXCLUSION_VIOLATION@: 23P01 (Error) +exclusion_violation :: ByteString +exclusion_violation = "23P01" + +-- |@INVALID_CURSOR_STATE@: 24000 (Error) +invalid_cursor_state :: ByteString +invalid_cursor_state = "24000" + +-- |@INVALID_TRANSACTION_STATE@: 25000 (Error) +invalid_transaction_state :: ByteString +invalid_transaction_state = "25000" + +-- |@ACTIVE_SQL_TRANSACTION@: 25001 (Error) +active_sql_transaction :: ByteString +active_sql_transaction = "25001" + +-- |@BRANCH_TRANSACTION_ALREADY_ACTIVE@: 25002 (Error) +branch_transaction_already_active :: ByteString +branch_transaction_already_active = "25002" + +-- |@HELD_CURSOR_REQUIRES_SAME_ISOLATION_LEVEL@: 25008 (Error) +held_cursor_requires_same_isolation_level :: ByteString +held_cursor_requires_same_isolation_level = "25008" + +-- |@INAPPROPRIATE_ACCESS_MODE_FOR_BRANCH_TRANSACTION@: 25003 (Error) +inappropriate_access_mode_for_branch_transaction :: ByteString +inappropriate_access_mode_for_branch_transaction = "25003" + +-- |@INAPPROPRIATE_ISOLATION_LEVEL_FOR_BRANCH_TRANSACTION@: 25004 (Error) +inappropriate_isolation_level_for_branch_transaction :: ByteString +inappropriate_isolation_level_for_branch_transaction = "25004" + +-- |@NO_ACTIVE_SQL_TRANSACTION_FOR_BRANCH_TRANSACTION@: 25005 (Error) +no_active_sql_transaction_for_branch_transaction :: ByteString +no_active_sql_transaction_for_branch_transaction = "25005" + +-- |@READ_ONLY_SQL_TRANSACTION@: 25006 (Error) +read_only_sql_transaction :: ByteString +read_only_sql_transaction = "25006" + +-- |@SCHEMA_AND_DATA_STATEMENT_MIXING_NOT_SUPPORTED@: 25007 (Error) +schema_and_data_statement_mixing_not_supported :: ByteString +schema_and_data_statement_mixing_not_supported = "25007" + +-- |@NO_ACTIVE_SQL_TRANSACTION@: 25P01 (Error) +no_active_sql_transaction :: ByteString +no_active_sql_transaction = "25P01" + +-- |@IN_FAILED_SQL_TRANSACTION@: 25P02 (Error) +in_failed_sql_transaction :: ByteString +in_failed_sql_transaction = "25P02" + +-- |@IDLE_IN_TRANSACTION_SESSION_TIMEOUT@: 25P03 (Error) +idle_in_transaction_session_timeout :: ByteString +idle_in_transaction_session_timeout = "25P03" + +-- |@INVALID_SQL_STATEMENT_NAME@: 26000 (Error) +invalid_sql_statement_name :: ByteString +invalid_sql_statement_name = "26000" + +-- |@TRIGGERED_DATA_CHANGE_VIOLATION@: 27000 (Error) +triggered_data_change_violation :: ByteString +triggered_data_change_violation = "27000" + +-- |@INVALID_AUTHORIZATION_SPECIFICATION@: 28000 (Error) +invalid_authorization_specification :: ByteString +invalid_authorization_specification = "28000" + +-- |@INVALID_PASSWORD@: 28P01 (Error) +invalid_password :: ByteString +invalid_password = "28P01" + +-- |@DEPENDENT_PRIVILEGE_DESCRIPTORS_STILL_EXIST@: 2B000 (Error) +dependent_privilege_descriptors_still_exist :: ByteString +dependent_privilege_descriptors_still_exist = "2B000" + +-- |@DEPENDENT_OBJECTS_STILL_EXIST@: 2BP01 (Error) +dependent_objects_still_exist :: ByteString +dependent_objects_still_exist = "2BP01" + +-- |@INVALID_TRANSACTION_TERMINATION@: 2D000 (Error) +invalid_transaction_termination :: ByteString +invalid_transaction_termination = "2D000" + +-- |@SQL_ROUTINE_EXCEPTION@: 2F000 (Error) +sql_routine_exception :: ByteString +sql_routine_exception = "2F000" + +-- |@S_R_E_FUNCTION_EXECUTED_NO_RETURN_STATEMENT@: 2F005 (Error) +s_r_e_function_executed_no_return_statement :: ByteString +s_r_e_function_executed_no_return_statement = "2F005" + +-- |@S_R_E_MODIFYING_SQL_DATA_NOT_PERMITTED@: 2F002 (Error) +s_r_e_modifying_sql_data_not_permitted :: ByteString +s_r_e_modifying_sql_data_not_permitted = "2F002" + +-- |@S_R_E_PROHIBITED_SQL_STATEMENT_ATTEMPTED@: 2F003 (Error) +s_r_e_prohibited_sql_statement_attempted :: ByteString +s_r_e_prohibited_sql_statement_attempted = "2F003" + +-- |@S_R_E_READING_SQL_DATA_NOT_PERMITTED@: 2F004 (Error) +s_r_e_reading_sql_data_not_permitted :: ByteString +s_r_e_reading_sql_data_not_permitted = "2F004" + +-- |@INVALID_CURSOR_NAME@: 34000 (Error) +invalid_cursor_name :: ByteString +invalid_cursor_name = "34000" + +-- |@EXTERNAL_ROUTINE_EXCEPTION@: 38000 (Error) +external_routine_exception :: ByteString +external_routine_exception = "38000" + +-- |@E_R_E_CONTAINING_SQL_NOT_PERMITTED@: 38001 (Error) +e_r_e_containing_sql_not_permitted :: ByteString +e_r_e_containing_sql_not_permitted = "38001" + +-- |@E_R_E_MODIFYING_SQL_DATA_NOT_PERMITTED@: 38002 (Error) +e_r_e_modifying_sql_data_not_permitted :: ByteString +e_r_e_modifying_sql_data_not_permitted = "38002" + +-- |@E_R_E_PROHIBITED_SQL_STATEMENT_ATTEMPTED@: 38003 (Error) +e_r_e_prohibited_sql_statement_attempted :: ByteString +e_r_e_prohibited_sql_statement_attempted = "38003" + +-- |@E_R_E_READING_SQL_DATA_NOT_PERMITTED@: 38004 (Error) +e_r_e_reading_sql_data_not_permitted :: ByteString +e_r_e_reading_sql_data_not_permitted = "38004" + +-- |@EXTERNAL_ROUTINE_INVOCATION_EXCEPTION@: 39000 (Error) +external_routine_invocation_exception :: ByteString +external_routine_invocation_exception = "39000" + +-- |@E_R_I_E_INVALID_SQLSTATE_RETURNED@: 39001 (Error) +e_r_i_e_invalid_sqlstate_returned :: ByteString +e_r_i_e_invalid_sqlstate_returned = "39001" + +-- |@E_R_I_E_NULL_VALUE_NOT_ALLOWED@: 39004 (Error) +e_r_i_e_null_value_not_allowed :: ByteString +e_r_i_e_null_value_not_allowed = "39004" + +-- |@E_R_I_E_TRIGGER_PROTOCOL_VIOLATED@: 39P01 (Error) +e_r_i_e_trigger_protocol_violated :: ByteString +e_r_i_e_trigger_protocol_violated = "39P01" + +-- |@E_R_I_E_SRF_PROTOCOL_VIOLATED@: 39P02 (Error) +e_r_i_e_srf_protocol_violated :: ByteString +e_r_i_e_srf_protocol_violated = "39P02" + +-- |@E_R_I_E_EVENT_TRIGGER_PROTOCOL_VIOLATED@: 39P03 (Error) +e_r_i_e_event_trigger_protocol_violated :: ByteString +e_r_i_e_event_trigger_protocol_violated = "39P03" + +-- |@SAVEPOINT_EXCEPTION@: 3B000 (Error) +savepoint_exception :: ByteString +savepoint_exception = "3B000" + +-- |@S_E_INVALID_SPECIFICATION@: 3B001 (Error) +invalid_savepoint_specification :: ByteString +invalid_savepoint_specification = "3B001" + +-- |@INVALID_CATALOG_NAME@: 3D000 (Error) +invalid_catalog_name :: ByteString +invalid_catalog_name = "3D000" + +-- |@INVALID_SCHEMA_NAME@: 3F000 (Error) +invalid_schema_name :: ByteString +invalid_schema_name = "3F000" + +-- |@TRANSACTION_ROLLBACK@: 40000 (Error) +transaction_rollback :: ByteString +transaction_rollback = "40000" + +-- |@T_R_INTEGRITY_CONSTRAINT_VIOLATION@: 40002 (Error) +transaction_integrity_constraint_violation :: ByteString +transaction_integrity_constraint_violation = "40002" + +-- |@T_R_SERIALIZATION_FAILURE@: 40001 (Error) +serialization_failure :: ByteString +serialization_failure = "40001" + +-- |@T_R_STATEMENT_COMPLETION_UNKNOWN@: 40003 (Error) +statement_completion_unknown :: ByteString +statement_completion_unknown = "40003" + +-- |@T_R_DEADLOCK_DETECTED@: 40P01 (Error) +deadlock_detected :: ByteString +deadlock_detected = "40P01" + +-- |@SYNTAX_ERROR_OR_ACCESS_RULE_VIOLATION@: 42000 (Error) +syntax_error_or_access_rule_violation :: ByteString +syntax_error_or_access_rule_violation = "42000" + +-- |@SYNTAX_ERROR@: 42601 (Error) +syntax_error :: ByteString +syntax_error = "42601" + +-- |@INSUFFICIENT_PRIVILEGE@: 42501 (Error) +insufficient_privilege :: ByteString +insufficient_privilege = "42501" + +-- |@CANNOT_COERCE@: 42846 (Error) +cannot_coerce :: ByteString +cannot_coerce = "42846" + +-- |@GROUPING_ERROR@: 42803 (Error) +grouping_error :: ByteString +grouping_error = "42803" + +-- |@WINDOWING_ERROR@: 42P20 (Error) +windowing_error :: ByteString +windowing_error = "42P20" + +-- |@INVALID_RECURSION@: 42P19 (Error) +invalid_recursion :: ByteString +invalid_recursion = "42P19" + +-- |@INVALID_FOREIGN_KEY@: 42830 (Error) +invalid_foreign_key :: ByteString +invalid_foreign_key = "42830" + +-- |@INVALID_NAME@: 42602 (Error) +invalid_name :: ByteString +invalid_name = "42602" + +-- |@NAME_TOO_LONG@: 42622 (Error) +name_too_long :: ByteString +name_too_long = "42622" + +-- |@RESERVED_NAME@: 42939 (Error) +reserved_name :: ByteString +reserved_name = "42939" + +-- |@DATATYPE_MISMATCH@: 42804 (Error) +datatype_mismatch :: ByteString +datatype_mismatch = "42804" + +-- |@INDETERMINATE_DATATYPE@: 42P18 (Error) +indeterminate_datatype :: ByteString +indeterminate_datatype = "42P18" + +-- |@COLLATION_MISMATCH@: 42P21 (Error) +collation_mismatch :: ByteString +collation_mismatch = "42P21" + +-- |@INDETERMINATE_COLLATION@: 42P22 (Error) +indeterminate_collation :: ByteString +indeterminate_collation = "42P22" + +-- |@WRONG_OBJECT_TYPE@: 42809 (Error) +wrong_object_type :: ByteString +wrong_object_type = "42809" + +-- |@GENERATED_ALWAYS@: 428C9 (Error) +generated_always :: ByteString +generated_always = "428C9" + +-- |@UNDEFINED_COLUMN@: 42703 (Error) +undefined_column :: ByteString +undefined_column = "42703" + +-- |@UNDEFINED_CURSOR@: 34000 (Error) +_UNDEFINED_CURSOR :: ByteString +_UNDEFINED_CURSOR = "34000" + +-- |@UNDEFINED_DATABASE@: 3D000 (Error) +_UNDEFINED_DATABASE :: ByteString +_UNDEFINED_DATABASE = "3D000" + +-- |@UNDEFINED_FUNCTION@: 42883 (Error) +undefined_function :: ByteString +undefined_function = "42883" + +-- |@UNDEFINED_PSTATEMENT@: 26000 (Error) +_UNDEFINED_PSTATEMENT :: ByteString +_UNDEFINED_PSTATEMENT = "26000" + +-- |@UNDEFINED_SCHEMA@: 3F000 (Error) +_UNDEFINED_SCHEMA :: ByteString +_UNDEFINED_SCHEMA = "3F000" + +-- |@UNDEFINED_TABLE@: 42P01 (Error) +undefined_table :: ByteString +undefined_table = "42P01" + +-- |@UNDEFINED_PARAMETER@: 42P02 (Error) +undefined_parameter :: ByteString +undefined_parameter = "42P02" + +-- |@UNDEFINED_OBJECT@: 42704 (Error) +undefined_object :: ByteString +undefined_object = "42704" + +-- |@DUPLICATE_COLUMN@: 42701 (Error) +duplicate_column :: ByteString +duplicate_column = "42701" + +-- |@DUPLICATE_CURSOR@: 42P03 (Error) +duplicate_cursor :: ByteString +duplicate_cursor = "42P03" + +-- |@DUPLICATE_DATABASE@: 42P04 (Error) +duplicate_database :: ByteString +duplicate_database = "42P04" + +-- |@DUPLICATE_FUNCTION@: 42723 (Error) +duplicate_function :: ByteString +duplicate_function = "42723" + +-- |@DUPLICATE_PSTATEMENT@: 42P05 (Error) +duplicate_prepared_statement :: ByteString +duplicate_prepared_statement = "42P05" + +-- |@DUPLICATE_SCHEMA@: 42P06 (Error) +duplicate_schema :: ByteString +duplicate_schema = "42P06" + +-- |@DUPLICATE_TABLE@: 42P07 (Error) +duplicate_table :: ByteString +duplicate_table = "42P07" + +-- |@DUPLICATE_ALIAS@: 42712 (Error) +duplicate_alias :: ByteString +duplicate_alias = "42712" + +-- |@DUPLICATE_OBJECT@: 42710 (Error) +duplicate_object :: ByteString +duplicate_object = "42710" + +-- |@AMBIGUOUS_COLUMN@: 42702 (Error) +ambiguous_column :: ByteString +ambiguous_column = "42702" + +-- |@AMBIGUOUS_FUNCTION@: 42725 (Error) +ambiguous_function :: ByteString +ambiguous_function = "42725" + +-- |@AMBIGUOUS_PARAMETER@: 42P08 (Error) +ambiguous_parameter :: ByteString +ambiguous_parameter = "42P08" + +-- |@AMBIGUOUS_ALIAS@: 42P09 (Error) +ambiguous_alias :: ByteString +ambiguous_alias = "42P09" + +-- |@INVALID_COLUMN_REFERENCE@: 42P10 (Error) +invalid_column_reference :: ByteString +invalid_column_reference = "42P10" + +-- |@INVALID_COLUMN_DEFINITION@: 42611 (Error) +invalid_column_definition :: ByteString +invalid_column_definition = "42611" + +-- |@INVALID_CURSOR_DEFINITION@: 42P11 (Error) +invalid_cursor_definition :: ByteString +invalid_cursor_definition = "42P11" + +-- |@INVALID_DATABASE_DEFINITION@: 42P12 (Error) +invalid_database_definition :: ByteString +invalid_database_definition = "42P12" + +-- |@INVALID_FUNCTION_DEFINITION@: 42P13 (Error) +invalid_function_definition :: ByteString +invalid_function_definition = "42P13" + +-- |@INVALID_PSTATEMENT_DEFINITION@: 42P14 (Error) +invalid_prepared_statement_definition :: ByteString +invalid_prepared_statement_definition = "42P14" + +-- |@INVALID_SCHEMA_DEFINITION@: 42P15 (Error) +invalid_schema_definition :: ByteString +invalid_schema_definition = "42P15" + +-- |@INVALID_TABLE_DEFINITION@: 42P16 (Error) +invalid_table_definition :: ByteString +invalid_table_definition = "42P16" + +-- |@INVALID_OBJECT_DEFINITION@: 42P17 (Error) +invalid_object_definition :: ByteString +invalid_object_definition = "42P17" + +-- |@WITH_CHECK_OPTION_VIOLATION@: 44000 (Error) +with_check_option_violation :: ByteString +with_check_option_violation = "44000" + +-- |@INSUFFICIENT_RESOURCES@: 53000 (Error) +insufficient_resources :: ByteString +insufficient_resources = "53000" + +-- |@DISK_FULL@: 53100 (Error) +disk_full :: ByteString +disk_full = "53100" + +-- |@OUT_OF_MEMORY@: 53200 (Error) +out_of_memory :: ByteString +out_of_memory = "53200" + +-- |@TOO_MANY_CONNECTIONS@: 53300 (Error) +too_many_connections :: ByteString +too_many_connections = "53300" + +-- |@CONFIGURATION_LIMIT_EXCEEDED@: 53400 (Error) +configuration_limit_exceeded :: ByteString +configuration_limit_exceeded = "53400" + +-- |@PROGRAM_LIMIT_EXCEEDED@: 54000 (Error) +program_limit_exceeded :: ByteString +program_limit_exceeded = "54000" + +-- |@STATEMENT_TOO_COMPLEX@: 54001 (Error) +statement_too_complex :: ByteString +statement_too_complex = "54001" + +-- |@TOO_MANY_COLUMNS@: 54011 (Error) +too_many_columns :: ByteString +too_many_columns = "54011" + +-- |@TOO_MANY_ARGUMENTS@: 54023 (Error) +too_many_arguments :: ByteString +too_many_arguments = "54023" + +-- |@OBJECT_NOT_IN_PREREQUISITE_STATE@: 55000 (Error) +object_not_in_prerequisite_state :: ByteString +object_not_in_prerequisite_state = "55000" + +-- |@OBJECT_IN_USE@: 55006 (Error) +object_in_use :: ByteString +object_in_use = "55006" + +-- |@CANT_CHANGE_RUNTIME_PARAM@: 55P02 (Error) +cant_change_runtime_param :: ByteString +cant_change_runtime_param = "55P02" + +-- |@LOCK_NOT_AVAILABLE@: 55P03 (Error) +lock_not_available :: ByteString +lock_not_available = "55P03" + +-- |@UNSAFE_NEW_ENUM_VALUE_USAGE@: 55P04 (Error) +unsafe_new_enum_value_usage :: ByteString +unsafe_new_enum_value_usage = "55P04" + +-- |@OPERATOR_INTERVENTION@: 57000 (Error) +operator_intervention :: ByteString +operator_intervention = "57000" + +-- |@QUERY_CANCELED@: 57014 (Error) +query_canceled :: ByteString +query_canceled = "57014" + +-- |@ADMIN_SHUTDOWN@: 57P01 (Error) +admin_shutdown :: ByteString +admin_shutdown = "57P01" + +-- |@CRASH_SHUTDOWN@: 57P02 (Error) +crash_shutdown :: ByteString +crash_shutdown = "57P02" + +-- |@CANNOT_CONNECT_NOW@: 57P03 (Error) +cannot_connect_now :: ByteString +cannot_connect_now = "57P03" + +-- |@DATABASE_DROPPED@: 57P04 (Error) +database_dropped :: ByteString +database_dropped = "57P04" + +-- |@SYSTEM_ERROR@: 58000 (Error) +system_error :: ByteString +system_error = "58000" + +-- |@IO_ERROR@: 58030 (Error) +io_error :: ByteString +io_error = "58030" + +-- |@UNDEFINED_FILE@: 58P01 (Error) +undefined_file :: ByteString +undefined_file = "58P01" + +-- |@DUPLICATE_FILE@: 58P02 (Error) +duplicate_file :: ByteString +duplicate_file = "58P02" + +-- |@SNAPSHOT_TOO_OLD@: 72000 (Error) +snapshot_too_old :: ByteString +snapshot_too_old = "72000" + +-- |@CONFIG_FILE_ERROR@: F0000 (Error) +config_file_error :: ByteString +config_file_error = "F0000" + +-- |@LOCK_FILE_EXISTS@: F0001 (Error) +lock_file_exists :: ByteString +lock_file_exists = "F0001" + +-- |@FDW_ERROR@: HV000 (Error) +fdw_error :: ByteString +fdw_error = "HV000" + +-- |@FDW_COLUMN_NAME_NOT_FOUND@: HV005 (Error) +fdw_column_name_not_found :: ByteString +fdw_column_name_not_found = "HV005" + +-- |@FDW_DYNAMIC_PARAMETER_VALUE_NEEDED@: HV002 (Error) +fdw_dynamic_parameter_value_needed :: ByteString +fdw_dynamic_parameter_value_needed = "HV002" + +-- |@FDW_FUNCTION_SEQUENCE_ERROR@: HV010 (Error) +fdw_function_sequence_error :: ByteString +fdw_function_sequence_error = "HV010" + +-- |@FDW_INCONSISTENT_DESCRIPTOR_INFORMATION@: HV021 (Error) +fdw_inconsistent_descriptor_information :: ByteString +fdw_inconsistent_descriptor_information = "HV021" + +-- |@FDW_INVALID_ATTRIBUTE_VALUE@: HV024 (Error) +fdw_invalid_attribute_value :: ByteString +fdw_invalid_attribute_value = "HV024" + +-- |@FDW_INVALID_COLUMN_NAME@: HV007 (Error) +fdw_invalid_column_name :: ByteString +fdw_invalid_column_name = "HV007" + +-- |@FDW_INVALID_COLUMN_NUMBER@: HV008 (Error) +fdw_invalid_column_number :: ByteString +fdw_invalid_column_number = "HV008" + +-- |@FDW_INVALID_DATA_TYPE@: HV004 (Error) +fdw_invalid_data_type :: ByteString +fdw_invalid_data_type = "HV004" + +-- |@FDW_INVALID_DATA_TYPE_DESCRIPTORS@: HV006 (Error) +fdw_invalid_data_type_descriptors :: ByteString +fdw_invalid_data_type_descriptors = "HV006" + +-- |@FDW_INVALID_DESCRIPTOR_FIELD_IDENTIFIER@: HV091 (Error) +fdw_invalid_descriptor_field_identifier :: ByteString +fdw_invalid_descriptor_field_identifier = "HV091" + +-- |@FDW_INVALID_HANDLE@: HV00B (Error) +fdw_invalid_handle :: ByteString +fdw_invalid_handle = "HV00B" + +-- |@FDW_INVALID_OPTION_INDEX@: HV00C (Error) +fdw_invalid_option_index :: ByteString +fdw_invalid_option_index = "HV00C" + +-- |@FDW_INVALID_OPTION_NAME@: HV00D (Error) +fdw_invalid_option_name :: ByteString +fdw_invalid_option_name = "HV00D" + +-- |@FDW_INVALID_STRING_LENGTH_OR_BUFFER_LENGTH@: HV090 (Error) +fdw_invalid_string_length_or_buffer_length :: ByteString +fdw_invalid_string_length_or_buffer_length = "HV090" + +-- |@FDW_INVALID_STRING_FORMAT@: HV00A (Error) +fdw_invalid_string_format :: ByteString +fdw_invalid_string_format = "HV00A" + +-- |@FDW_INVALID_USE_OF_NULL_POINTER@: HV009 (Error) +fdw_invalid_use_of_null_pointer :: ByteString +fdw_invalid_use_of_null_pointer = "HV009" + +-- |@FDW_TOO_MANY_HANDLES@: HV014 (Error) +fdw_too_many_handles :: ByteString +fdw_too_many_handles = "HV014" + +-- |@FDW_OUT_OF_MEMORY@: HV001 (Error) +fdw_out_of_memory :: ByteString +fdw_out_of_memory = "HV001" + +-- |@FDW_NO_SCHEMAS@: HV00P (Error) +fdw_no_schemas :: ByteString +fdw_no_schemas = "HV00P" + +-- |@FDW_OPTION_NAME_NOT_FOUND@: HV00J (Error) +fdw_option_name_not_found :: ByteString +fdw_option_name_not_found = "HV00J" + +-- |@FDW_REPLY_HANDLE@: HV00K (Error) +fdw_reply_handle :: ByteString +fdw_reply_handle = "HV00K" + +-- |@FDW_SCHEMA_NOT_FOUND@: HV00Q (Error) +fdw_schema_not_found :: ByteString +fdw_schema_not_found = "HV00Q" + +-- |@FDW_TABLE_NOT_FOUND@: HV00R (Error) +fdw_table_not_found :: ByteString +fdw_table_not_found = "HV00R" + +-- |@FDW_UNABLE_TO_CREATE_EXECUTION@: HV00L (Error) +fdw_unable_to_create_execution :: ByteString +fdw_unable_to_create_execution = "HV00L" + +-- |@FDW_UNABLE_TO_CREATE_REPLY@: HV00M (Error) +fdw_unable_to_create_reply :: ByteString +fdw_unable_to_create_reply = "HV00M" + +-- |@FDW_UNABLE_TO_ESTABLISH_CONNECTION@: HV00N (Error) +fdw_unable_to_establish_connection :: ByteString +fdw_unable_to_establish_connection = "HV00N" + +-- |@PLPGSQL_ERROR@: P0000 (Error) +plpgsql_error :: ByteString +plpgsql_error = "P0000" + +-- |@RAISE_EXCEPTION@: P0001 (Error) +raise_exception :: ByteString +raise_exception = "P0001" + +-- |@NO_DATA_FOUND@: P0002 (Error) +no_data_found :: ByteString +no_data_found = "P0002" + +-- |@TOO_MANY_ROWS@: P0003 (Error) +too_many_rows :: ByteString +too_many_rows = "P0003" + +-- |@ASSERT_FAILURE@: P0004 (Error) +assert_failure :: ByteString +assert_failure = "P0004" + +-- |@INTERNAL_ERROR@: XX000 (Error) +internal_error :: ByteString +internal_error = "XX000" + +-- |@DATA_CORRUPTED@: XX001 (Error) +data_corrupted :: ByteString +data_corrupted = "XX001" + +-- |@INDEX_CORRUPTED@: XX002 (Error) +index_corrupted :: ByteString +index_corrupted = "XX002" + +-- |All known error code names by code. +names :: Map ByteString String +names = fromDistinctAscList + [(successful_completion,"successful_completion") + ,(warning,"warning") + ,(warning_null_value_eliminated_in_set_function,"null_value_eliminated_in_set_function") + ,(warning_string_data_right_truncation,"string_data_right_truncation") + ,(warning_privilege_not_revoked,"privilege_not_revoked") + ,(warning_privilege_not_granted,"privilege_not_granted") + ,(warning_implicit_zero_bit_padding,"implicit_zero_bit_padding") + ,(warning_dynamic_result_sets_returned,"dynamic_result_sets_returned") + ,(warning_deprecated_feature,"deprecated_feature") + ,(no_data,"no_data") + ,(no_additional_dynamic_result_sets_returned,"no_additional_dynamic_result_sets_returned") + ,(sql_statement_not_yet_complete,"sql_statement_not_yet_complete") + ,(connection_exception,"connection_exception") + ,(sqlclient_unable_to_establish_sqlconnection,"sqlclient_unable_to_establish_sqlconnection") + ,(connection_does_not_exist,"connection_does_not_exist") + ,(sqlserver_rejected_establishment_of_sqlconnection,"sqlserver_rejected_establishment_of_sqlconnection") + ,(connection_failure,"connection_failure") + ,(transaction_resolution_unknown,"transaction_resolution_unknown") + ,(protocol_violation,"protocol_violation") + ,(triggered_action_exception,"triggered_action_exception") + ,(feature_not_supported,"feature_not_supported") + ,(invalid_transaction_initiation,"invalid_transaction_initiation") + ,(locator_exception,"locator_exception") + ,(invalid_locator_specification,"invalid_locator_specification") + ,(invalid_grantor,"invalid_grantor") + ,(invalid_grant_operation,"invalid_grant_operation") + ,(invalid_role_specification,"invalid_role_specification") + ,(diagnostics_exception,"diagnostics_exception") + ,(stacked_diagnostics_accessed_without_active_handler,"stacked_diagnostics_accessed_without_active_handler") + ,(case_not_found,"case_not_found") + ,(cardinality_violation,"cardinality_violation") + ,(data_exception,"data_exception") + ,(string_data_right_truncation,"string_data_right_truncation") + ,(null_value_no_indicator_parameter,"null_value_no_indicator_parameter") + ,(numeric_value_out_of_range,"numeric_value_out_of_range") + ,(null_value_not_allowed,"null_value_not_allowed") + ,(error_in_assignment,"error_in_assignment") + ,(invalid_datetime_format,"invalid_datetime_format") + ,(datetime_field_overflow,"datetime_field_overflow") + ,(_DATETIME_VALUE_OUT_OF_RANGE,"DATETIME_VALUE_OUT_OF_RANGE") + ,(invalid_time_zone_displacement_value,"invalid_time_zone_displacement_value") + ,(escape_character_conflict,"escape_character_conflict") + ,(invalid_use_of_escape_character,"invalid_use_of_escape_character") + ,(invalid_escape_octet,"invalid_escape_octet") + ,(zero_length_character_string,"zero_length_character_string") + ,(most_specific_type_mismatch,"most_specific_type_mismatch") + ,(sequence_generator_limit_exceeded,"sequence_generator_limit_exceeded") + ,(not_an_xml_document,"not_an_xml_document") + ,(invalid_xml_document,"invalid_xml_document") + ,(invalid_xml_content,"invalid_xml_content") + ,(invalid_xml_comment,"invalid_xml_comment") + ,(invalid_xml_processing_instruction,"invalid_xml_processing_instruction") + ,(invalid_indicator_parameter_value,"invalid_indicator_parameter_value") + ,(substring_error,"substring_error") + ,(division_by_zero,"division_by_zero") + ,(invalid_preceding_or_following_size,"invalid_preceding_or_following_size") + ,(invalid_argument_for_ntile_function,"invalid_argument_for_ntile_function") + ,(interval_field_overflow,"interval_field_overflow") + ,(invalid_argument_for_nth_value_function,"invalid_argument_for_nth_value_function") + ,(invalid_character_value_for_cast,"invalid_character_value_for_cast") + ,(invalid_escape_character,"invalid_escape_character") + ,(invalid_regular_expression,"invalid_regular_expression") + ,(invalid_argument_for_logarithm,"invalid_argument_for_logarithm") + ,(invalid_argument_for_power_function,"invalid_argument_for_power_function") + ,(invalid_argument_for_width_bucket_function,"invalid_argument_for_width_bucket_function") + ,(invalid_row_count_in_limit_clause,"invalid_row_count_in_limit_clause") + ,(invalid_row_count_in_result_offset_clause,"invalid_row_count_in_result_offset_clause") + ,(character_not_in_repertoire,"character_not_in_repertoire") + ,(indicator_overflow,"indicator_overflow") + ,(invalid_parameter_value,"invalid_parameter_value") + ,(unterminated_c_string,"unterminated_c_string") + ,(invalid_escape_sequence,"invalid_escape_sequence") + ,(string_data_length_mismatch,"string_data_length_mismatch") + ,(trim_error,"trim_error") + ,(_ARRAY_ELEMENT_ERROR,"ARRAY_ELEMENT_ERROR") + ,(array_subscript_error,"array_subscript_error") + ,(invalid_tablesample_repeat,"invalid_tablesample_repeat") + ,(invalid_tablesample_argument,"invalid_tablesample_argument") + ,(duplicate_json_object_key_value,"duplicate_json_object_key_value") + ,(invalid_json_text,"invalid_json_text") + ,(invalid_sql_json_subscript,"invalid_sql_json_subscript") + ,(more_than_one_sql_json_item,"more_than_one_sql_json_item") + ,(no_sql_json_item,"no_sql_json_item") + ,(non_numeric_sql_json_item,"non_numeric_sql_json_item") + ,(non_unique_keys_in_a_json_object,"non_unique_keys_in_a_json_object") + ,(singleton_sql_json_item_required,"singleton_sql_json_item_required") + ,(sql_json_array_not_found,"sql_json_array_not_found") + ,(sql_json_member_not_found,"sql_json_member_not_found") + ,(sql_json_number_not_found,"sql_json_number_not_found") + ,(sql_json_object_not_found,"sql_json_object_not_found") + ,(too_many_json_array_elements,"too_many_json_array_elements") + ,(too_many_json_object_members,"too_many_json_object_members") + ,(sql_json_scalar_required,"sql_json_scalar_required") + ,(floating_point_exception,"floating_point_exception") + ,(invalid_text_representation,"invalid_text_representation") + ,(invalid_binary_representation,"invalid_binary_representation") + ,(bad_copy_file_format,"bad_copy_file_format") + ,(untranslatable_character,"untranslatable_character") + ,(nonstandard_use_of_escape_character,"nonstandard_use_of_escape_character") + ,(integrity_constraint_violation,"integrity_constraint_violation") + ,(restrict_violation,"restrict_violation") + ,(not_null_violation,"not_null_violation") + ,(foreign_key_violation,"foreign_key_violation") + ,(unique_violation,"unique_violation") + ,(check_violation,"check_violation") + ,(exclusion_violation,"exclusion_violation") + ,(invalid_cursor_state,"invalid_cursor_state") + ,(invalid_transaction_state,"invalid_transaction_state") + ,(active_sql_transaction,"active_sql_transaction") + ,(branch_transaction_already_active,"branch_transaction_already_active") + ,(inappropriate_access_mode_for_branch_transaction,"inappropriate_access_mode_for_branch_transaction") + ,(inappropriate_isolation_level_for_branch_transaction,"inappropriate_isolation_level_for_branch_transaction") + ,(no_active_sql_transaction_for_branch_transaction,"no_active_sql_transaction_for_branch_transaction") + ,(read_only_sql_transaction,"read_only_sql_transaction") + ,(schema_and_data_statement_mixing_not_supported,"schema_and_data_statement_mixing_not_supported") + ,(held_cursor_requires_same_isolation_level,"held_cursor_requires_same_isolation_level") + ,(no_active_sql_transaction,"no_active_sql_transaction") + ,(in_failed_sql_transaction,"in_failed_sql_transaction") + ,(idle_in_transaction_session_timeout,"idle_in_transaction_session_timeout") + ,(invalid_sql_statement_name,"invalid_sql_statement_name") + ,(_UNDEFINED_PSTATEMENT,"UNDEFINED_PSTATEMENT") + ,(triggered_data_change_violation,"triggered_data_change_violation") + ,(invalid_authorization_specification,"invalid_authorization_specification") + ,(invalid_password,"invalid_password") + ,(dependent_privilege_descriptors_still_exist,"dependent_privilege_descriptors_still_exist") + ,(dependent_objects_still_exist,"dependent_objects_still_exist") + ,(invalid_transaction_termination,"invalid_transaction_termination") + ,(sql_routine_exception,"sql_routine_exception") + ,(s_r_e_modifying_sql_data_not_permitted,"modifying_sql_data_not_permitted") + ,(s_r_e_prohibited_sql_statement_attempted,"prohibited_sql_statement_attempted") + ,(s_r_e_reading_sql_data_not_permitted,"reading_sql_data_not_permitted") + ,(s_r_e_function_executed_no_return_statement,"function_executed_no_return_statement") + ,(invalid_cursor_name,"invalid_cursor_name") + ,(_UNDEFINED_CURSOR,"UNDEFINED_CURSOR") + ,(external_routine_exception,"external_routine_exception") + ,(e_r_e_containing_sql_not_permitted,"containing_sql_not_permitted") + ,(e_r_e_modifying_sql_data_not_permitted,"modifying_sql_data_not_permitted") + ,(e_r_e_prohibited_sql_statement_attempted,"prohibited_sql_statement_attempted") + ,(e_r_e_reading_sql_data_not_permitted,"reading_sql_data_not_permitted") + ,(external_routine_invocation_exception,"external_routine_invocation_exception") + ,(e_r_i_e_invalid_sqlstate_returned,"invalid_sqlstate_returned") + ,(e_r_i_e_null_value_not_allowed,"null_value_not_allowed") + ,(e_r_i_e_trigger_protocol_violated,"trigger_protocol_violated") + ,(e_r_i_e_srf_protocol_violated,"srf_protocol_violated") + ,(e_r_i_e_event_trigger_protocol_violated,"event_trigger_protocol_violated") + ,(savepoint_exception,"savepoint_exception") + ,(invalid_savepoint_specification,"invalid_savepoint_specification") + ,(invalid_catalog_name,"invalid_catalog_name") + ,(_UNDEFINED_DATABASE,"UNDEFINED_DATABASE") + ,(invalid_schema_name,"invalid_schema_name") + ,(_UNDEFINED_SCHEMA,"UNDEFINED_SCHEMA") + ,(transaction_rollback,"transaction_rollback") + ,(serialization_failure,"serialization_failure") + ,(transaction_integrity_constraint_violation,"transaction_integrity_constraint_violation") + ,(statement_completion_unknown,"statement_completion_unknown") + ,(deadlock_detected,"deadlock_detected") + ,(syntax_error_or_access_rule_violation,"syntax_error_or_access_rule_violation") + ,(insufficient_privilege,"insufficient_privilege") + ,(syntax_error,"syntax_error") + ,(invalid_name,"invalid_name") + ,(invalid_column_definition,"invalid_column_definition") + ,(name_too_long,"name_too_long") + ,(duplicate_column,"duplicate_column") + ,(ambiguous_column,"ambiguous_column") + ,(undefined_column,"undefined_column") + ,(undefined_object,"undefined_object") + ,(duplicate_object,"duplicate_object") + ,(duplicate_alias,"duplicate_alias") + ,(duplicate_function,"duplicate_function") + ,(ambiguous_function,"ambiguous_function") + ,(grouping_error,"grouping_error") + ,(datatype_mismatch,"datatype_mismatch") + ,(wrong_object_type,"wrong_object_type") + ,(invalid_foreign_key,"invalid_foreign_key") + ,(cannot_coerce,"cannot_coerce") + ,(undefined_function,"undefined_function") + ,(generated_always,"generated_always") + ,(reserved_name,"reserved_name") + ,(undefined_table,"undefined_table") + ,(undefined_parameter,"undefined_parameter") + ,(duplicate_cursor,"duplicate_cursor") + ,(duplicate_database,"duplicate_database") + ,(duplicate_prepared_statement,"duplicate_prepared_statement") + ,(duplicate_schema,"duplicate_schema") + ,(duplicate_table,"duplicate_table") + ,(ambiguous_parameter,"ambiguous_parameter") + ,(ambiguous_alias,"ambiguous_alias") + ,(invalid_column_reference,"invalid_column_reference") + ,(invalid_cursor_definition,"invalid_cursor_definition") + ,(invalid_database_definition,"invalid_database_definition") + ,(invalid_function_definition,"invalid_function_definition") + ,(invalid_prepared_statement_definition,"invalid_prepared_statement_definition") + ,(invalid_schema_definition,"invalid_schema_definition") + ,(invalid_table_definition,"invalid_table_definition") + ,(invalid_object_definition,"invalid_object_definition") + ,(indeterminate_datatype,"indeterminate_datatype") + ,(invalid_recursion,"invalid_recursion") + ,(windowing_error,"windowing_error") + ,(collation_mismatch,"collation_mismatch") + ,(indeterminate_collation,"indeterminate_collation") + ,(with_check_option_violation,"with_check_option_violation") + ,(insufficient_resources,"insufficient_resources") + ,(disk_full,"disk_full") + ,(out_of_memory,"out_of_memory") + ,(too_many_connections,"too_many_connections") + ,(configuration_limit_exceeded,"configuration_limit_exceeded") + ,(program_limit_exceeded,"program_limit_exceeded") + ,(statement_too_complex,"statement_too_complex") + ,(too_many_columns,"too_many_columns") + ,(too_many_arguments,"too_many_arguments") + ,(object_not_in_prerequisite_state,"object_not_in_prerequisite_state") + ,(object_in_use,"object_in_use") + ,(cant_change_runtime_param,"cant_change_runtime_param") + ,(lock_not_available,"lock_not_available") + ,(unsafe_new_enum_value_usage,"unsafe_new_enum_value_usage") + ,(operator_intervention,"operator_intervention") + ,(query_canceled,"query_canceled") + ,(admin_shutdown,"admin_shutdown") + ,(crash_shutdown,"crash_shutdown") + ,(cannot_connect_now,"cannot_connect_now") + ,(database_dropped,"database_dropped") + ,(system_error,"system_error") + ,(io_error,"io_error") + ,(undefined_file,"undefined_file") + ,(duplicate_file,"duplicate_file") + ,(snapshot_too_old,"snapshot_too_old") + ,(config_file_error,"config_file_error") + ,(lock_file_exists,"lock_file_exists") + ,(fdw_error,"fdw_error") + ,(fdw_out_of_memory,"fdw_out_of_memory") + ,(fdw_dynamic_parameter_value_needed,"fdw_dynamic_parameter_value_needed") + ,(fdw_invalid_data_type,"fdw_invalid_data_type") + ,(fdw_column_name_not_found,"fdw_column_name_not_found") + ,(fdw_invalid_data_type_descriptors,"fdw_invalid_data_type_descriptors") + ,(fdw_invalid_column_name,"fdw_invalid_column_name") + ,(fdw_invalid_column_number,"fdw_invalid_column_number") + ,(fdw_invalid_use_of_null_pointer,"fdw_invalid_use_of_null_pointer") + ,(fdw_invalid_string_format,"fdw_invalid_string_format") + ,(fdw_invalid_handle,"fdw_invalid_handle") + ,(fdw_invalid_option_index,"fdw_invalid_option_index") + ,(fdw_invalid_option_name,"fdw_invalid_option_name") + ,(fdw_option_name_not_found,"fdw_option_name_not_found") + ,(fdw_reply_handle,"fdw_reply_handle") + ,(fdw_unable_to_create_execution,"fdw_unable_to_create_execution") + ,(fdw_unable_to_create_reply,"fdw_unable_to_create_reply") + ,(fdw_unable_to_establish_connection,"fdw_unable_to_establish_connection") + ,(fdw_no_schemas,"fdw_no_schemas") + ,(fdw_schema_not_found,"fdw_schema_not_found") + ,(fdw_table_not_found,"fdw_table_not_found") + ,(fdw_function_sequence_error,"fdw_function_sequence_error") + ,(fdw_too_many_handles,"fdw_too_many_handles") + ,(fdw_inconsistent_descriptor_information,"fdw_inconsistent_descriptor_information") + ,(fdw_invalid_attribute_value,"fdw_invalid_attribute_value") + ,(fdw_invalid_string_length_or_buffer_length,"fdw_invalid_string_length_or_buffer_length") + ,(fdw_invalid_descriptor_field_identifier,"fdw_invalid_descriptor_field_identifier") + ,(plpgsql_error,"plpgsql_error") + ,(raise_exception,"raise_exception") + ,(no_data_found,"no_data_found") + ,(too_many_rows,"too_many_rows") + ,(assert_failure,"assert_failure") + ,(internal_error,"internal_error") + ,(data_corrupted,"data_corrupted") + ,(index_corrupted,"index_corrupted")] diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs new file mode 100644 index 0000000..3e60fc7 --- /dev/null +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -0,0 +1,347 @@ +-- | +-- Module: Database.PostgreSQL.Typed.HDBC +-- Copyright: 2016 Dylan Simon +-- +-- Use postgresql-typed as a backend for HDBC. +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Database.PostgreSQL.Typed.HDBC + ( Connection + , connect + , fromPGConnection + , withPGConnection + , reloadTypes + , connectionFetchSize + , setFetchSize + ) where + +import Control.Arrow ((&&&)) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Exception (handle, throwIO) +import Control.Monad (void, guard) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef') +import Data.Int (Int16) +import qualified Data.IntMap.Lazy as IntMap +import Data.List (uncons) +import qualified Data.Map.Lazy as Map +import Data.Maybe (fromMaybe, isNothing) +import Data.Time.Clock (DiffTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.LocalTime (zonedTimeToUTC) +import Data.Word (Word32) +import qualified Database.HDBC.Types as HDBC +import qualified Database.HDBC.ColTypes as HDBC +import System.Mem.Weak (addFinalizer) +import Text.Read (readMaybe) + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.TypeCache +import Database.PostgreSQL.Typed.SQLToken +import Paths_postgresql_typed (version) + +-- |A wrapped 'PGConnection'. +-- This differs from a bare 'PGConnection' in a few ways: +-- +-- 1. It always has exactly one active transaction (with 'pgBegin') +-- 2. It automatically disconnects on GC +-- 3. It provides a mutex around the underlying 'PGConnection' for thread-safety +-- +data Connection = Connection + { connectionPG :: MVar PGConnection + , connectionServerVer :: String + , connectionTypes :: IntMap.IntMap SqlType + , connectionFetchSize :: Word32 -- ^Number of rows to fetch (and cache) with 'HDBC.execute' and each time 'HDBC.fetchRow' requires more rows. A higher value will result in fewer round-trips to the database but potentially more wasted data. Defaults to 1. 0 means fetch all rows. + } + +sqlError :: IO a -> IO a +sqlError = handle $ \(PGError m) -> + let f c = BSC.unpack $ Map.findWithDefault BSC.empty c m + fC = f 'C' + fD = f 'D' in + throwIO HDBC.SqlError + { HDBC.seState = fC + , HDBC.seNativeError = if null fC then -1 else fromMaybe 0 $ readMaybe (f 'P') + , HDBC.seErrorMsg = f 'S' ++ ": " ++ f 'M' ++ if null fD then fD else '\n':fD + } + +-- |Use the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. +withPGConnection :: Connection -> (PGConnection -> IO a) -> IO a +withPGConnection c = sqlError . withMVar (connectionPG c) + +takePGConnection :: PGConnection -> IO (MVar PGConnection) +takePGConnection pg = do + addFinalizer pg (pgDisconnectOnce pg) + pgBegin pg + newMVar pg + +-- |Convert an existing 'PGConnection' to an HDBC-compatible 'Connection'. +-- The caveats under 'connectionPG' apply if you plan to continue using the original 'PGConnection'. +fromPGConnection :: PGConnection -> IO Connection +fromPGConnection pg = do + pgv <- takePGConnection pg + reloadTypes Connection + { connectionPG = pgv + , connectionServerVer = maybe "" BSC.unpack $ pgServerVersion $ pgTypeEnv pg + , connectionTypes = mempty + , connectionFetchSize = 1 + } + +-- |Connect to a database for HDBC use (equivalent to 'pgConnect' and 'pgBegin'). +connect :: PGDatabase -> IO Connection +connect d = sqlError $ do + pg <- pgConnect d + fromPGConnection pg + +-- |Reload the table of all types from the database. +-- This may be needed if you make structural changes to the database. +reloadTypes :: Connection -> IO Connection +reloadTypes c = withPGConnection c $ \pg -> do + t <- pgGetTypes pg + return c{ connectionTypes = IntMap.map (sqlType (pgTypeEnv pg) . pgNameString) t } + +-- |Change the 'connectionFetchSize' for new 'HDBC.Statement's created with 'HDBC.prepare'. +-- Ideally this could be set with each call to 'HDBC.execute' and 'HDBC.fetchRow', but the HDBC interface provides no way to do this. +setFetchSize :: Word32 -> Connection -> Connection +setFetchSize i c = c{ connectionFetchSize = i } + +sqls :: String -> BSLC.ByteString +sqls = BSLC.pack + +placeholders :: Int -> [SQLToken] -> [SQLToken] +placeholders n (SQLQMark False : l) = SQLParam n : placeholders (succ n) l +placeholders n (SQLQMark True : l) = SQLQMark False : placeholders n l +placeholders n (t : l) = t : placeholders n l +placeholders _ [] = [] + +data ColDesc = ColDesc + { colDescName :: String + , colDesc :: HDBC.SqlColDesc + , colDescDecode :: PGValue -> HDBC.SqlValue + } + +data Cursor = Cursor + { cursorDesc :: [ColDesc] + , cursorRow :: [PGValues] + , cursorActive :: Bool + , _cursorStatement :: HDBC.Statement -- keep a handle to prevent GC + } + +noCursor :: HDBC.Statement -> Cursor +noCursor = Cursor [] [] False + +getType :: Connection -> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc +getType c pg nul PGColDescription{..} = ColDesc + { colDescName = BSC.unpack pgColName + , colDesc = HDBC.SqlColDesc + { HDBC.colType = sqlTypeId t + , HDBC.colSize = fromIntegral pgColModifier <$ guard (pgColModifier >= 0) + , HDBC.colOctetLength = fromIntegral pgColSize <$ guard (pgColSize >= 0) + , HDBC.colDecDigits = Nothing + , HDBC.colNullable = nul + } + , colDescDecode = sqlTypeDecode t + } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show pgColType) (fromIntegral pgColType) (connectionTypes c) + +instance HDBC.IConnection Connection where + disconnect c = withPGConnection c + pgDisconnectOnce + commit c = withPGConnection c $ \pg -> do + pgCommitAll pg + pgBegin pg + rollback c = withPGConnection c $ \pg -> do + pgRollbackAll pg + pgBegin pg + runRaw c q = withPGConnection c $ \pg -> + pgSimpleQueries_ pg $ sqls q + run c q v = withPGConnection c $ \pg -> do + let q' = sqls $ show $ placeholders 1 $ sqlTokens q + v' = map encode v + fromMaybe 0 <$> pgRun pg q' [] v' + prepare c q = do + let q' = sqls $ show $ placeholders 1 $ sqlTokens q + n <- withPGConnection c $ \pg -> pgPrepare pg q' [] + cr <- newIORef $ error "Cursor" + let + execute v = withPGConnection c $ \pg -> do + d <- pgBind pg n (map encode v) + (r, e) <- pgFetch pg n (connectionFetchSize c) + modifyIORef' cr $ \p -> p + { cursorDesc = map (getType c pg Nothing) d + , cursorRow = r + , cursorActive = isNothing e + } + return $ fromMaybe 0 e + stmt = HDBC.Statement + { HDBC.execute = execute + , HDBC.executeRaw = void $ execute [] + , HDBC.executeMany = mapM_ execute + , HDBC.finish = withPGConnection c $ \pg -> do + writeIORef cr $ noCursor stmt + pgClose pg n + , HDBC.fetchRow = withPGConnection c $ \pg -> do + p <- readIORef cr + fmap (zipWith colDescDecode (cursorDesc p)) <$> case cursorRow p of + [] | cursorActive p -> do + (rl, e) <- pgFetch pg n (connectionFetchSize c) + let rl' = uncons rl + writeIORef cr p + { cursorRow = maybe [] snd rl' + , cursorActive = isNothing e + } + return $ fst <$> rl' + | otherwise -> + return Nothing + (r:l) -> do + writeIORef cr p{ cursorRow = l } + return $ Just r + , HDBC.getColumnNames = + map colDescName . cursorDesc <$> readIORef cr + , HDBC.originalQuery = q + , HDBC.describeResult = + map (colDescName &&& colDesc) . cursorDesc <$> readIORef cr + } + writeIORef cr $ noCursor stmt + addFinalizer stmt $ withPGConnection c $ \pg -> pgClose pg n + return stmt + clone c = withPGConnection c $ \pg -> do + pg' <- pgConnect $ pgConnectionDatabase pg + pgv <- takePGConnection pg' + return c{ connectionPG = pgv } + hdbcDriverName _ = "postgresql-typed" + hdbcClientVer _ = show version + proxiedClientName = HDBC.hdbcDriverName + proxiedClientVer = HDBC.hdbcClientVer + dbServerVer = connectionServerVer + dbTransactionSupport _ = True + getTables c = withPGConnection c $ \pg -> + map (pgDecodeRep . head) . snd <$> pgSimpleQuery pg (BSLC.fromChunks + [ "SELECT relname" + , " FROM pg_catalog.pg_class" + , " JOIN pg_catalog.pg_namespace ON relnamespace = pg_namespace.oid" + , " WHERE nspname = ANY (current_schemas(false))" + , " AND relkind IN ('r','v','m','f')" + ]) + describeTable c t = withPGConnection c $ \pg -> + map (\[attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull] -> + colDescName &&& colDesc $ getType c pg (Just $ not $ pgDecodeRep attnotnull) PGColDescription + { pgColName = pgDecodeRep attname + , pgColTable = pgDecodeRep attrelid + , pgColNumber = pgDecodeRep attnum + , pgColType = pgDecodeRep atttypid + , pgColSize = pgDecodeRep attlen + , pgColModifier = pgDecodeRep atttypmod + , pgColBinary = False + }) + . snd <$> pgSimpleQuery pg (BSLC.fromChunks + [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull" + , " FROM pg_catalog.pg_attribute" + , " WHERE attrelid = ", pgLiteralRep t, "::regclass" + , " AND attnum > 0 AND NOT attisdropped" + , " ORDER BY attrelid, attnum" + ]) + +encodeRep :: PGRep a => a -> PGValue +encodeRep x = PGTextValue $ pgEncode (pgTypeOf x) x + +encode :: HDBC.SqlValue -> PGValue +encode (HDBC.SqlString x) = encodeRep x +encode (HDBC.SqlByteString x) = encodeRep x +encode (HDBC.SqlWord32 x) = encodeRep x +encode (HDBC.SqlWord64 x) = encodeRep (fromIntegral x :: Rational) +encode (HDBC.SqlInt32 x) = encodeRep x +encode (HDBC.SqlInt64 x) = encodeRep x +encode (HDBC.SqlInteger x) = encodeRep (fromInteger x :: Rational) +encode (HDBC.SqlChar x) = encodeRep x +encode (HDBC.SqlBool x) = encodeRep x +encode (HDBC.SqlDouble x) = encodeRep x +encode (HDBC.SqlRational x) = encodeRep x +encode (HDBC.SqlLocalDate x) = encodeRep x +encode (HDBC.SqlLocalTimeOfDay x) = encodeRep x +encode (HDBC.SqlZonedLocalTimeOfDay t z) = encodeRep (t, z) +encode (HDBC.SqlLocalTime x) = encodeRep x +encode (HDBC.SqlZonedTime x) = encodeRep (zonedTimeToUTC x) +encode (HDBC.SqlUTCTime x) = encodeRep x +encode (HDBC.SqlDiffTime x) = encodeRep (realToFrac x :: DiffTime) +encode (HDBC.SqlPOSIXTime x) = encodeRep (realToFrac x :: Rational) -- (posixSecondsToUTCTime x) +encode (HDBC.SqlEpochTime x) = encodeRep (posixSecondsToUTCTime (fromInteger x)) +encode (HDBC.SqlTimeDiff x) = encodeRep (fromIntegral x :: DiffTime) +encode HDBC.SqlNull = PGNullValue + +data SqlType = SqlType + { sqlTypeId :: HDBC.SqlTypeId + , sqlTypeDecode :: PGValue -> HDBC.SqlValue + } + +sqlType :: PGTypeEnv -> String -> SqlType +sqlType e t = SqlType + { sqlTypeId = typeId t + , sqlTypeDecode = decode t e + } + +typeId :: String -> HDBC.SqlTypeId +typeId "boolean" = HDBC.SqlBitT +typeId "bytea" = HDBC.SqlVarBinaryT +typeId "\"char\"" = HDBC.SqlCharT +typeId "name" = HDBC.SqlVarCharT +typeId "bigint" = HDBC.SqlBigIntT +typeId "smallint" = HDBC.SqlSmallIntT +typeId "integer" = HDBC.SqlIntegerT +typeId "text" = HDBC.SqlLongVarCharT +typeId "oid" = HDBC.SqlIntegerT +typeId "real" = HDBC.SqlFloatT +typeId "double precision" = HDBC.SqlDoubleT +typeId "abstime" = HDBC.SqlUTCDateTimeT +typeId "reltime" = HDBC.SqlIntervalT HDBC.SqlIntervalSecondT +typeId "tinterval" = HDBC.SqlIntervalT HDBC.SqlIntervalDayToSecondT +typeId "bpchar" = HDBC.SqlVarCharT +typeId "character varying" = HDBC.SqlVarCharT +typeId "date" = HDBC.SqlDateT +typeId "time without time zone" = HDBC.SqlTimeT +typeId "timestamp without time zone" = HDBC.SqlTimestampT +typeId "timestamp with time zone" = HDBC.SqlTimestampWithZoneT -- XXX really SQLUTCDateTimeT +typeId "interval" = HDBC.SqlIntervalT HDBC.SqlIntervalDayToSecondT +typeId "time with time zone" = HDBC.SqlTimeWithZoneT +typeId "numeric" = HDBC.SqlDecimalT +typeId "uuid" = HDBC.SqlGUIDT +typeId t = HDBC.SqlUnknownT t + +decodeRep :: PGColumn t a => PGTypeID t -> PGTypeEnv -> (a -> HDBC.SqlValue) -> PGValue -> HDBC.SqlValue +decodeRep t e f (PGBinaryValue v) = f $ pgDecodeBinary e t v +decodeRep t _ f (PGTextValue v) = f $ pgDecode t v +decodeRep _ _ _ PGNullValue = HDBC.SqlNull + +#define DECODE(T) \ + decode T e = decodeRep (PGTypeProxy :: PGTypeID T) e + +decode :: String -> PGTypeEnv -> PGValue -> HDBC.SqlValue +DECODE("boolean") HDBC.SqlBool +DECODE("\"char\"") HDBC.SqlChar +DECODE("name") HDBC.SqlString +DECODE("bigint") HDBC.SqlInt64 +DECODE("smallint") (HDBC.SqlInt32 . fromIntegral :: Int16 -> HDBC.SqlValue) +DECODE("integer") HDBC.SqlInt32 +DECODE("text") HDBC.SqlString +DECODE("oid") HDBC.SqlWord32 +DECODE("real") HDBC.SqlDouble +DECODE("double precision") HDBC.SqlDouble +DECODE("bpchar") HDBC.SqlString +DECODE("character varying") HDBC.SqlString +DECODE("date") HDBC.SqlLocalDate +DECODE("time without time zone") HDBC.SqlLocalTimeOfDay +DECODE("time with time zone") (uncurry HDBC.SqlZonedLocalTimeOfDay) +DECODE("timestamp without time zone") HDBC.SqlLocalTime +DECODE("timestamp with time zone") HDBC.SqlUTCTime +DECODE("interval") (HDBC.SqlDiffTime . realToFrac :: DiffTime -> HDBC.SqlValue) +DECODE("numeric") HDBC.SqlRational +decode _ _ = decodeRaw where + decodeRaw (PGBinaryValue v) = HDBC.SqlByteString v + decodeRaw (PGTextValue v) = HDBC.SqlByteString v + decodeRaw PGNullValue = HDBC.SqlNull diff --git a/Database/PostgreSQL/Typed/Inet.hs b/Database/PostgreSQL/Typed/Inet.hs new file mode 100644 index 0000000..30a2752 --- /dev/null +++ b/Database/PostgreSQL/Typed/Inet.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module: Database.PostgreSQL.Typed.Inet +-- Copyright: 2015 Dylan Simon +-- +-- Representaion of PostgreSQL's inet/cidr types using "Network.Socket". +-- We don't (yet) supply PGColumn (parsing) instances. + +module Database.PostgreSQL.Typed.Inet where + +import Control.Monad (void, guard, liftM2) +import qualified Data.ByteString.Char8 as BSC +import Data.Bits (shiftL, (.|.)) +import Data.Maybe (fromJust) +import Data.Word (Word8, Word16, Word32) +import Foreign.Marshal.Array (withArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek) +import qualified Network.Socket as Net +import Numeric (readDec, readHex) +import System.IO.Unsafe (unsafeDupablePerformIO) +import qualified Text.ParserCombinators.ReadP as RP +import qualified Text.ParserCombinators.ReadPrec as RP (lift) +import Text.Read (Read(readPrec)) + +import Database.PostgreSQL.Typed.Types + +data PGInet + = PGInet + { pgInetAddr :: !Net.HostAddress + , pgInetMask :: !Word8 + } + | PGInet6 + { pgInetAddr6 :: !Net.HostAddress6 + , pgInetMask :: !Word8 + } + deriving (Eq) + +sockAddrPGInet :: Net.SockAddr -> Maybe PGInet +sockAddrPGInet (Net.SockAddrInet _ a) = Just $ PGInet a 32 +sockAddrPGInet (Net.SockAddrInet6 _ _ a _) = Just $ PGInet6 a 128 +sockAddrPGInet _ = Nothing + +-- |Convert four bytes to network byte order, using unsafe casting. +-- 'Data.Word.byteSwap32' would be better, but I couldn't find a good way to determine host byte order. +bton32 :: (Word8, Word8, Word8, Word8) -> Word32 +bton32 (b1, b2, b3, b4) = unsafeDupablePerformIO $ + withArray [b1, b2, b3, b4] (peek . castPtr) + +instance Show PGInet where + -- This is how Network.Socket's Show SockAddr does it: + show (PGInet a 32) = fromJust $ fst $ unsafeDupablePerformIO $ + Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet 0 a) + show (PGInet a m) = show (PGInet a 32) ++ '/' : show m + show (PGInet6 a 128) = fromJust $ fst $ unsafeDupablePerformIO $ + Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet6 0 0 a 0) + show (PGInet6 a m) = show (PGInet6 a 128) ++ '/' : show m + +instance Read PGInet where + -- This is even less pleasant, but we only have to deal with representations pg generates + -- Not at all efficient, since in ReadP, but should get us by + readPrec = RP.lift $ r4 RP.+++ r6 where + r4i = do + o1 <- rdec + _ <- RP.char '.' + o2 <- rdec + _ <- RP.char '.' + o3 <- rdec + _ <- RP.char '.' + o4 <- rdec + return (o1, o2, o3, o4) + -- ipv4 + r4 = do + q <- r4i + m <- mask 32 + return $ PGInet (bton32 q) m + + -- trailing ipv4 in ipv6 + r64 = do + (b1, b2, b3, b4) <- r4i + return [jb b1 b2, jb b3 b4] + -- ipv6 pre-double-colon + r6l 0 = return [] + r6l 2 = colon >> r6lc 2 RP.+++ r64 + r6l n = colon >> r6lc n + r6lc n = r6lp n RP.+++ r6b n + r6lp n = r6w (r6l (pred n)) + -- ipv6 double-colon + r6b n = do + colon + r <- r6rp (pred n) RP.<++ return [] + let l = length r + return $ replicate (n - l) 0 ++ r + -- ipv6 post-double-colon + r6r 0 = return [] + r6r n = (colon >> r6rp n) RP.<++ return [] + r6rp n + | n >= 2 = r6rc n RP.+++ r64 + | otherwise = r6rc n + r6rc n = r6w (r6r (pred n)) + r6w = liftM2 (:) rhex + -- ipv6 + r6 = do + [w1, w2, w3, w4, w5, w6, w7, w8] <- r6lp 8 RP.<++ (colon >> r6b 8) + m <- mask 128 + return $ PGInet6 (jw w1 w2, jw w3 w4, jw w5 w6, jw w7 w8) m + + colon = void $ RP.char ':' + mask m = RP.option m $ do + _ <- RP.char '/' + n <- rdec + guard (n <= m) + return n + rdec :: RP.ReadP Word8 + rdec = RP.readS_to_P readDec + rhex :: RP.ReadP Word16 + rhex = RP.readS_to_P readHex + jw :: Word16 -> Word16 -> Word32 + jw x y = fromIntegral x `shiftL` 16 .|. fromIntegral y + jb :: Word8 -> Word8 -> Word16 + jb x y = fromIntegral x `shiftL` 8 .|. fromIntegral y + +instance PGType "inet" where + type PGVal "inet" = PGInet +instance PGType "cidr" where + type PGVal "cidr" = PGInet +instance PGParameter "inet" PGInet where + pgEncode _ = BSC.pack . show +instance PGParameter "cidr" PGInet where + pgEncode _ = BSC.pack . show +instance PGColumn "inet" PGInet where + pgDecode _ = read . BSC.unpack +instance PGColumn "cidr" PGInet where + pgDecode _ = read . BSC.unpack diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs new file mode 100644 index 0000000..5e548e6 --- /dev/null +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -0,0 +1,1180 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +-- Copyright 2010, 2011, 2012, 2013 Chris Forno +-- Copyright 2014-2018 Dylan Simon + +-- |The Protocol module allows for direct, low-level communication with a +-- PostgreSQL server over TCP/IP. You probably don't want to use this module +-- directly. + +module Database.PostgreSQL.Typed.Protocol ( + PGDatabase(..) + , defaultPGDatabase + , PGConnection + , PGError(..) +#ifdef VERSION_tls + , PGTlsMode(..) + , PGTlsValidateMode (..) +#endif + , pgErrorCode + , pgConnectionDatabase + , pgTypeEnv + , pgConnect + , pgDisconnect + , pgReconnect + -- * Query operations + , pgDescribe + , pgSimpleQuery + , pgSimpleQueries_ + , pgPreparedQuery + , pgPreparedLazyQuery + , pgCloseStatement + -- * Transactions + , pgBegin + , pgCommit + , pgRollback + , pgCommitAll + , pgRollbackAll + , pgTransaction + -- * HDBC support + , pgDisconnectOnce + , pgRun + , PGPreparedStatement + , pgPrepare + , pgClose + , PGColDescription(..) + , PGRowDescription + , pgBind + , pgFetch + -- * Notifications + , PGNotification(..) + , pgGetNotification + , pgGetNotifications +#ifdef VERSION_tls + -- * TLS Helpers + , pgTlsValidate +#endif + , pgSupportsTls + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<$)) +#endif +import Control.Arrow ((&&&), first, second) +import Control.Exception (Exception, onException, finally, throwIO) +#ifdef VERSION_tls +import Control.Exception (catch) +#endif +import Control.Monad (void, liftM2, replicateM, when, unless) +#if defined(VERSION_cryptonite) || defined(VERSION_crypton) +import qualified Crypto.Hash as Hash +import qualified Data.ByteArray.Encoding as BA +#endif +import qualified Data.Binary.Get as G +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal (w2c, createAndTrim) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteString.Lazy.Internal (smallChunkSize) +#ifdef VERSION_tls +import Data.Default (def) +#endif +import qualified Data.Foldable as Fold +import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef') +import Data.Int (Int32, Int16) +import qualified Data.Map.Lazy as Map +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty) +#endif +import Data.Time.Clock (getCurrentTime) +import Data.Tuple (swap) +import Data.Typeable (Typeable) +#if !MIN_VERSION_base(4,8,0) +import Data.Word (Word) +#endif +import Data.Word (Word32, Word8) +#ifdef VERSION_tls +import Data.X509 (SignedCertificate, HashALG(HashSHA256)) +import Data.X509.Memory (readSignedObjectFromMemory) +import Data.X509.CertificateStore (makeCertificateStore) +import qualified Data.X509.Validation +#endif +#ifndef mingw32_HOST_OS +import Foreign.C.Error (eWOULDBLOCK, getErrno, errnoToIOError) +import Foreign.C.Types (CChar(..), CInt(..), CSize(..)) +import Foreign.Ptr (Ptr, castPtr) +import GHC.IO.Exception (IOErrorType(InvalidArgument)) +#endif +import qualified Network.Socket as Net +import qualified Network.Socket.ByteString as NetBS +import qualified Network.Socket.ByteString.Lazy as NetBSL +#ifdef VERSION_tls +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS +#endif +import System.IO (stderr, hPutStrLn) +import System.IO.Error (IOError, mkIOError, eofErrorType, ioError, ioeSetErrorString) +import System.IO.Unsafe (unsafeInterleaveIO) +import Text.Read (readMaybe) +import Text.Show.Functions () + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic + +data PGState + = StateUnsync -- no Sync + | StatePending -- expecting ReadyForQuery + -- ReadyForQuery received: + | StateIdle + | StateTransaction + | StateTransactionFailed + -- Terminate sent or EOF received + | StateClosed + deriving (Show, Eq) + +#ifdef VERSION_tls +data PGTlsValidateMode + = TlsValidateFull + -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQHN against the + -- certicate's CN + | TlsValidateCA + -- ^ Equivalent to sslmode=verify-ca. Ie: Only check that the certificate has + -- been signed by the root certificate we provide + deriving (Show, Eq) + +data PGTlsMode + = TlsDisabled + -- ^ TLS is disabled + | TlsNoValidate + | TlsValidate PGTlsValidateMode SignedCertificate + deriving (Eq, Show) + +-- | Constructs a 'PGTlsMode' to validate the server certificate with given root +-- certificate (in PEM format) +pgTlsValidate :: PGTlsValidateMode -> BSC.ByteString -> Either String PGTlsMode +pgTlsValidate mode certPem = + case readSignedObjectFromMemory certPem of + [] -> Left "Could not parse any certificate in PEM" + (x:_) -> Right (TlsValidate mode x) + +pgSupportsTls :: PGConnection -> Bool +pgSupportsTls PGConnection{connHandle=PGTlsContext _} = True +pgSupportsTls _ = False +#else +pgSupportsTls :: PGConnection -> Bool +pgSupportsTls _ = False +#endif + +-- |Information for how to connect to a database, to be passed to 'pgConnect'. +data PGDatabase = PGDatabase + { pgDBAddr :: Either (Net.HostName, Net.ServiceName) Net.SockAddr -- ^ The address to connect to the server + , pgDBName :: BS.ByteString -- ^ The name of the database + , pgDBUser, pgDBPass :: BS.ByteString + , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) + , pgDBDebug :: Bool -- ^ Log all low-level server messages + , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) +#ifdef VERSION_tls + , pgDBTLS :: PGTlsMode -- ^ TLS mode + , pgDBTLSParams :: Maybe TLS.ClientParams -- ^ TLS client params +#endif + } deriving (Show) + +instance Eq PGDatabase where +#ifdef VERSION_tls + PGDatabase a1 n1 u1 p1 l1 _ _ s1 _ == PGDatabase a2 n2 u2 p2 l2 _ _ s2 _ = + a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 == s2 +#else + PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ = + a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 +#endif + +newtype PGPreparedStatement = PGPreparedStatement Integer + deriving (Eq, Show) + +preparedStatementName :: PGPreparedStatement -> BS.ByteString +preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n + +data PGHandle + = PGSocket Net.Socket +#ifdef VERSION_tls + | PGTlsContext TLS.Context +#endif + +pgPutBuilder :: PGHandle -> B.Builder -> IO () +pgPutBuilder (PGSocket s) b = NetBSL.sendAll s (B.toLazyByteString b) +#ifdef VERSION_tls +pgPutBuilder (PGTlsContext c) b = TLS.sendData c (B.toLazyByteString b) +#endif + +pgPut:: PGHandle -> BS.ByteString -> IO () +pgPut (PGSocket s) bs = NetBS.sendAll s bs +#ifdef VERSION_tls +pgPut (PGTlsContext c) bs = TLS.sendData c (BSL.fromChunks [bs]) +#endif + +pgGetSome :: PGHandle -> Int -> IO BSC.ByteString +pgGetSome (PGSocket s) count = NetBS.recv s count +#ifdef VERSION_tls +pgGetSome (PGTlsContext c) _ = TLS.recvData c +#endif + +pgCloseHandle :: PGHandle -> IO () +pgCloseHandle (PGSocket s) = Net.close s +#ifdef VERSION_tls +pgCloseHandle (PGTlsContext c) = do + TLS.bye c `catch` \(_ :: IOError) -> pure () + TLS.contextClose c +#endif + +pgFlush :: PGConnection -> IO () +pgFlush PGConnection{connHandle=PGSocket _} = pure () +#ifdef VERSION_tls +pgFlush PGConnection{connHandle=PGTlsContext c} = TLS.contextFlush c +#endif + +-- |An established connection to the PostgreSQL server. +-- These objects are not thread-safe and must only be used for a single request at a time. +data PGConnection = PGConnection + { connHandle :: PGHandle + , connDatabase :: !PGDatabase + , connPid :: !Word32 -- unused + , connKey :: !Word32 -- unused + , connTypeEnv :: PGTypeEnv + , connParameters :: IORef (Map.Map BS.ByteString BS.ByteString) + , connPreparedStatementCount :: IORef Integer + , connPreparedStatementMap :: IORef (Map.Map (BS.ByteString, [OID]) PGPreparedStatement) + , connState :: IORef PGState + , connInput :: IORef (G.Decoder PGBackendMessage) + , connTransaction :: IORef Word + , connNotifications :: IORef (Queue PGNotification) + } + +data PGColDescription = PGColDescription + { pgColName :: BS.ByteString + , pgColTable :: !OID + , pgColNumber :: !Int16 + , pgColType :: !OID + , pgColSize :: !Int16 + , pgColModifier :: !Int32 + , pgColBinary :: !Bool + } deriving (Show) +type PGRowDescription = [PGColDescription] + +type MessageFields = Map.Map Char BS.ByteString + +data PGNotification = PGNotification + { pgNotificationPid :: !Word32 + , pgNotificationChannel :: !BS.ByteString + , pgNotificationPayload :: BSL.ByteString + } deriving (Show) + +-- |Simple amortized fifo +data Queue a = Queue [a] [a] + +emptyQueue :: Queue a +emptyQueue = Queue [] [] + +enQueue :: a -> Queue a -> Queue a +enQueue a (Queue e d) = Queue (a:e) d + +deQueue :: Queue a -> (Queue a, Maybe a) +deQueue (Queue e (x:d)) = (Queue e d, Just x) +deQueue (Queue (reverse -> x:d) []) = (Queue [] d, Just x) +deQueue q = (q, Nothing) + +-- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. +-- See . +data PGFrontendMessage + = StartupMessage [(BS.ByteString, BS.ByteString)] -- only sent first + | CancelRequest !Word32 !Word32 -- sent first on separate connection + | Bind { portalName :: BS.ByteString, statementName :: BS.ByteString, bindParameters :: PGValues, binaryColumns :: [Bool] } + | CloseStatement { statementName :: BS.ByteString } + | ClosePortal { portalName :: BS.ByteString } + -- |Describe a SQL query/statement. The SQL string can contain + -- parameters ($1, $2, etc.). + | DescribeStatement { statementName :: BS.ByteString } + | DescribePortal { portalName :: BS.ByteString } + | Execute { portalName :: BS.ByteString, executeRows :: !Word32 } + | Flush + -- |Parse SQL Destination (prepared statement) + | Parse { statementName :: BS.ByteString, queryString :: BSL.ByteString, parseTypes :: [OID] } + | PasswordMessage BS.ByteString + -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, + -- etc.) aren't allowed. + | SimpleQuery { queryString :: BSL.ByteString } + | Sync + | Terminate + deriving (Show) + +-- |PGBackendMessage represents a PostgreSQL protocol message that we'll receive. +-- See . +data PGBackendMessage + = AuthenticationOk + | AuthenticationCleartextPassword + | AuthenticationMD5Password BS.ByteString + -- AuthenticationSCMCredential + | BackendKeyData Word32 Word32 + | BindComplete + | CloseComplete + | CommandComplete BS.ByteString + -- |Each DataRow (result of a query) is a list of 'PGValue', which are assumed to be text unless known to be otherwise. + | DataRow PGValues + | EmptyQueryResponse + -- |An ErrorResponse contains the severity, "SQLSTATE", and + -- message of an error. See + -- . + | ErrorResponse { messageFields :: MessageFields } + | NoData + | NoticeResponse { messageFields :: MessageFields } + | NotificationResponse PGNotification + -- |A ParameterDescription describes the type of a given SQL + -- query/statement parameter ($1, $2, etc.). Unfortunately, + -- PostgreSQL does not give us nullability information for the + -- parameter. + | ParameterDescription [OID] + | ParameterStatus BS.ByteString BS.ByteString + | ParseComplete + | PortalSuspended + | ReadyForQuery PGState + -- |A RowDescription contains the name, type, table OID, and + -- column number of the resulting columns(s) of a query. The + -- column number is useful for inferring nullability. + | RowDescription PGRowDescription + deriving (Show) + +-- |PGException is thrown upon encountering an 'ErrorResponse' with severity of +-- ERROR, FATAL, or PANIC. It holds the message of the error. +newtype PGError = PGError { pgErrorFields :: MessageFields } + deriving (Typeable) + +instance Show PGError where + show (PGError m) = displayMessage m + +instance Exception PGError + +-- |Produce a human-readable string representing the message +displayMessage :: MessageFields -> String +displayMessage m = "PG" ++ f 'S' ++ (if null fC then ": " else " [" ++ fC ++ "]: ") ++ f 'M' ++ (if null fD then fD else '\n' : fD) + where + fC = f 'C' + fD = f 'D' + f c = BSC.unpack $ Map.findWithDefault BS.empty c m + +makeMessage :: BS.ByteString -> BS.ByteString -> MessageFields +makeMessage m d = Map.fromAscList [('D', d), ('M', m)] + +-- |Message SQLState code. +-- See . +pgErrorCode :: PGError -> BS.ByteString +pgErrorCode (PGError e) = Map.findWithDefault BS.empty 'C' e + +defaultLogMessage :: MessageFields -> IO () +defaultLogMessage = hPutStrLn stderr . displayMessage + +-- |A database connection with sane defaults: +-- localhost:5432:postgres +defaultPGDatabase :: PGDatabase +defaultPGDatabase = PGDatabase + { pgDBAddr = Right $ Net.SockAddrInet 5432 (Net.tupleToHostAddress (127,0,0,1)) + , pgDBName = "postgres" + , pgDBUser = "postgres" + , pgDBPass = BS.empty + , pgDBParams = [] + , pgDBDebug = False + , pgDBLogMessage = defaultLogMessage +#ifdef VERSION_tls + , pgDBTLS = TlsDisabled + , pgDBTLSParams = Nothing +#endif + } + +connDebugMsg :: PGConnection -> String -> IO () +connDebugMsg c msg = when (pgDBDebug $ connDatabase c) $ do + t <- getCurrentTime + hPutStrLn stderr $ show t ++ msg + +connLogMessage :: PGConnection -> MessageFields -> IO () +connLogMessage = pgDBLogMessage . connDatabase + +-- |The database information for this connection. +pgConnectionDatabase :: PGConnection -> PGDatabase +pgConnectionDatabase = connDatabase + +-- |The type environment for this connection. +pgTypeEnv :: PGConnection -> PGTypeEnv +pgTypeEnv = connTypeEnv + +#if defined(VERSION_cryptonite) || defined(VERSION_crypton) +md5 :: BS.ByteString -> BS.ByteString +md5 = BA.convertToBase BA.Base16 . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) +#endif + + +nul :: B.Builder +nul = B.word8 0 + +byteStringNul :: BS.ByteString -> B.Builder +byteStringNul s = B.byteString s <> nul + +lazyByteStringNul :: BSL.ByteString -> B.Builder +lazyByteStringNul s = B.lazyByteString s <> nul + +-- |Given a message, determine the (optional) type ID and the body +messageBody :: PGFrontendMessage -> (Maybe Char, B.Builder) +messageBody (StartupMessage kv) = (Nothing, B.word32BE 0x30000 + <> Fold.foldMap (\(k, v) -> byteStringNul k <> byteStringNul v) kv <> nul) +messageBody (CancelRequest pid key) = (Nothing, B.word32BE 80877102 + <> B.word32BE pid <> B.word32BE key) +messageBody Bind{ portalName = d, statementName = n, bindParameters = p, binaryColumns = bc } = (Just 'B', + byteStringNul d + <> byteStringNul n + <> (if any fmt p + then B.word16BE (fromIntegral $ length p) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum . fmt) p + else B.word16BE 0) + <> B.word16BE (fromIntegral $ length p) <> Fold.foldMap val p + <> (if or bc + then B.word16BE (fromIntegral $ length bc) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum) bc + else B.word16BE 0)) + where + fmt (PGBinaryValue _) = True + fmt _ = False + val PGNullValue = B.int32BE (-1) + val (PGTextValue v) = B.word32BE (fromIntegral $ BS.length v) <> B.byteString v + val (PGBinaryValue v) = B.word32BE (fromIntegral $ BS.length v) <> B.byteString v +messageBody CloseStatement{ statementName = n } = (Just 'C', + B.char7 'S' <> byteStringNul n) +messageBody ClosePortal{ portalName = n } = (Just 'C', + B.char7 'P' <> byteStringNul n) +messageBody DescribeStatement{ statementName = n } = (Just 'D', + B.char7 'S' <> byteStringNul n) +messageBody DescribePortal{ portalName = n } = (Just 'D', + B.char7 'P' <> byteStringNul n) +messageBody Execute{ portalName = n, executeRows = r } = (Just 'E', + byteStringNul n <> B.word32BE r) +messageBody Flush = (Just 'H', mempty) +messageBody Parse{ statementName = n, queryString = s, parseTypes = t } = (Just 'P', + byteStringNul n <> lazyByteStringNul s + <> B.word16BE (fromIntegral $ length t) <> Fold.foldMap B.word32BE t) +messageBody (PasswordMessage s) = (Just 'p', + B.byteString s <> nul) +messageBody SimpleQuery{ queryString = s } = (Just 'Q', + lazyByteStringNul s) +messageBody Sync = (Just 'S', mempty) +messageBody Terminate = (Just 'X', mempty) + +-- |Send a message to PostgreSQL (low-level). +pgSend :: PGConnection -> PGFrontendMessage -> IO () +pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do + modifyIORef' sr $ state msg + connDebugMsg c $ "> " ++ show msg + pgPutBuilder h $ Fold.foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + BS.length b) + pgPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length + where + (t, b) = second (BSL.toStrict . B.toLazyByteString) $ messageBody msg + state _ StateClosed = StateClosed + state Sync _ = StatePending + state SimpleQuery{} _ = StatePending + state Terminate _ = StateClosed + state _ _ = StateUnsync + + +getByteStringNul :: G.Get BS.ByteString +getByteStringNul = fmap BSL.toStrict G.getLazyByteStringNul + +getMessageFields :: G.Get MessageFields +getMessageFields = g . w2c =<< G.getWord8 where + g '\0' = return Map.empty + g f = liftM2 (Map.insert f) getByteStringNul getMessageFields + +-- |Parse an incoming message. +getMessageBody :: Char -> G.Get PGBackendMessage +getMessageBody 'R' = auth =<< G.getWord32be where + auth 0 = return AuthenticationOk + auth 3 = return AuthenticationCleartextPassword + auth 5 = AuthenticationMD5Password <$> G.getByteString 4 + auth op = fail $ "pgGetMessage: unsupported authentication type: " ++ show op +getMessageBody 't' = do + numParams <- G.getWord16be + ParameterDescription <$> replicateM (fromIntegral numParams) G.getWord32be +getMessageBody 'T' = do + numFields <- G.getWord16be + RowDescription <$> replicateM (fromIntegral numFields) getField where + getField = do + name <- getByteStringNul + oid <- G.getWord32be -- table OID + col <- G.getWord16be -- column number + typ' <- G.getWord32be -- type + siz <- G.getWord16be -- type size + tmod <- G.getWord32be -- type modifier + fmt <- G.getWord16be -- format code + return $ PGColDescription + { pgColName = name + , pgColTable = oid + , pgColNumber = fromIntegral col + , pgColType = typ' + , pgColSize = fromIntegral siz + , pgColModifier = fromIntegral tmod + , pgColBinary = toEnum (fromIntegral fmt) + } +getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where + rs 'I' = return StateIdle + rs 'T' = return StateTransaction + rs 'E' = return StateTransactionFailed + rs s = fail $ "pgGetMessage: unknown ready state: " ++ show s +getMessageBody '1' = return ParseComplete +getMessageBody '2' = return BindComplete +getMessageBody '3' = return CloseComplete +getMessageBody 'C' = CommandComplete <$> getByteStringNul +getMessageBody 'S' = liftM2 ParameterStatus getByteStringNul getByteStringNul +getMessageBody 'D' = do + numFields <- G.getWord16be + DataRow <$> replicateM (fromIntegral numFields) (getField =<< G.getWord32be) where + getField 0xFFFFFFFF = return PGNullValue + getField len = PGTextValue <$> G.getByteString (fromIntegral len) + -- could be binary, too, but we don't know here, so have to choose one +getMessageBody 'K' = liftM2 BackendKeyData G.getWord32be G.getWord32be +getMessageBody 'E' = ErrorResponse <$> getMessageFields +getMessageBody 'I' = return EmptyQueryResponse +getMessageBody 'n' = return NoData +getMessageBody 's' = return PortalSuspended +getMessageBody 'N' = NoticeResponse <$> getMessageFields +getMessageBody 'A' = NotificationResponse <$> do + PGNotification + <$> G.getWord32be + <*> getByteStringNul + <*> G.getLazyByteStringNul +getMessageBody t = fail $ "pgGetMessage: unknown message type: " ++ show t + +getMessage :: G.Decoder PGBackendMessage +getMessage = G.runGetIncremental $ do + typ <- G.getWord8 + len <- G.getWord32be + G.isolate (fromIntegral len - 4) $ getMessageBody (w2c typ) + +class Show m => RecvMsg m where + -- |Read from connection, returning immediate value or non-empty data + recvMsgData :: PGConnection -> IO (Either m BS.ByteString) + recvMsgData c = do + r <- pgGetSome (connHandle c) smallChunkSize + if BS.null r + then do + writeIORef (connState c) StateClosed + pgCloseHandle (connHandle c) + -- Should this instead be a special PGError? + ioError $ mkIOError eofErrorType "PGConnection" Nothing Nothing + else + return (Right r) + -- |Expected ReadyForQuery message + recvMsgSync :: Maybe m + recvMsgSync = Nothing + -- |NotificationResponse message + recvMsgNotif :: PGConnection -> PGNotification -> IO (Maybe m) + recvMsgNotif c n = Nothing <$ + modifyIORef' (connNotifications c) (enQueue n) + -- |ErrorResponse message + recvMsgErr :: PGConnection -> MessageFields -> IO (Maybe m) + recvMsgErr c m = Nothing <$ + connLogMessage c m + -- |Any other unhandled message + recvMsg :: PGConnection -> PGBackendMessage -> IO (Maybe m) + recvMsg c m = Nothing <$ + connLogMessage c (makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query") + +-- |Process all pending messages +data RecvNonBlock = RecvNonBlock deriving (Show) +instance RecvMsg RecvNonBlock where +#ifndef mingw32_HOST_OS + recvMsgData PGConnection{connHandle=PGSocket s} = do + r <- recvNonBlock s smallChunkSize + if BS.null r + then return (Left RecvNonBlock) + else return (Right r) +#else + recvMsgData PGConnection{connHandle=PGSocket _} = + throwIO (userError "Non-blocking recvMsgData is not supported on mingw32 ATM") +#endif +#ifdef VERSION_tls + recvMsgData PGConnection{connHandle=PGTlsContext _} = + throwIO (userError "Non-blocking recvMsgData is not supported on TLS connections") +#endif + +-- |Wait for ReadyForQuery +data RecvSync = RecvSync deriving (Show) +instance RecvMsg RecvSync where + recvMsgSync = Just RecvSync + +-- |Wait for NotificationResponse +instance RecvMsg PGNotification where + recvMsgNotif _ = return . Just + +-- |Return any message (throwing errors) +instance RecvMsg PGBackendMessage where + recvMsgErr _ = throwIO . PGError + recvMsg _ = return . Just + +-- |Return any message or ReadyForQuery +instance RecvMsg (Either PGBackendMessage RecvSync) where + recvMsgSync = Just $ Right RecvSync + recvMsgErr _ = throwIO . PGError + recvMsg _ = return . Just . Left + +-- |Receive the next message from PostgreSQL (low-level). +pgRecv :: RecvMsg m => PGConnection -> IO m +pgRecv c@PGConnection{ connInput = dr, connState = sr } = + rcv =<< readIORef dr where + next = writeIORef dr + new = G.pushChunk getMessage + + -- read and parse + rcv (G.Done b _ m) = do + connDebugMsg c $ "< " ++ show m + got (new b) m + rcv (G.Fail _ _ r) = next (new BS.empty) >> fail r -- not clear how can recover + rcv d@(G.Partial r) = recvMsgData c `onException` next d >>= + either (<$ next d) (rcv . r . Just) + + -- process message + msg (ParameterStatus k v) = Nothing <$ + modifyIORef' (connParameters c) (Map.insert k v) + msg (NoticeResponse m) = Nothing <$ + connLogMessage c m + msg (ErrorResponse m) = + recvMsgErr c m + msg m@(ReadyForQuery s) = do + s' <- atomicModifyIORef' sr (s, ) + if s' == StatePending + then return recvMsgSync -- expected + else recvMsg c m -- unexpected + msg (NotificationResponse n) = + recvMsgNotif c n + msg m@AuthenticationOk = do + writeIORef sr StatePending + recvMsg c m + msg m = recvMsg c m + got d m = msg m `onException` next d >>= + maybe (rcv d) (<$ next d) + +-- |Connect to a PostgreSQL server. +pgConnect :: PGDatabase -> IO PGConnection +pgConnect db = do + param <- newIORef Map.empty + state <- newIORef StateUnsync + prepc <- newIORef 0 + prepm <- newIORef Map.empty + input <- newIORef getMessage + tr <- newIORef 0 + notif <- newIORef emptyQueue + addr <- either + (\(h,p) -> head <$> Net.getAddrInfo (Just defai) (Just h) (Just p)) + (\a -> return defai{ Net.addrAddress = a, Net.addrFamily = case a of + Net.SockAddrInet{} -> Net.AF_INET + Net.SockAddrInet6{} -> Net.AF_INET6 + Net.SockAddrUnix{} -> Net.AF_UNIX + _ -> Net.AF_UNSPEC }) + $ pgDBAddr db + sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) + unless (Net.addrFamily addr == Net.AF_UNIX) $ Net.setSocketOption sock Net.NoDelay 1 + Net.connect sock $ Net.addrAddress addr + pgHandle <- mkPGHandle db sock + let c = PGConnection + { connHandle = pgHandle + , connDatabase = db + , connPid = 0 + , connKey = 0 + , connParameters = param + , connPreparedStatementCount = prepc + , connPreparedStatementMap = prepm + , connState = state + , connTypeEnv = unknownPGTypeEnv + , connInput = input + , connTransaction = tr + , connNotifications = notif + } + pgSend c $ StartupMessage $ + [ ("user", pgDBUser db) + , ("database", pgDBName db) + , ("client_encoding", "UTF8") + , ("standard_conforming_strings", "on") + , ("bytea_output", "hex") + , ("DateStyle", "ISO, YMD") + , ("IntervalStyle", "iso_8601") + , ("extra_float_digits", "3") + ] ++ pgDBParams db + pgFlush c + conn c + where + defai = Net.defaultHints{ Net.addrSocketType = Net.Stream } + conn c = pgRecv c >>= msg c + msg c (Right RecvSync) = do + cp <- readIORef (connParameters c) + return c + { connTypeEnv = PGTypeEnv + { pgIntegerDatetimes = fmap ("on" ==) $ Map.lookup "integer_datetimes" cp + , pgServerVersion = Map.lookup "server_version" cp + } + } + msg c (Left (BackendKeyData p k)) = conn c{ connPid = p, connKey = k } + msg c (Left AuthenticationOk) = conn c + msg c (Left AuthenticationCleartextPassword) = do + pgSend c $ PasswordMessage $ pgDBPass db + pgFlush c + conn c +#if defined(VERSION_cryptonite) || defined(VERSION_crypton) + msg c (Left (AuthenticationMD5Password salt)) = do + pgSend c $ PasswordMessage $ "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) + pgFlush c + conn c +#endif + msg _ (Left m) = fail $ "pgConnect: unexpected response: " ++ show m + +mkPGHandle :: PGDatabase -> Net.Socket -> IO PGHandle +#ifdef VERSION_tls +mkPGHandle db sock = + case pgDBTLS db of + TlsDisabled -> pure (PGSocket sock) + TlsNoValidate -> mkTlsContext + TlsValidate _ _ -> mkTlsContext + where + mkTlsContext = do + NetBSL.sendAll sock sslRequest + resp <- NetBS.recv sock 1 + case resp of + "S" -> do + ctx <- TLS.contextNew sock params + void $ TLS.handshake ctx + pure $ PGTlsContext ctx + "N" -> throwIO (userError "Server does not support TLS") + _ -> throwIO (userError "Unexpected response from server when issuing SSLRequest") + params = + case pgDBTLSParams db of + Nothing -> (TLS.defaultParamsClient tlsHost tlsPort) + { TLS.clientSupported = + def + { TLS.supportedCiphers = TLS.ciphersuite_strong +#if MIN_VERSION_tls(2,0,0) + , TLS.supportedExtendedMainSecret = TLS.AllowEMS +#endif + } + , TLS.clientShared = clientShared + , TLS.clientHooks = clientHooks + } + Just userParams -> userParams { TLS.clientShared = clientShared, TLS.clientHooks = clientHooks } + tlsHost = case pgDBAddr db of + Left (h,_) -> h + Right (Net.SockAddrUnix s) -> s + Right _ -> "some-socket" + tlsPort = case pgDBAddr db of + Left (_,p) -> BSC.pack p + Right _ -> "socket" + clientShared = + case pgDBTLS db of + TlsDisabled -> def { TLS.sharedValidationCache = noValidate } + TlsNoValidate -> def { TLS.sharedValidationCache = noValidate } + TlsValidate _ sc -> def { TLS.sharedCAStore = makeCertificateStore [sc] } + clientHooks = + case pgDBTLS db of + TlsValidate TlsValidateCA _ -> def { TLS.onServerCertificate = validateNoCheckFQHN } + _ -> def + validateNoCheckFQHN = Data.X509.Validation.validate HashSHA256 def (def { TLS.checkFQHN = False }) + + noValidate = TLS.ValidationCache + (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + sslRequest = B.toLazyByteString (B.word32BE 8 <> B.word32BE 80877103) +#else +mkPGHandle _ sock = pure (PGSocket sock) +#endif + +-- |Disconnect cleanly from the PostgreSQL server. +pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' + -> IO () +pgDisconnect c@PGConnection{ connHandle = h } = + pgSend c Terminate `finally` pgCloseHandle h + +-- |Disconnect cleanly from the PostgreSQL server, but only if it's still connected. +pgDisconnectOnce :: PGConnection -- ^ a handle from 'pgConnect' + -> IO () +pgDisconnectOnce c@PGConnection{ connState = cs } = do + s <- readIORef cs + unless (s == StateClosed) $ + pgDisconnect c + +-- |Possibly re-open a connection to a different database, either reusing the connection if the given database is already connected or closing it and opening a new one. +-- Regardless, the input connection must not be used afterwards. +pgReconnect :: PGConnection -> PGDatabase -> IO PGConnection +pgReconnect c@PGConnection{ connDatabase = cd, connState = cs } d = do + s <- readIORef cs + if cd == d && s /= StateClosed + then return c{ connDatabase = d } + else do + pgDisconnectOnce c + pgConnect d + +pgSync :: PGConnection -> IO () +pgSync c@PGConnection{ connState = sr } = do + s <- readIORef sr + case s of + StateClosed -> fail "pgSync: operation on closed connection" + StatePending -> wait + StateUnsync -> do + pgSend c Sync + pgFlush c + wait + _ -> return () + where + wait = do + RecvSync <- pgRecv c + return () + +rowDescription :: PGBackendMessage -> PGRowDescription +rowDescription (RowDescription d) = d +rowDescription NoData = [] +rowDescription m = error $ "describe: unexpected response: " ++ show m + +-- |Describe a SQL statement/query. A statement description consists of 0 or +-- more parameter descriptions (a PostgreSQL type) and zero or more result +-- field descriptions (for queries) (consist of the name of the field, the +-- type of the field, and a nullability indicator). +pgDescribe :: PGConnection -> BSL.ByteString -- ^ SQL string + -> [OID] -- ^ Optional type specifications + -> Bool -- ^ Guess nullability, otherwise assume everything is + -> IO ([OID], [(BS.ByteString, OID, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. +pgDescribe h sql types nulls = do + pgSync h + pgSend h Parse{ queryString = sql, statementName = BS.empty, parseTypes = types } + pgSend h DescribeStatement{ statementName = BS.empty } + pgSend h Sync + pgFlush h + ParseComplete <- pgRecv h + ParameterDescription ps <- pgRecv h + (,) ps <$> (mapM desc . rowDescription =<< pgRecv h) + where + desc (PGColDescription{ pgColName = name, pgColTable = tab, pgColNumber = col, pgColType = typ }) = do + n <- nullable tab col + return (name, typ, n) + -- We don't get nullability indication from PostgreSQL, at least not directly. + -- Without any hints, we have to assume that the result can be null and + -- leave it up to the developer to figure it out. + nullable oid col + | nulls && oid /= 0 = do + -- In cases where the resulting field is tracable to the column of a + -- table, we can check there. + (_, r) <- pgPreparedQuery h "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] + case r of + [[s]] -> return $ not $ pgDecodeRep s + [] -> return True + _ -> fail $ "Failed to determine nullability of column #" ++ show col + | otherwise = return True + +rowsAffected :: (Integral i, Read i) => BS.ByteString -> i +rowsAffected = ra . BSC.words where + ra [] = -1 + ra l = fromMaybe (-1) $ readMaybe $ BSC.unpack $ last l + +-- Do we need to use the PGColDescription here always, or are the request formats okay? +fixBinary :: [Bool] -> PGValues -> PGValues +fixBinary (False:b) (PGBinaryValue x:r) = PGTextValue x : fixBinary b r +fixBinary (True :b) (PGTextValue x:r) = PGBinaryValue x : fixBinary b r +fixBinary (_:b) (x:r) = x : fixBinary b r +fixBinary _ l = l + +-- |A simple query is one which requires sending only a single 'SimpleQuery' +-- message to the PostgreSQL server. The query is sent as a single string; you +-- cannot bind parameters. Note that queries can return 0 results (an empty +-- list). +pgSimpleQuery :: PGConnection -> BSL.ByteString -- ^ SQL string + -> IO (Int, [PGValues]) -- ^ The number of rows affected and a list of result rows +pgSimpleQuery h sql = do + pgSync h + pgSend h $ SimpleQuery sql + pgFlush h + go start where + go = (pgRecv h >>=) + start (RowDescription rd) = go $ row (map pgColBinary rd) id + start (CommandComplete c) = got c [] + start EmptyQueryResponse = return (0, []) + start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m + row bc r (DataRow fs) = go $ row bc (r . (fixBinary bc fs :)) + row _ r (CommandComplete c) = got c (r []) + row _ _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m + got c r = return (rowsAffected c, r) + +-- |A simple query which may contain multiple queries (separated by semi-colons) whose results are all ignored. +-- This function can also be used for \"SET\" parameter queries if necessary, but it's safer better to use 'pgDBParams'. +pgSimpleQueries_ :: PGConnection -> BSL.ByteString -- ^ SQL string + -> IO () +pgSimpleQueries_ h sql = do + pgSync h + pgSend h $ SimpleQuery sql + pgFlush h + go where + go = pgRecv h >>= res + res (Left (RowDescription _)) = go + res (Left (CommandComplete _)) = go + res (Left EmptyQueryResponse) = go + res (Left (DataRow _)) = go + res (Right RecvSync) = return () + res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m + +pgPreparedBind :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> IO (IO ()) +pgPreparedBind c sql types bind bc = do + pgSync c + m <- readIORef (connPreparedStatementMap c) + (p, n) <- maybe + (atomicModifyIORef' (connPreparedStatementCount c) (succ &&& (,) False . PGPreparedStatement)) + (return . (,) True) $ Map.lookup key m + unless p $ + pgSend c Parse{ queryString = BSL.fromStrict sql, statementName = preparedStatementName n, parseTypes = types } + pgSend c Bind{ portalName = BS.empty, statementName = preparedStatementName n, bindParameters = bind, binaryColumns = bc } + let + go = pgRecv c >>= start + start ParseComplete = do + modifyIORef' (connPreparedStatementMap c) $ + Map.insert key n + go + start BindComplete = return () + start r = fail $ "pgPrepared: unexpected response: " ++ show r + return go + where key = (sql, types) + +-- |Prepare a statement, bind it, and execute it. +-- If the given statement has already been prepared (and not yet closed) on this connection, it will be re-used. +pgPreparedQuery :: PGConnection -> BS.ByteString -- ^ SQL statement with placeholders + -> [OID] -- ^ Optional type specifications (only used for first call) + -> PGValues -- ^ Paremeters to bind to placeholders + -> [Bool] -- ^ Requested binary format for result columns + -> IO (Int, [PGValues]) +pgPreparedQuery c sql types bind bc = do + start <- pgPreparedBind c sql types bind bc + pgSend c Execute{ portalName = BS.empty, executeRows = 0 } + pgSend c Sync + pgFlush c + start + go id + where + go r = pgRecv c >>= row r + row r (DataRow fs) = go (r . (fixBinary bc fs :)) + row r (CommandComplete d) = return (rowsAffected d, r []) + row r EmptyQueryResponse = return (0, r []) + row _ m = fail $ "pgPreparedQuery: unexpected row: " ++ show m + +-- |Like 'pgPreparedQuery' but requests results lazily in chunks of the given size. +-- Does not use a named portal, so other requests may not intervene. +pgPreparedLazyQuery :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) + -> IO [PGValues] +pgPreparedLazyQuery c sql types bind bc count = do + start <- pgPreparedBind c sql types bind bc + unsafeInterleaveIO $ do + execute + start + go id + where + execute = do + pgSend c Execute{ portalName = BS.empty, executeRows = count } + pgSend c Flush + pgFlush c + go r = pgRecv c >>= row r + row r (DataRow fs) = go (r . (fixBinary bc fs :)) + row r PortalSuspended = r <$> unsafeInterleaveIO (execute >> go id) + row r (CommandComplete _) = return (r []) + row r EmptyQueryResponse = return (r []) + row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m + +-- |Close a previously prepared query (if necessary). +pgCloseStatement :: PGConnection -> BS.ByteString -> [OID] -> IO () +pgCloseStatement c sql types = do + mn <- atomicModifyIORef (connPreparedStatementMap c) $ + swap . Map.updateLookupWithKey (\_ _ -> Nothing) (sql, types) + Fold.mapM_ (pgClose c) mn + +-- |Begin a new transaction. If there is already a transaction in progress (created with 'pgBegin' or 'pgTransaction') instead creates a savepoint. +pgBegin :: PGConnection -> IO () +pgBegin c@PGConnection{ connTransaction = tr } = do + t <- atomicModifyIORef' tr (succ &&& id) + void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "BEGIN" else "SAVEPOINT pgt" ++ show t + +predTransaction :: Word -> (Word, Word) +predTransaction 0 = (0, error "pgTransaction: no transactions") +predTransaction x = (x', x') where x' = pred x + +-- |Rollback to the most recent 'pgBegin'. +pgRollback :: PGConnection -> IO () +pgRollback c@PGConnection{ connTransaction = tr } = do + t <- atomicModifyIORef' tr predTransaction + void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "ROLLBACK" else "ROLLBACK TO SAVEPOINT pgt" ++ show t + +-- |Commit the most recent 'pgBegin'. +pgCommit :: PGConnection -> IO () +pgCommit c@PGConnection{ connTransaction = tr } = do + t <- atomicModifyIORef' tr predTransaction + void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "COMMIT" else "RELEASE SAVEPOINT pgt" ++ show t + +-- |Rollback all active 'pgBegin's. +pgRollbackAll :: PGConnection -> IO () +pgRollbackAll c@PGConnection{ connTransaction = tr } = do + writeIORef tr 0 + void $ pgSimpleQuery c $ BSLC.pack "ROLLBACK" + +-- |Commit all active 'pgBegin's. +pgCommitAll :: PGConnection -> IO () +pgCommitAll c@PGConnection{ connTransaction = tr } = do + writeIORef tr 0 + void $ pgSimpleQuery c $ BSLC.pack "COMMIT" + +-- |Wrap a computation in a 'pgBegin', 'pgCommit' block, or 'pgRollback' on exception. +pgTransaction :: PGConnection -> IO a -> IO a +pgTransaction c f = do + pgBegin c + onException (do + r <- f + pgCommit c + return r) + (pgRollback c) + +-- |Prepare, bind, execute, and close a single (unnamed) query, and return the number of rows affected, or Nothing if there are (ignored) result rows. +pgRun :: PGConnection -> BSL.ByteString -> [OID] -> PGValues -> IO (Maybe Integer) +pgRun c sql types bind = do + pgSync c + pgSend c Parse{ queryString = sql, statementName = BS.empty, parseTypes = types } + pgSend c Bind{ portalName = BS.empty, statementName = BS.empty, bindParameters = bind, binaryColumns = [] } + pgSend c Execute{ portalName = BS.empty, executeRows = 1 } -- 0 does not mean none + pgSend c Sync + pgFlush c + go where + go = pgRecv c >>= res + res ParseComplete = go + res BindComplete = go + res (DataRow _) = go + res PortalSuspended = return Nothing + res (CommandComplete d) = return (Just $ rowsAffected d) + res EmptyQueryResponse = return (Just 0) + res m = fail $ "pgRun: unexpected response: " ++ show m + +-- |Prepare a single query and return its handle. +pgPrepare :: PGConnection -> BSL.ByteString -> [OID] -> IO PGPreparedStatement +pgPrepare c sql types = do + n <- atomicModifyIORef' (connPreparedStatementCount c) (succ &&& PGPreparedStatement) + pgSync c + pgSend c Parse{ queryString = sql, statementName = preparedStatementName n, parseTypes = types } + pgSend c Sync + pgFlush c + ParseComplete <- pgRecv c + return n + +-- |Close a previously prepared query. +pgClose :: PGConnection -> PGPreparedStatement -> IO () +pgClose c n = do + pgSync c + pgSend c ClosePortal{ portalName = preparedStatementName n } + pgSend c CloseStatement{ statementName = preparedStatementName n } + pgSend c Sync + pgFlush c + CloseComplete <- pgRecv c + CloseComplete <- pgRecv c + return () + +-- |Bind a prepared statement, and return the row description. +-- After 'pgBind', you must either call 'pgFetch' until it completes (returns @(_, 'Just' _)@) or 'pgFinish' before calling 'pgBind' again on the same prepared statement. +pgBind :: PGConnection -> PGPreparedStatement -> PGValues -> IO PGRowDescription +pgBind c n bind = do + pgSync c + pgSend c ClosePortal{ portalName = sn } + pgSend c Bind{ portalName = sn, statementName = sn, bindParameters = bind, binaryColumns = [] } + pgSend c DescribePortal{ portalName = sn } + pgSend c Sync + pgFlush c + CloseComplete <- pgRecv c + BindComplete <- pgRecv c + rowDescription <$> pgRecv c + where sn = preparedStatementName n + +-- |Fetch some rows from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete. +pgFetch :: PGConnection -> PGPreparedStatement -> Word32 -- ^Maximum number of rows to return, or 0 for all + -> IO ([PGValues], Maybe Integer) +pgFetch c n count = do + pgSync c + pgSend c Execute{ portalName = preparedStatementName n, executeRows = count } + pgSend c Sync + pgFlush c + go where + go = pgRecv c >>= res + res (DataRow v) = first (v :) <$> go + res PortalSuspended = return ([], Nothing) + res (CommandComplete d) = do + pgSync c + pgSend c ClosePortal{ portalName = preparedStatementName n } + pgSend c Sync + pgFlush c + CloseComplete <- pgRecv c + return ([], Just $ rowsAffected d) + res EmptyQueryResponse = return ([], Just 0) + res m = fail $ "pgFetch: unexpected response: " ++ show m + +-- |Retrieve a notifications, blocking if necessary. +pgGetNotification :: PGConnection -> IO PGNotification +pgGetNotification c = + maybe (pgRecv c) return + =<< atomicModifyIORef' (connNotifications c) deQueue + +-- |Retrieve any pending notifications. Non-blocking. +pgGetNotifications :: PGConnection -> IO [PGNotification] +pgGetNotifications c = do + RecvNonBlock <- pgRecv c + queueToList <$> atomicModifyIORef' (connNotifications c) (emptyQueue, ) + where + queueToList :: Queue a -> [a] + queueToList (Queue e d) = d ++ reverse e + + +--TODO: Implement non-blocking recv on mingw32 +#ifndef mingw32_HOST_OS +recvNonBlock + :: Net.Socket -- ^ Connected socket + -> Int -- ^ Maximum number of bytes to receive + -> IO BS.ByteString -- ^ Data received +recvNonBlock s nbytes + | nbytes < 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.Protocol.recvNonBlock") + | otherwise = createAndTrim nbytes $ \ptr -> recvBufNonBlock s ptr nbytes + +recvBufNonBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int +recvBufNonBlock s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNonBlock") + | otherwise = do + len <- +#if MIN_VERSION_network(3,1,0) + Net.withFdSocket s $ \fd -> +#elif MIN_VERSION_network(3,0,0) + Net.fdSocket s >>= \fd -> +#else + let fd = Net.fdSocket s in +#endif + c_recv fd (castPtr ptr) (fromIntegral nbytes) 0 + if len == -1 + then do + errno <- getErrno + if errno == eWOULDBLOCK + then return 0 + else throwIO (errnoToIOError "recvBufNonBlock" errno Nothing (Just "Database.PostgreSQL.Typed")) + else + return $ fromIntegral len + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError + InvalidArgument + loc Nothing Nothing) "non-positive length" + + +foreign import ccall unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +#endif diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs new file mode 100644 index 0000000..bc38032 --- /dev/null +++ b/Database/PostgreSQL/Typed/Query.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP, PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, GADTs, DataKinds, TemplateHaskell #-} +module Database.PostgreSQL.Typed.Query + ( PGQuery(..) + , PGSimpleQuery + , PGPreparedQuery + , rawPGSimpleQuery + , rawPGPreparedQuery + , QueryFlags(..) + , simpleQueryFlags + , parseQueryFlags + , makePGQuery + , pgSQL + , pgExecute + , pgQuery + , pgLazyQuery + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Arrow ((***), first, second) +import Control.Exception (try) +import Control.Monad (void, when, mapAndUnzipM) +import Data.Array (listArray, (!), inRange) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.ByteString.UTF8 as BSU +import Data.Char (isSpace, isAlphaNum) +import qualified Data.Foldable as Fold +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe, isNothing) +import Data.String (IsString(..)) +import Data.Word (Word32) +import Language.Haskell.Meta.Parse (parseExp) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.SQLToken + +class PGQuery q a | q -> a where + -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results. + pgRunQuery :: PGConnection -> q -> IO (Int, [a]) + -- |Change the raw SQL query stored within this query. + -- This is unsafe because the query has already been type-checked, so any change must not change the number or type of results or placeholders (so adding additional static WHERE or ORDER BY clauses is generally safe). + -- This is useful in cases where you need to construct some part of the query dynamically, but still want to infer the result types. + -- If you want to add dynamic values to the query, it's best to use 'Database.PostgreSQL.Typed.Dynamic.pgSafeLiteral'. + -- For example: + -- + -- > [pgSQL|SELECT a FROM t|] `unsafeModifyQuery` (<> (" WHERE a = " <> pgSafeLiteral x)) + unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q + getQueryString :: PGTypeEnv -> q -> BS.ByteString +class PGQuery q PGValues => PGRawQuery q + +-- |Execute a query that does not return results. +-- Return the number of rows affected (or -1 if not known). +pgExecute :: PGQuery q () => PGConnection -> q -> IO Int +pgExecute c q = fst <$> pgRunQuery c q + +-- |Run a query and return a list of row results. +pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] +pgQuery c q = snd <$> pgRunQuery c q + +instance PGQuery BS.ByteString PGValues where + pgRunQuery c sql = pgSimpleQuery c (BSL.fromStrict sql) + unsafeModifyQuery q f = f q + getQueryString _ = id + +newtype SimpleQuery = SimpleQuery BS.ByteString + deriving (Show) +instance PGQuery SimpleQuery PGValues where + pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c (BSL.fromStrict sql) + unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql + getQueryString _ (SimpleQuery q) = q +instance PGRawQuery SimpleQuery + +data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool] + deriving (Show) +instance PGQuery PreparedQuery PGValues where + pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc + unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc + getQueryString _ (PreparedQuery q _ _ _) = q +instance PGRawQuery PreparedQuery + + +data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a) +instance PGRawQuery q => PGQuery (QueryParser q a) a where + pgRunQuery c (QueryParser q p) = second (fmap $ p e) <$> pgRunQuery c (q e) where e = pgTypeEnv c + unsafeModifyQuery (QueryParser q p) f = QueryParser (\e -> unsafeModifyQuery (q e) f) p + getQueryString e (QueryParser q _) = getQueryString e $ q e + +instance Functor (QueryParser q) where + fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) + +instance Show q => Show (QueryParser q a) where + showsPrec p (QueryParser q _) = showParen (p > 10) $ + showString "QueryParser " . showsPrec 11 (q unknownPGTypeEnv) + +rawParser :: q -> QueryParser q PGValues +rawParser q = QueryParser (const q) (const id) + +-- |A simple one-shot query that simply substitutes literal representations of parameters for placeholders. +type PGSimpleQuery = QueryParser SimpleQuery +-- |A prepared query that automatically is prepared in the database the first time it is run and bound with new parameters each subsequent time. +type PGPreparedQuery = QueryParser PreparedQuery + +-- |Make a simple query directly from a query string, with no type inference +rawPGSimpleQuery :: BS.ByteString -> PGSimpleQuery PGValues +rawPGSimpleQuery = rawParser . SimpleQuery + +instance IsString (PGSimpleQuery PGValues) where + fromString = rawPGSimpleQuery . fromString +instance IsString (PGSimpleQuery ()) where + fromString = void . rawPGSimpleQuery . fromString + +-- |Make a prepared query directly from a query string and bind parameters, with no type inference +rawPGPreparedQuery :: BS.ByteString -> PGValues -> PGPreparedQuery PGValues +rawPGPreparedQuery sql bind = rawParser $ PreparedQuery sql [] bind [] + +-- |Run a prepared query in lazy mode, where only chunk size rows are requested at a time. +-- If you eventually retrieve all the rows this way, it will be far less efficient than using @pgQuery@, since every chunk requires an additional round-trip. +-- Although you may safely stop consuming rows early, currently you may not interleave any other database operation while reading rows. (This limitation could theoretically be lifted if required.) +pgLazyQuery :: PGConnection -> PGPreparedQuery a -> Word32 -- ^ Chunk size (1 is common, 0 is all-or-nothing) + -> IO [a] +pgLazyQuery c (QueryParser q p) count = + fmap (p e) <$> pgPreparedLazyQuery c sql types bind bc count where + e = pgTypeEnv c + PreparedQuery sql types bind bc = q e + +-- |Given a SQL statement with placeholders of the form @${expr}@, return a (hopefully) valid SQL statement with @$N@ placeholders and the list of expressions. +-- This does its best to understand SQL syntax, so placeholders are only interpreted in places postgres would understand them (i.e., not in quoted strings). Since this is not valid SQL otherwise, there is never reason to escape a literal @${@. +-- You can use @$N@ placeholders in the query otherwise to refer to the N-th index placeholder expression. +sqlPlaceholders :: String -> (String, [String]) +sqlPlaceholders = sst (1 :: Int) . sqlTokens where + sst n (SQLExpr e : l) = (('$':show n) ++) *** (e :) $ sst (succ n) l + sst n (t : l) = first (show t ++) $ sst n l + sst _ [] = ("", []) + +-- |Given a SQL statement with placeholders of the form @$N@ and a list of TH 'ByteString' expressions, return a new 'ByteString' expression that substitutes the expressions for the placeholders. +sqlSubstitute :: String -> [TH.Exp] -> TH.Exp +sqlSubstitute sql exprl = TH.AppE (TH.VarE 'BS.concat) $ TH.ListE $ map sst $ sqlTokens sql where + bnds = (1, length exprl) + exprs = listArray bnds exprl + expr n + | inRange bnds n = exprs ! n + | otherwise = error $ "SQL placeholder '$" ++ show n ++ "' out of range (not recognized by PostgreSQL)" + sst (SQLParam n) = expr n + sst t = TH.VarE 'BSU.fromString `TH.AppE` TH.LitE (TH.StringL $ show t) + +splitCommas :: String -> [String] +splitCommas = spl where + spl [] = [] + spl [c] = [[c]] + spl (',':s) = "":spl s + spl (c:s) = (c:h):t where h:t = spl s + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +-- |Flags affecting how and what type of query to build with 'makePGQuery'. +data QueryFlags = QueryFlags + { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment). + , flagNullable :: Maybe Bool -- ^ Disable nullability inference, treating all values as nullable (if 'True') or not (if 'False'). + , flagPrepare :: Maybe [String] -- ^ Prepare and re-use query, binding parameters of the given types (inferring the rest, like PREPARE). + } + +-- |'QueryFlags' for a default (simple) query. +simpleQueryFlags :: QueryFlags +simpleQueryFlags = QueryFlags True Nothing Nothing + +newName :: Char -> BS.ByteString -> TH.Q TH.Name +newName pre = TH.newName . ('_':) . (pre:) . filter (\c -> isAlphaNum c || c == '_') . BSC.unpack + +-- |Construct a 'PGQuery' from a SQL string. +-- This is the underlying template function for 'pgSQL' which you can use in largely the same way when you want to construct query strings from other variables. +-- For example: +-- +-- > selectQuery = "SELECT * FROM" +-- > selectFoo = $(makePGQuery simpleQueryFlags (selectQuery ++ " foo")) +-- +-- The only caveat is that variables or functions like @selectQuery@ need to be defined in a different module (due to TH stage restrictions). +makePGQuery :: QueryFlags -> String -> TH.ExpQ +makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle +makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do + (pt, rt) <- TH.runIO $ tpgDescribe (BSU.fromString sqlp) (fromMaybe [] prep) (isNothing nulls) + when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL" + + e <- TH.newName "_tenv" + l <- TH.newName "l" + (vars, vals) <- mapAndUnzipM (\t -> do + v <- newName 'p' $ tpgValueName t + return + ( TH.VarP v + , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v + )) pt + (pats, conv, bins) <- unzip3 <$> mapM (\t -> do + v <- newName 'c' $ tpgValueName t + return + ( TH.VarP v + , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v + , tpgTypeBinary t e + )) rt + foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser + `TH.AppE` TH.LamE [TH.VarP e] (maybe + (TH.ConE 'SimpleQuery + `TH.AppE` sqlSubstitute sqlp vals) + (\p -> TH.ConE 'PreparedQuery + `TH.AppE` (TH.VarE 'BSU.fromString `TH.AppE` TH.LitE (TH.StringL sqlp)) + `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID . snd) $ zip p pt) + `TH.AppE` TH.ListE vals + `TH.AppE` TH.ListE +#ifdef VERSION_postgresql_binary + bins +#else + [] +#endif + ) + prep) + `TH.AppE` TH.LamE [TH.VarP e, TH.VarP l] (TH.CaseE (TH.VarE l) + [ TH.Match (TH.ListP pats) (TH.NormalB $ case conv of + [x] -> x + _ -> TH.TupE +#if MIN_VERSION_template_haskell(2,16,0) + $ map Just +#endif + conv) [] + , TH.Match TH.WildP (TH.NormalB $ TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL "pgSQL: result arity mismatch")) [] + ])) + <$> mapM parse exprs + where + (sqlp, exprs) = sqlPlaceholders sqle + parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e + +-- |Parse flags off the beginning of a query string, returning the flags and the remaining string. +parseQueryFlags :: String -> (QueryFlags, String) +parseQueryFlags = pqf simpleQueryFlags where + pqf f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = pqf f{ flagQuery = False } q + pqf f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('?':q) = pqf f{ flagNullable = Just True } q + pqf f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('!':q) = pqf f{ flagNullable = Just False } q + pqf f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = pqf f{ flagPrepare = Just [] } q + pqf f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = pqf f{ flagPrepare = Just args } (sql r) where + args = map trim $ splitCommas arg + (arg, r) = break (')' ==) s + sql (')':q) = q + sql _ = error "pgSQL: unterminated argument list" + pqf f q = (f, q) + +qqQuery :: String -> TH.ExpQ +qqQuery = uncurry makePGQuery . parseQueryFlags + +qqTop :: Bool -> String -> TH.DecsQ +qqTop True ('!':sql) = qqTop False sql +qqTop err sql = do + r <- TH.runIO $ try $ withTPGConnection $ \c -> + pgSimpleQuery c (BSLU.fromString sql) + either ((if err then TH.reportError else TH.reportWarning) . (show :: PGError -> String)) (const $ return ()) r + return [] + +-- |A quasi-quoter for PGSQL queries. +-- +-- Used in expression context, it may contain any SQL statement @[pgSQL|SELECT ...|]@. +-- The statement may contain PostgreSQL-style placeholders (@$1@, @$2@, ...) or in-line placeholders (@${1+1}@) containing any valid Haskell expression (except @{}@). +-- It will be replaced by a 'PGQuery' object that can be used to perform the SQL statement. +-- If there are more @$N@ placeholders than expressions, it will instead be a function accepting the additional parameters and returning a 'PGQuery'. +-- +-- Ideally, this mimics postgres' SQL parsing, so that placeholders and expressions will only be expanded when they are in valid positions (i.e., not inside quoted strings). +-- Since @${@ is not valid SQL otherwise, there should be no need to escape it. +-- +-- The statement may start with one of more special flags affecting the interpretation: +-- +-- [@?@] To disable nullability inference, treating all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. This makes unexpected NULL errors impossible. +-- [@!@] To disable nullability inference, treating all result values as /not/ nullable, thus only returning 'Maybe' where requested. This is makes unexpected NULL errors more likely. +-- [@$@] To create a 'PGPreparedQuery' (using placeholder parameters) rather than the default 'PGSimpleQuery' (using literal substitution). +-- [@$(type,...)@] To specify specific types for a prepared query (see for details), rather than inferring parameter types by default. +-- [@#@] Only do literal @${}@ substitution using 'pgSubstituteLiterals' and return a string, not a query. +-- +-- 'pgSQL' can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results). +-- Here the query can only be prefixed with @!@ to make errors non-fatal. +-- +-- If you want to construct queries out of string variables rather than quasi-quoted strings, you can use the lower-level 'makePGQuery' instead. +pgSQL :: QuasiQuoter +pgSQL = QuasiQuoter + { quoteExp = qqQuery + , quoteType = const $ fail "pgSQL not supported in types" + , quotePat = const $ fail "pgSQL not supported in patterns" + , quoteDec = qqTop True + } diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs new file mode 100644 index 0000000..3a36e7d --- /dev/null +++ b/Database/PostgreSQL/Typed/Range.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings, TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module: Database.PostgreSQL.Typed.Range +-- Copyright: 2015 Dylan Simon +-- +-- Representaion of PostgreSQL's range type. +-- There are a number of existing range data types, but PostgreSQL's is rather particular. +-- This tries to provide a one-to-one mapping. + +module Database.PostgreSQL.Typed.Range where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<$)) +#endif +import Control.Monad (guard) +import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as BSC +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..)) +#else +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid(..)) +#endif +#endif +import GHC.TypeLits (Symbol) + +import Database.PostgreSQL.Typed.Types + +-- |A end-point for a range, which may be nothing (infinity, NULL in PostgreSQL), open (inclusive), or closed (exclusive) +data Bound a + = Unbounded -- ^ Equivalent to @Bounded False ±Infinity@ + | Bounded + { _boundClosed :: Bool -- ^ @True@ if the range includes this bound + , _bound :: a + } + deriving (Eq) + +instance Functor Bound where + fmap _ Unbounded = Unbounded + fmap f (Bounded c a) = Bounded c (f a) + +newtype LowerBound a = Lower { boundLower :: Bound a } deriving (Eq, Functor) + +-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds) +instance Ord a => Ord (LowerBound a) where + compare (Lower Unbounded) (Lower Unbounded) = EQ + compare (Lower Unbounded) _ = LT + compare _ (Lower Unbounded) = GT + compare (Lower (Bounded ac a)) (Lower (Bounded bc b)) = compare a b <> compare bc ac + +-- |The constraint is only necessary for @maxBound@, unfortunately +instance Bounded a => Bounded (LowerBound a) where + minBound = Lower Unbounded + maxBound = Lower (Bounded False maxBound) + +newtype UpperBound a = Upper { boundUpper :: Bound a } deriving (Eq, Functor) + +-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds) +instance Ord a => Ord (UpperBound a) where + compare (Upper Unbounded) (Upper Unbounded) = EQ + compare (Upper Unbounded) _ = GT + compare _ (Upper Unbounded) = LT + compare (Upper (Bounded ac a)) (Upper (Bounded bc b)) = compare a b <> compare ac bc + +-- |The constraint is only necessary for @minBound@, unfortunately +instance Bounded a => Bounded (UpperBound a) where + minBound = Upper (Bounded False minBound) + maxBound = Upper Unbounded + +compareBounds :: Ord a => LowerBound a -> UpperBound a -> Bound Bool +compareBounds (Lower (Bounded lc l)) (Upper (Bounded uc u)) = + case compare l u of + LT -> Bounded True True + EQ -> Bounded (lc /= uc) (lc && uc) + GT -> Bounded False False +compareBounds _ _ = Unbounded + +data Range a + = Empty + | Range + { lower :: LowerBound a + , upper :: UpperBound a + } + deriving (Eq, Ord) + +instance Functor Range where + fmap _ Empty = Empty + fmap f (Range l u) = Range (fmap f l) (fmap f u) + +instance Show a => Show (Range a) where + showsPrec _ Empty = showString "empty" + showsPrec _ (Range (Lower l) (Upper u)) = + sc '[' '(' l . sb l . showChar ',' . sb u . sc ']' ')' u where + sc c o b = showChar $ if boundClosed b then c else o + sb = maybe id (showsPrec 10) . bound + +bound :: Bound a -> Maybe a +bound Unbounded = Nothing +bound (Bounded _ b) = Just b + +-- |Unbounded endpoints are always open. +boundClosed :: Bound a -> Bool +boundClosed Unbounded = False +boundClosed (Bounded c _) = c + +-- |Construct from parts: @makeBound (boundClosed b) (bound b) == b@ +makeBound :: Bool -> Maybe a -> Bound a +makeBound c (Just a) = Bounded c a +makeBound False Nothing = Unbounded +makeBound True Nothing = error "makeBound: unbounded may not be closed" + +-- |Empty ranges treated as 'Unbounded' +lowerBound :: Range a -> Bound a +lowerBound Empty = Unbounded +lowerBound (Range (Lower b) _) = b + +-- |Empty ranges treated as 'Unbounded' +upperBound :: Range a -> Bound a +upperBound Empty = Unbounded +upperBound (Range _ (Upper b)) = b + +-- |Equivalent to @boundClosed . lowerBound@ +lowerClosed :: Range a -> Bool +lowerClosed Empty = False +lowerClosed (Range (Lower b) _) = boundClosed b + +-- |Equivalent to @boundClosed . upperBound@ +upperClosed :: Range a -> Bool +upperClosed Empty = False +upperClosed (Range _ (Upper b)) = boundClosed b + +empty :: Range a +empty = Empty + +isEmpty :: Ord a => Range a -> Bool +isEmpty Empty = True +isEmpty (Range l u) + | Bounded _ n <- compareBounds l u = not n + | otherwise = False + +full :: Range a +full = Range (Lower Unbounded) (Upper Unbounded) + +isFull :: Range a -> Bool +isFull (Range (Lower Unbounded) (Upper Unbounded)) = True +isFull _ = False + +-- |Create a point range @[x,x]@ +point :: a -> Range a +point a = Range (Lower (Bounded True a)) (Upper (Bounded True a)) + +-- |Extract a point: @getPoint (point x) == Just x@ +getPoint :: Eq a => Range a -> Maybe a +getPoint (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = u <$ guard (u == l) +getPoint _ = Nothing + +-- Construct a range from endpoints and normalize it. +range :: Ord a => Bound a -> Bound a -> Range a +range l u = normalize $ Range (Lower l) (Upper u) + +-- Construct a standard range (@[l,u)@ or 'point') from bounds (like 'bound') and normalize it. +normal :: Ord a => Maybe a -> Maybe a -> Range a +normal l u = range (mb True l) (mb (l == u) u) where + mb = maybe Unbounded . Bounded + +-- Construct a bounded range like 'normal'. +bounded :: Ord a => a -> a -> Range a +bounded l u = normal (Just l) (Just u) + +-- Fold empty ranges to 'Empty'. +normalize :: Ord a => Range a -> Range a +normalize r + | isEmpty r = Empty + | otherwise = r + +-- |'normalize' for discrete (non-continuous) range types, using the 'Enum' instance +normalize' :: (Ord a, Enum a) => Range a -> Range a +normalize' Empty = Empty +normalize' (Range (Lower l) (Upper u)) = normalize $ range l' u' + where + l' = case l of + Bounded False b -> Bounded True (succ b) + _ -> l + u' = case u of + Bounded True b -> Bounded False (succ b) + _ -> u + +-- |Contains range +(@>), (<@) :: Ord a => Range a -> Range a -> Bool +_ @> Empty = True +Empty @> r = isEmpty r +Range la ua @> Range lb ub = la <= lb && ua >= ub +a <@ b = b @> a + +-- |Contains element +(@>.) :: Ord a => Range a -> a -> Bool +r @>. a = r @> point a + +overlaps :: Ord a => Range a -> Range a -> Bool +overlaps a b = intersect a b /= Empty + +intersect :: Ord a => Range a -> Range a -> Range a +intersect (Range la ua) (Range lb ub) = normalize $ Range (max la lb) (min ua ub) +intersect _ _ = Empty + +-- |Union ranges. Fails if ranges are disjoint. +union :: Ord a => Range a -> Range a -> Range a +union Empty r = r +union r Empty = r +union _ra@(Range la ua) _rb@(Range lb ub) + -- isEmpty _ra = _rb + -- isEmpty _rb = _ra + | Bounded False False <- compareBounds lb ua = error "union: disjoint Ranges" + | Bounded False False <- compareBounds la ub = error "union: disjoint Ranges" + | otherwise = Range (min la lb) (max ua ub) + +#if MIN_VERSION_base(4,9,0) +instance Ord a => Semigroup (Range a) where + (<>) = union +#endif + +instance Ord a => Monoid (Range a) where + mempty = Empty + mappend = union + +-- |Class indicating that the first PostgreSQL type is a range of the second. +-- This implies 'PGParameter' and 'PGColumn' instances that will work for any type. +class (PGType t, PGType (PGSubType t)) => PGRangeType t where + type PGSubType t :: Symbol + pgRangeElementType :: PGTypeID t -> PGTypeID (PGSubType t) + pgRangeElementType PGTypeProxy = PGTypeProxy + +instance (PGRangeType t, PGParameter (PGSubType t) a) => PGParameter t (Range a) where + pgEncode _ Empty = BSC.pack "empty" + pgEncode tr (Range (Lower l) (Upper u)) = buildPGValue $ + pc '[' '(' l + <> pb (bound l) + <> BSB.char7 ',' + <> pb (bound u) + <> pc ']' ')' u + where + pb Nothing = mempty + pb (Just b) = pgDQuoteFrom "(),[]" $ pgEncode (pgRangeElementType tr) b + pc c o b = BSB.char7 $ if boundClosed b then c else o +instance (PGRangeType t, PGColumn (PGSubType t) a) => PGColumn t (Range a) where + pgDecode tr a = either (error . ("pgDecode range (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly per a where + per = (Empty <$ pe) <> pr + pe = P.stringCI "empty" + pb = fmap (pgDecode (pgRangeElementType tr)) <$> parsePGDQuote True "(),[]" BSC.null + pc c o = (True <$ P.char c) <> (False <$ P.char o) + mb = maybe Unbounded . Bounded + pr = do + lc <- pc '[' '(' + lb <- pb + _ <- P.char ',' + ub <- pb + uc <- pc ']' ')' + return $ Range (Lower (mb lc lb)) (Upper (mb uc ub)) + +instance PGType "int4range" where + type PGVal "int4range" = Range (PGVal (PGSubType "int4range")) +instance PGRangeType "int4range" where + type PGSubType "int4range" = "integer" +instance PGType "numrange" where + type PGVal "numrange" = Range (PGVal (PGSubType "numrange")) +instance PGRangeType "numrange" where + type PGSubType "numrange" = "numeric" +instance PGType "tsrange" where + type PGVal "tsrange" = Range (PGVal (PGSubType "tsrange")) +instance PGRangeType "tsrange" where + type PGSubType "tsrange" = "timestamp without time zone" +instance PGType "tstzrange" where + type PGVal "tstzrange" = Range (PGVal (PGSubType "tstzrange")) +instance PGRangeType "tstzrange" where + type PGSubType "tstzrange" = "timestamp with time zone" +instance PGType "daterange" where + type PGVal "daterange" = Range (PGVal (PGSubType "daterange")) +instance PGRangeType "daterange" where + type PGSubType "daterange" = "date" +instance PGType "int8range" where + type PGVal "int8range" = Range (PGVal (PGSubType "int8range")) +instance PGRangeType "int8range" where + type PGSubType "int8range" = "bigint" + diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs new file mode 100644 index 0000000..41e3928 --- /dev/null +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +-- | +-- Module: Database.PostgreSQL.Typed.Relation +-- Copyright: 2016 Dylan Simon +-- +-- Automatically create data types based on tables and other relations. + +module Database.PostgreSQL.Typed.Relation + ( dataPGRelation + ) where + +import qualified Data.ByteString.Lazy as BSL +import Data.Proxy (Proxy(..)) +import qualified Language.Haskell.TH as TH + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TypeCache +import Database.PostgreSQL.Typed.TH + +-- |Data types that are based on database relations. +-- Normally these instances are created using 'dataPGRelation'. +class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where + -- |Database name of table/relation (i.e., second argument to 'dataPGRelation'). Normally this is the same as @'pgTypeID' . 'pgTypeOfProxy'@, but this preserves any specified schema qualification. + pgRelationName :: Proxy a -> PGName + pgRelationName = pgTypeName . pgTypeOfProxy + -- |Database names of columns. + pgColumnNames :: Proxy a -> [PGName] + +-- |Create a new data type corresponding to the given PostgreSQL relation. +-- For example, if you have @CREATE TABLE foo (abc integer NOT NULL, def text)@, then +-- @dataPGRelation \"Foo\" \"foo\" (\"foo_\"++)@ will be equivalent to: +-- +-- > data Foo = Foo{ foo_abc :: PGVal "integer", foo_def :: Maybe (PGVal "text") } +-- > instance PGType "foo" where PGVal "foo" = Foo +-- > instance PGParameter "foo" Foo where ... +-- > instance PGColumn "foo" Foo where ... +-- > instance PGColumn "foo" (Maybe Foo) where ... -- to handle NULL in not null columns +-- > instance PGRep Foo where PGRepType = "foo" +-- > instance PGRecordType "foo" +-- > instance PGRelation Foo where pgColumnNames _ = ["abc", "def"] +-- > uncurryFoo :: (PGVal "integer", Maybe (PGVal "text")) -> Foo +-- +-- (Note that @PGVal "integer" = Int32@ and @PGVal "text" = Text@ by default.) +-- This provides instances for marshalling the corresponding composite/record types, e.g., using @SELECT foo.*::foo FROM foo@. +-- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving. +-- +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds, TypeFamilies, PatternGuards +dataPGRelation :: String -- ^ Haskell type and constructor to create + -> PGName -- ^ PostgreSQL table/relation name + -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_"++)@ (input is 'pgNameString') + -> TH.DecsQ +dataPGRelation typs pgtab colf = do + (pgid, cold) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do + cl <- mapM (\[to, cn, ct, cnn] -> do + let c = pgDecodeRep cn :: PGName + n = TH.mkName $ colf $ pgNameString c + o = pgDecodeRep ct :: OID + t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": column '" ++ show c ++ "' has unknown type " ++ show o) return + =<< lookupPGType tpg o + return (pgDecodeRep to, (c, n, TH.LitT (TH.StrTyLit $ pgNameString t), not $ pgDecodeRep cnn))) + . snd =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks + [ "SELECT reltype, attname, atttypid, attnotnull" + , " FROM pg_catalog.pg_attribute" + , " JOIN pg_catalog.pg_class ON attrelid = pg_class.oid" + , " WHERE attrelid = ", pgLiteralRep pgtab, "::regclass" + , " AND attnum > 0 AND NOT attisdropped" + , " ORDER BY attnum" + ]) + case cl of + [] -> fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": no columns found" + (to, _):_ -> do + tt <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return + =<< lookupPGType tpg to + return (tt, map snd cl) + cols <- mapM (\(c, _, t, nn) -> do + v <- TH.newName $ pgNameString c + return (v, t, nn)) + cold + let typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) + encfun f = TH.FunD f [TH.Clause [TH.WildP, conP typn (map (\(v, _, _) -> TH.VarP v) cols)] + (TH.NormalB $ pgcall f rect `TH.AppE` + (TH.ConE 'PGRecord `TH.AppE` TH.ListE (map (colenc f) cols))) + [] ] + dv <- TH.newName "x" + tv <- TH.newName "t" + ev <- TH.newName "e" + return $ + [ TH.DataD + [] + typn + [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + [ TH.RecC typn $ map (\(_, n, t, nn) -> + ( n +#if MIN_VERSION_template_haskell(2,11,0) + , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness +#else + , TH.NotStrict +#endif + , (if nn then (TH.ConT ''Maybe `TH.AppT`) else id) + (TH.ConT ''PGVal `TH.AppT` t))) + cold + ] + [] + , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) + [ tySynInstD ''PGVal typl typt + ] + , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) + [ encfun 'pgEncode + , encfun 'pgLiteral + ] + , instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) + [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.GuardedB + [ (TH.PatG [TH.BindS + (conP 'PGRecord [TH.ListP $ map colpat cols]) + (pgcall 'pgDecode rect `TH.AppE` TH.VarE dv)] + , foldl (\f -> TH.AppE f . coldec) (TH.ConE typn) cols) + , (TH.NormalG (TH.ConE 'True) + , TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL $ "pgDecode " ++ typs ++ ": NULL in not null record column")) + ]) + [] ] + ] +#if MIN_VERSION_template_haskell(2,11,0) + , TH.InstanceD (Just TH.Overlapping) [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` (TH.ConT ''Maybe `TH.AppT` typt)) + [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.GuardedB + [ (TH.PatG [TH.BindS + (conP 'PGRecord [TH.ListP $ map colpat cols]) + (pgcall 'pgDecode rect `TH.AppE` TH.VarE dv)] + , TH.ConE 'Just `TH.AppE` foldl (\f -> TH.AppE f . coldec) (TH.ConE typn) cols) + , (TH.NormalG (TH.ConE 'True) + , TH.ConE 'Nothing) + ]) + [] ] + , TH.FunD 'pgDecodeValue + [ TH.Clause [TH.WildP, TH.WildP, conP 'PGNullValue []] + (TH.NormalB $ TH.ConE 'Nothing) + [] + , TH.Clause [TH.WildP, TH.VarP tv, conP 'PGTextValue [TH.VarP dv]] + (TH.NormalB $ TH.VarE 'pgDecode `TH.AppE` TH.VarE tv `TH.AppE` TH.VarE dv) + [] + , TH.Clause [TH.VarP ev, TH.VarP tv, conP 'PGBinaryValue [TH.VarP dv]] + (TH.NormalB $ TH.VarE 'pgDecodeBinary `TH.AppE` TH.VarE ev `TH.AppE` TH.VarE tv `TH.AppE` TH.VarE dv) + [] + ] + ] +#endif + , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) + [ tySynInstD ''PGRepType typt typl + ] + , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] + , instanceD [] (TH.ConT ''PGRelation `TH.AppT` typt) + [ TH.FunD 'pgRelationName [TH.Clause [TH.WildP] + (TH.NormalB $ namelit pgtab) + [] ] + , TH.FunD 'pgColumnNames [TH.Clause [TH.WildP] + (TH.NormalB $ TH.ListE $ map (\(c, _, _, _) -> namelit c) cold) + [] ] + ] + , TH.SigD (TH.mkName ("uncurry" ++ typs)) $ TH.ArrowT `TH.AppT` + foldl (\f (_, t, n) -> f `TH.AppT` + (if n then (TH.ConT ''Maybe `TH.AppT`) else id) + (TH.ConT ''PGVal `TH.AppT` t)) + (TH.ConT (TH.tupleTypeName (length cols))) + cols `TH.AppT` typt + , TH.FunD (TH.mkName ("uncurry" ++ typs)) + [ TH.Clause [conP (TH.tupleDataName (length cols)) (map (\(v, _, _) -> TH.VarP v) cols)] + (TH.NormalB $ foldl (\f (v, _, _) -> f `TH.AppE` TH.VarE v) (TH.ConE typn) cols) + [] + ] + , TH.PragmaD $ TH.AnnP (TH.TypeAnnotation typn) $ namelit pgid + , TH.PragmaD $ TH.AnnP (TH.ValueAnnotation typn) $ namelit pgid + ] ++ map (\(c, n, _, _) -> + TH.PragmaD $ TH.AnnP (TH.ValueAnnotation n) $ namelit c) cold + where + typn = TH.mkName typs + typt = TH.ConT typn + instanceD = TH.InstanceD +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + tySynInstD c l t = TH.TySynInstD +#if MIN_VERSION_template_haskell(2,15,0) + $ TH.TySynEqn Nothing (TH.AppT (TH.ConT c) l) +#else + c $ TH.TySynEqn [l] +#endif + t + pgcall f t = TH.VarE f `TH.AppE` + (TH.ConE 'PGTypeProxy `TH.SigE` + (TH.ConT ''PGTypeID `TH.AppT` t)) + colenc f (v, t, False) = TH.ConE 'Just `TH.AppE` (pgcall f t `TH.AppE` TH.VarE v) + colenc f (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall f t `TH.AppE` TH.VarE v + colpat (v, _, False) = conP 'Just [TH.VarP v] + colpat (v, _, True) = TH.VarP v + coldec (v, t, False) = pgcall 'pgDecode t `TH.AppE` TH.VarE v + coldec (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall 'pgDecode t `TH.AppE` TH.VarE v + rect = TH.LitT $ TH.StrTyLit "record" + namelit n = TH.ConE 'PGName `TH.AppE` + TH.ListE (map (TH.LitE . TH.IntegerL . fromIntegral) $ pgNameBytes n) + conP n p = TH.ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + p diff --git a/Database/PostgreSQL/Typed/SQLToken.hs b/Database/PostgreSQL/Typed/SQLToken.hs new file mode 100644 index 0000000..bf6f99c --- /dev/null +++ b/Database/PostgreSQL/Typed/SQLToken.hs @@ -0,0 +1,131 @@ +-- | +-- Module: Database.PostgreSQL.Typed.SQLToken +-- Copyright: 2016 Dylan Simon +-- +-- Parsing of SQL statements to safely identify placeholders. +-- Supports both dollar-placeholders and question marks for HDBC. +{-# LANGUAGE PatternGuards #-} +module Database.PostgreSQL.Typed.SQLToken + ( SQLToken(..) + , sqlTokens + ) where + +import Control.Arrow (first) +import Data.Char (isDigit, isAsciiUpper, isAsciiLower) +import Data.List (stripPrefix) +import Data.String (IsString(..)) + +-- |A parsed SQL token. +data SQLToken + = SQLToken String -- ^Raw (non-markup) SQL string + | SQLParam Int -- ^A \"$N\" parameter placeholder (this is the only non-string-preserving token: \"$012\" becomes \"$12\") + | SQLExpr String -- ^A \"${expr}\" expression placeholder + | SQLQMark Bool -- ^A possibly-escaped question-mark: False for \"?\" or True for \"\\?\" + deriving (Eq) + +-- |Produces the original SQL string +instance Show SQLToken where + showsPrec _ (SQLToken s) = showString s + showsPrec _ (SQLParam p) = showChar '$' . shows p + showsPrec _ (SQLExpr e) = showString "${" . showString e . showChar '}' + showsPrec _ (SQLQMark False) = showChar '?' + showsPrec _ (SQLQMark True) = showString "\\?" + showList = flip $ foldr shows + +instance IsString SQLToken where + fromString = SQLToken + +type PH = String -> [SQLToken] + +infixr 4 ++:, +: + +(++:) :: String -> [SQLToken] -> [SQLToken] +p ++: (SQLToken q : l) = SQLToken (p ++ q) : l +p ++: l = SQLToken p : l + +(+:) :: Char -> [SQLToken] -> [SQLToken] +p +: (SQLToken q : l) = SQLToken (p : q) : l +p +: l = SQLToken [p] : l + +x :: PH +x ('-':'-':s) = "--" ++: comment s +x ('e':'\'':s) = "e'" ++: xe s +x ('E':'\'':s) = "E'" ++: xe s +x ('\'':s) = '\'' +: xq s +x ('$':'{':s) = expr s +x ('$':'$':s) = "$$" ++: xdolq "" s +x ('$':c:s) + | dolqStart c + , (t,'$':r) <- span dolqCont s + = '$' : c : t ++: '$' +: xdolq (c:t) r + | isDigit c + , (i,r) <- span isDigit s + = SQLParam (read $ c:i) : x r +x ('"':s) = '"' +: xd s +x ('/':'*':s) = "/*" ++: xc 1 s +x (c:s) + | identStart c + , (i,r) <- span identCont s + = c : i ++: x r +x ('\\':'?':s) = SQLQMark True : x s +x ('?':s) = SQLQMark False : x s +x (c:s) = c +: x s +x [] = [] + +xthru :: (Char -> Bool) -> PH +xthru f s = case break f s of + (p, c:r) -> p ++ [c] ++: x r + (p, []) -> [SQLToken p] + +comment :: PH +comment = xthru (\n -> '\n' == n || '\r' == n) + +xe :: PH +xe ('\\':c:s) = '\\' +: c +: xe s +xe ('\'':s) = '\'' +: x s +xe (c:s) = c +: xe s +xe [] = [] + +xq :: PH +xq = xthru ('\'' ==) +-- no need to handle xqdouble + +xd :: PH +xd = xthru ('\"' ==) +-- no need to handle xddouble + +identStart, identCont, dolqStart, dolqCont :: Char -> Bool +identStart c = isAsciiUpper c || isAsciiLower c || c >= '\128' && c <= '\255' || c == '_' +dolqStart = identStart +dolqCont c = dolqStart c || isDigit c +identCont c = dolqCont c || c == '$' + +xdolq :: String -> PH +xdolq t = dolq where + dolq ('$':s) + | Just r <- stripPrefix t' s = '$':t' ++: x r + dolq (c:s) = c +: dolq s + dolq [] = [] + t' = t ++ "$" + +xc :: Int -> PH +xc 0 s = x s +xc n ('/':'*':s) = "/*" ++: xc (succ n) s +xc n ('*':'/':s) = "*/" ++: xc (pred n) s +xc n (c:s) = c +: xc n s +xc _ [] = [] + +expr :: PH +expr = pr . ex (0 :: Int) where + pr (e, Nothing) = [SQLToken ("${" ++ e)] + pr (e, Just r) = SQLExpr e : r + ex 0 ('}':s) = ("", Just $ x s) + ex n ('}':s) = first ('}':) $ ex (pred n) s + ex n ('{':s) = first ('{':) $ ex (succ n) s + ex n (c:s) = first (c:) $ ex n s + ex _ [] = ("", Nothing) + +-- |Parse a SQL string into a series of tokens. +-- The 'showList' implementation for 'SQLToken' inverts this sequence back to a SQL string. +sqlTokens :: String -> [SQLToken] +sqlTokens = x diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs new file mode 100644 index 0000000..8dd9555 --- /dev/null +++ b/Database/PostgreSQL/Typed/TH.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP, PatternGuards, ScopedTypeVariables, FlexibleContexts, TemplateHaskell, DataKinds #-} +-- | +-- Module: Database.PostgreSQL.Typed.TH +-- Copyright: 2015 Dylan Simon +-- +-- Support functions for compile-time PostgreSQL connection and state management. +-- You can use these to build your own Template Haskell functions using the PostgreSQL connection. + +module Database.PostgreSQL.Typed.TH + ( getTPGDatabase + , withTPGTypeConnection + , withTPGConnection + , useTPGDatabase + , reloadTPGTypes + , TPGValueInfo(..) + , tpgDescribe + , tpgTypeEncoder + , tpgTypeDecoder + , tpgTypeBinary + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<$)) +#endif +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) +import Control.Exception (onException, finally) +#ifdef VERSION_tls +import Control.Exception (throwIO) +#endif +import Control.Monad (liftM2) +import qualified Data.ByteString as BS +#ifdef VERSION_tls +import qualified Data.ByteString.Char8 as BSC +#endif +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.Foldable as Fold +import Data.Maybe (isJust, fromMaybe) +import Data.String (fromString) +import qualified Data.Traversable as Tv +import qualified Language.Haskell.TH as TH +import qualified Network.Socket as Net +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TypeCache + +-- |Generate a 'PGDatabase' based on the environment variables: +-- @TPG_HOST@ (localhost); @TPG_SOCK@ or @TPG_PORT@ (5432); @TPG_DB@ or user; @TPG_USER@ or @USER@ (postgres); @TPG_PASS@ () +getTPGDatabase :: IO PGDatabase +getTPGDatabase = do + user <- fromMaybe "postgres" <$> liftM2 (<|>) (lookupEnv "TPG_USER") (lookupEnv "USER") + db <- fromMaybe user <$> lookupEnv "TPG_DB" + host <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" + pnum <- fromMaybe "5432" <$> lookupEnv "TPG_PORT" +#ifdef mingw32_HOST_OS + let port = Right pnum +#else + port <- maybe (Right pnum) Left <$> lookupEnv "TPG_SOCK" +#endif + pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" + debug <- isJust <$> lookupEnv "TPG_DEBUG" +#ifdef VERSION_tls + tlsEnabled <- isJust <$> lookupEnv "TPG_TLS" + tlsVerifyMode <- lookupEnv "TPG_TLS_MODE" >>= \modeStr -> + case modeStr of + Just "full" -> pure TlsValidateFull + Just "ca" -> pure TlsValidateCA + Just other -> throwIO (userError ("Unknown verify mode: " ++ other)) + Nothing -> pure TlsValidateCA + mTlsCertPem <- lookupEnv "TPG_TLS_ROOT_CERT" + dbTls <- case mTlsCertPem of + Just certPem -> + case pgTlsValidate tlsVerifyMode (BSC.pack certPem) of + Right x -> pure x + Left err -> throwIO (userError err) + Nothing | tlsEnabled -> pure TlsNoValidate + Nothing -> pure TlsDisabled +#endif + return $ defaultPGDatabase + { pgDBAddr = either (Right . Net.SockAddrUnix) (Left . (,) host) port + , pgDBName = BSU.fromString db + , pgDBUser = BSU.fromString user + , pgDBPass = BSU.fromString pass + , pgDBDebug = debug +#ifdef VERSION_tls + , pgDBTLS = dbTls +#endif + } + +{-# NOINLINE tpgState #-} +tpgState :: MVar (PGDatabase, Maybe PGTypeConnection) +tpgState = unsafePerformIO $ do + db <- unsafeInterleaveIO getTPGDatabase + newMVar (db, Nothing) + +-- |Run an action using the Template Haskell state. +withTPGTypeConnection :: (PGTypeConnection -> IO a) -> IO a +withTPGTypeConnection f = do + (db, tpg') <- takeMVar tpgState + tpg <- maybe (newPGTypeConnection =<< pgConnect db) return tpg' + `onException` putMVar tpgState (db, Nothing) -- might leave connection open + f tpg `finally` putMVar tpgState (db, Just tpg) + +-- |Run an action using the Template Haskell PostgreSQL connection. +withTPGConnection :: (PGConnection -> IO a) -> IO a +withTPGConnection f = withTPGTypeConnection (f . pgConnection) + +-- |Specify an alternative database to use during compilation. +-- This lets you override the default connection parameters that are based on TPG environment variables. +-- This should be called as a top-level declaration and produces no code. +-- It uses 'pgReconnect' so is safe to call multiple times with the same database. +useTPGDatabase :: PGDatabase -> TH.DecsQ +useTPGDatabase db = TH.runIO $ do + (db', tpg') <- takeMVar tpgState + putMVar tpgState . (,) db =<< + (if db == db' + then Tv.mapM (\t -> do + c <- pgReconnect (pgConnection t) db + return t{ pgConnection = c }) tpg' + else Nothing <$ Fold.mapM_ (pgDisconnect . pgConnection) tpg') + `onException` putMVar tpgState (db, Nothing) + return [] + +-- |Force reloading of all types from the database. +-- This may be needed if you make structural changes to the database during compile-time. +reloadTPGTypes :: TH.DecsQ +reloadTPGTypes = TH.runIO $ [] <$ withMVar tpgState (mapM_ flushPGTypeConnection . snd) + +-- |Lookup a type name by OID. +-- Error if not found. +tpgType :: PGTypeConnection -> OID -> IO PGName +tpgType c o = + maybe (fail $ "Unknown PostgreSQL type: " ++ show o ++ "\nYou may need to use reloadTPGTypes or adjust search_path, or your postgresql-typed application may need to be rebuilt.") return =<< lookupPGType c o + +-- |Lookup a type OID by type name. +-- This is less common and thus less efficient than going the other way. +-- Fail if not found. +getTPGTypeOID :: PGTypeConnection -> PGName -> IO OID +getTPGTypeOID c t = + maybe (fail $ "Unknown PostgreSQL type: " ++ show t ++ "; be sure to use the exact type name from \\dTS") return =<< findPGType c t + +data TPGValueInfo = TPGValueInfo + { tpgValueName :: BS.ByteString + , tpgValueTypeOID :: !OID + , tpgValueType :: PGName + , tpgValueNullable :: Bool + } + +-- |A type-aware wrapper to 'pgDescribe' +tpgDescribe :: BS.ByteString -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo]) +tpgDescribe sql types nulls = withTPGTypeConnection $ \tpg -> do + at <- mapM (getTPGTypeOID tpg . fromString) types + (pt, rt) <- pgDescribe (pgConnection tpg) (BSL.fromStrict sql) at nulls + (,) + <$> mapM (\o -> do + ot <- tpgType tpg o + return TPGValueInfo + { tpgValueName = BS.empty + , tpgValueTypeOID = o + , tpgValueType = ot + , tpgValueNullable = True + }) pt + <*> mapM (\(c, o, n) -> do + ot <- tpgType tpg o + return TPGValueInfo + { tpgValueName = c + , tpgValueTypeOID = o + , tpgValueType = ot + , tpgValueNullable = n && o /= 2278 -- "void" + }) rt + +typeApply :: PGName -> TH.Name -> TH.Name -> TH.Exp +typeApply t f e = + TH.VarE f `TH.AppE` TH.VarE e + `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeID `TH.AppT` TH.LitT (TH.StrTyLit $ pgNameString $ t))) + + +-- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. +tpgTypeEncoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeEncoder lit v = typeApply (tpgValueType v) $ + if lit + then 'pgEscapeParameter + else 'pgEncodeParameter + +-- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. +tpgTypeDecoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeDecoder nulls v = typeApply (tpgValueType v) $ + if nulls && tpgValueNullable v + then 'pgDecodeColumn + else 'pgDecodeColumnNotNull + +-- |TH expression calling 'pgBinaryColumn'. +tpgTypeBinary :: TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeBinary v = typeApply (tpgValueType v) 'pgBinaryColumn diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs new file mode 100644 index 0000000..88b116b --- /dev/null +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +-- Copyright 2010, 2011, 2012, 2013 Chris Forno + +-- |This module exposes the high-level Template Haskell interface for querying +-- and manipulating the PostgreSQL server. +-- +-- All SQL string arguments support expression interpolation. Just enclose your +-- expression in @{}@ in the SQL string. +-- +-- Note that transactions are messy and untested. Attempt to use them at your +-- own risk. + +module Database.PostgreSQL.Typed.TemplatePG + ( queryTuples + , queryTuple + , execute + , insertIgnore + , withTransaction + , rollback + , PGException + , pgConnect +#if !MIN_VERSION_network(2,7,0) + , PortID(..) +#endif + , PG.pgDisconnect + ) where + +import Control.Exception (catchJust) +import Control.Monad (liftM, void, guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Maybe (listToMaybe, isJust) +import qualified Language.Haskell.TH as TH +#if MIN_VERSION_network(2,7,0) +import Data.Word (Word16) +#else +import Network (PortID(..)) +#endif +#if !defined(mingw32_HOST_OS) +import qualified Network.Socket as Net +#endif +import System.Environment (lookupEnv) + +import qualified Database.PostgreSQL.Typed.Protocol as PG +import Database.PostgreSQL.Typed.Query + +-- |Convert a 'queryTuple'-style string with placeholders into a new style SQL string. +querySQL :: String -> String +querySQL ('{':s) = '$':'{':querySQL s +querySQL (c:s) = c:querySQL s +querySQL "" = "" + +-- |@queryTuples :: String -> (PGConnection -> IO [(column1, column2, ...)])@ +-- +-- Query a PostgreSQL server and return the results as a list of tuples. +-- +-- Example (where @h@ is a handle from 'pgConnect'): +-- +-- > $(queryTuples "SELECT usesysid, usename FROM pg_user") h :: IO [(Maybe String, Maybe Integer)] +queryTuples :: String -> TH.ExpQ +queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleQueryFlags $ querySQL sql) |] + +-- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ +-- +-- Convenience function to query a PostgreSQL server and return the first +-- result as a tuple. If the query produces no results, return 'Nothing'. +-- +-- Example (where @h@ is a handle from 'pgConnect'): +-- +-- > let sysid = 10::Integer; +-- > $(queryTuple "SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}") h :: IO (Maybe (Maybe String, Maybe Integer)) +queryTuple :: String -> TH.ExpQ +queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] + +-- |@execute :: String -> (PGConnection -> IO ())@ +-- +-- Convenience function to execute a statement on the PostgreSQL server. +-- +-- Example (where @h@ is a handle from 'pgConnect'): +execute :: String -> TH.ExpQ +execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleQueryFlags $ querySQL sql) |] + +-- |Run a sequence of IO actions (presumably SQL statements) wrapped in a +-- transaction. Unfortunately you're restricted to using this in the 'IO' +-- Monad for now due to the use of 'onException'. I'm debating adding a +-- 'MonadPeelIO' version. +withTransaction :: PG.PGConnection -> IO a -> IO a +withTransaction = PG.pgTransaction + +-- |Roll back a transaction. +rollback :: PG.PGConnection -> IO () +rollback h = void $ PG.pgSimpleQuery h $ BSLC.pack "ROLLBACK" + +-- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. +insertIgnore :: IO () -> IO () +insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where + uniquenessError e = guard (PG.pgErrorCode e == BSC.pack "23505") + +type PGException = PG.PGError + +#if MIN_VERSION_network(2,7,0) +-- |For backwards compatibility with old network package. +data PortID + = Service String + | PortNumber Word16 +#if !defined(mingw32_HOST_OS) + | UnixSocket String +#endif +#endif + +pgConnect :: String -- ^ the host to connect to + -> PortID -- ^ the port to connect on + -> ByteString -- ^ the database to connect to + -> ByteString -- ^ the username to connect as + -> ByteString -- ^ the password to connect with + -> IO PG.PGConnection -- ^ a handle to communicate with the PostgreSQL server on +pgConnect h n d u p = do + debug <- isJust `liftM` lookupEnv "TPG_DEBUG" + PG.pgConnect $ PG.defaultPGDatabase + { PG.pgDBAddr = case n of + PortNumber s -> Left (h, show s) + Service s -> Left (h, s) +#if !defined(mingw32_HOST_OS) + UnixSocket s -> Right (Net.SockAddrUnix s) +#endif + , PG.pgDBName = d + , PG.pgDBUser = u + , PG.pgDBPass = p + , PG.pgDBDebug = debug + } diff --git a/Database/PostgreSQL/Typed/TypeCache.hs b/Database/PostgreSQL/Typed/TypeCache.hs new file mode 100644 index 0000000..c642300 --- /dev/null +++ b/Database/PostgreSQL/Typed/TypeCache.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.PostgreSQL.Typed.TypeCache + ( PGTypes + , pgGetTypes + , PGTypeConnection + , pgConnection + , newPGTypeConnection + , flushPGTypeConnection + , lookupPGType + , findPGType + ) where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.IntMap as IntMap +import Data.List (find) + +import Database.PostgreSQL.Typed.Types (PGName, OID) +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol + +-- |Map keyed on fromIntegral OID. +type PGTypes = IntMap.IntMap PGName + +-- |A 'PGConnection' along with cached information about types. +data PGTypeConnection = PGTypeConnection + { pgConnection :: !PGConnection + , pgTypes :: IORef (Maybe PGTypes) + } + +-- |Create a 'PGTypeConnection'. +newPGTypeConnection :: PGConnection -> IO PGTypeConnection +newPGTypeConnection c = do + t <- newIORef Nothing + return $ PGTypeConnection c t + +-- |Flush the cached type list, forcing it to be reloaded. +flushPGTypeConnection :: PGTypeConnection -> IO () +flushPGTypeConnection c = + writeIORef (pgTypes c) Nothing + +-- |Get a map of types from the database. +pgGetTypes :: PGConnection -> IO PGTypes +pgGetTypes c = + IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . + snd <$> pgSimpleQuery c "SELECT oid, format_type(CASE WHEN typtype = 'd' THEN typbasetype ELSE oid END, -1) FROM pg_catalog.pg_type ORDER BY oid" + +-- |Get a cached map of types. +getPGTypes :: PGTypeConnection -> IO PGTypes +getPGTypes (PGTypeConnection c tr) = + maybe (do + t <- pgGetTypes c + writeIORef tr $ Just t + return t) + return + =<< readIORef tr + +-- |Lookup a type name by OID. +-- This is an efficient, often pure operation. +lookupPGType :: PGTypeConnection -> OID -> IO (Maybe PGName) +lookupPGType c o = + IntMap.lookup (fromIntegral o) <$> getPGTypes c + +-- |Lookup a type OID by type name. +-- This is less common and thus less efficient than going the other way. +findPGType :: PGTypeConnection -> PGName -> IO (Maybe OID) +findPGType c t = + fmap (fromIntegral . fst) . find ((==) t . snd) . IntMap.toList <$> getPGTypes c diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs new file mode 100644 index 0000000..3e738af --- /dev/null +++ b/Database/PostgreSQL/Typed/Types.hs @@ -0,0 +1,827 @@ +{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, DeriveDataTypeable #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +-- | +-- Module: Database.PostgreSQL.Typed.Types +-- Copyright: 2015 Dylan Simon +-- +-- Classes to support type inference, value encoding/decoding, and instances to support built-in PostgreSQL types. + +module Database.PostgreSQL.Typed.Types + ( + -- * Basic types + OID + , PGValue(..) + , PGValues + , PGTypeID(..) + , PGTypeEnv(..), unknownPGTypeEnv + , PGName(..), pgNameBS, pgNameString + , PGRecord(..) + + -- * Marshalling classes + , PGType(..) + , PGParameter(..) + , PGColumn(..) + , PGStringType + , PGRecordType + + -- * Marshalling interface + , pgEncodeParameter + , pgEscapeParameter + , pgDecodeColumn + , pgDecodeColumnNotNull + + -- * Conversion utilities + , pgQuote + , pgDQuote + , pgDQuoteFrom + , parsePGDQuote + , buildPGValue + ) where + +import qualified Codec.Binary.UTF8.String as UTF8 +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<$), (<*), (*>)) +#endif +import Control.Arrow ((&&&)) +#ifdef VERSION_aeson +import qualified Data.Aeson as JSON +#endif +import qualified Data.Attoparsec.ByteString as P (anyWord8) +import qualified Data.Attoparsec.ByteString.Char8 as P +import Data.Bits (shiftL, (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Prim as BSBP +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.UTF8 as BSU +import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower) +import Data.Data (Data) +import Data.Int +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty, mconcat) +#endif +import Data.Ratio ((%), numerator, denominator) +#ifdef VERSION_scientific +import Data.Scientific (Scientific) +#endif +import Data.String (IsString(..)) +#ifdef VERSION_text +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +#endif +import qualified Data.Time as Time +#if MIN_VERSION_time(1,5,0) +import Data.Time (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif +import Data.Typeable (Typeable) +#ifdef VERSION_uuid +import qualified Data.UUID as UUID +#endif +import Data.Word (Word8, Word32) +import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) +import Numeric (readFloat) +#ifdef VERSION_postgresql_binary +#if MIN_VERSION_postgresql_binary(0,12,0) +import qualified PostgreSQL.Binary.Decoding as BinD +import qualified PostgreSQL.Binary.Encoding as BinE +#else +import qualified PostgreSQL.Binary.Decoder as BinD +import qualified PostgreSQL.Binary.Encoder as BinE +#endif +#endif + +type PGTextValue = BS.ByteString +type PGBinaryValue = BS.ByteString +-- |A value passed to or from PostgreSQL in raw format. +data PGValue + = PGNullValue + | PGTextValue { pgTextValue :: PGTextValue } -- ^ The standard text encoding format (also used for unknown formats) + | PGBinaryValue { pgBinaryValue :: PGBinaryValue } -- ^ Special binary-encoded data. Not supported in all cases. + deriving (Show, Eq) +-- |A list of (nullable) data values, e.g. a single row or query parameters. +type PGValues = [PGValue] + +-- |Parameters that affect how marshalling happens. +-- Currenly we force all other relevant parameters at connect time. +-- Nothing values represent unknown. +data PGTypeEnv = PGTypeEnv + { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. + , pgServerVersion :: Maybe BS.ByteString -- ^ The @server_version@ parameter + } deriving (Show) + +unknownPGTypeEnv :: PGTypeEnv +unknownPGTypeEnv = PGTypeEnv + { pgIntegerDatetimes = Nothing + , pgServerVersion = Nothing + } + +-- |A PostgreSQL literal identifier, generally corresponding to the \"name\" type (63-byte strings), but as it would be entered in a query, so may include double-quoting for special characters or schema-qualification. +newtype PGName = PGName + { pgNameBytes :: [Word8] -- ^Raw bytes of the identifier (should really be a 'BS.ByteString', but we need a working 'Data' instance for annotations). + } + deriving (Eq, Ord, Typeable, Data) + +-- |The literal identifier as used in a query. +pgNameBS :: PGName -> BS.ByteString +pgNameBS = BS.pack . pgNameBytes + +-- |Applies utf-8 encoding. +instance IsString PGName where + fromString = PGName . UTF8.encode +-- |Unquoted 'pgNameString'. +instance Show PGName where + show = pgNameString + +-- |Reverses the 'IsString' instantce. +pgNameString :: PGName -> String +pgNameString = UTF8.decode . pgNameBytes + +-- |A proxy type for PostgreSQL types. The type argument should be an (internal) name of a database type, as per @format_type(OID)@ (usually the same as @\\dT+@). +-- When the type's namespace (schema) is not in @search_path@, this will be explicitly qualified, so you should be sure to have a consistent @search_path@ for all database connections. +-- The underlying 'Symbol' should be considered a lifted 'PGName'. +data PGTypeID (t :: Symbol) = PGTypeProxy + +-- |A valid PostgreSQL type, its metadata, and corresponding Haskell representation. +-- For conversion the other way (from Haskell type to PostgreSQL), see 'Database.PostgreSQL.Typed.Dynamic.PGRep'. +-- Unfortunately any instances of this will be orphans. +class (KnownSymbol t +#if __GLASGOW_HASKELL__ >= 800 + , PGParameter t (PGVal t), PGColumn t (PGVal t) +#endif + ) => PGType t where + -- |The default, native Haskell representation of this type, which should be as close as possible to the PostgreSQL representation. + type PGVal t :: * + -- |The string name of this type: specialized version of 'symbolVal'. + pgTypeName :: PGTypeID t -> PGName + pgTypeName = fromString . symbolVal + -- |Does this type support binary decoding? + -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type. + pgBinaryColumn :: PGTypeEnv -> PGTypeID t -> Bool + pgBinaryColumn _ _ = False + +-- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@. +class PGType t => PGParameter t a where + -- |Encode a value to a PostgreSQL text representation. + pgEncode :: PGTypeID t -> a -> PGTextValue + -- |Encode a value to a (quoted) literal value for use in SQL statements. + -- Defaults to a quoted version of 'pgEncode' + pgLiteral :: PGTypeID t -> a -> BS.ByteString + pgLiteral t = pgQuote . pgEncode t + -- |Encode a value to a PostgreSQL representation. + -- Defaults to the text representation by pgEncode + pgEncodeValue :: PGTypeEnv -> PGTypeID t -> a -> PGValue + pgEncodeValue _ t = PGTextValue . pgEncode t + +-- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@. +class PGType t => PGColumn t a where + -- |Decode the PostgreSQL text representation into a value. + pgDecode :: PGTypeID t -> PGTextValue -> a + -- |Decode the PostgreSQL binary representation into a value. + -- Only needs to be implemented if 'pgBinaryColumn' is true. + pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a + pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ show (pgTypeName t) ++ ": not supported" + pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> a + pgDecodeValue _ t (PGTextValue v) = pgDecode t v + pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v + pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ show (pgTypeName t) ++ " column (use Maybe or COALESCE)" + +instance PGParameter t a => PGParameter t (Maybe a) where + pgEncode t = maybe (error $ "pgEncode " ++ show (pgTypeName t) ++ ": Nothing") (pgEncode t) + pgLiteral = maybe (BSC.pack "NULL") . pgLiteral + pgEncodeValue e = maybe PGNullValue . pgEncodeValue e + +instance PGColumn t a => PGColumn t (Maybe a) where + pgDecode t = Just . pgDecode t + pgDecodeBinary e t = Just . pgDecodeBinary e t + pgDecodeValue _ _ PGNullValue = Nothing + pgDecodeValue e t v = Just $ pgDecodeValue e t v + +-- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. +pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> PGValue +pgEncodeParameter = pgEncodeValue + +-- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query. +pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> BS.ByteString +pgEscapeParameter _ = pgLiteral + +-- |Final column decoding function used for a nullable result value. +pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a +pgDecodeColumn = pgDecodeValue + +-- |Final column decoding function used for a non-nullable result value. +pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeID t -> PGValue -> a +pgDecodeColumnNotNull = pgDecodeValue + + +pgQuoteUnsafe :: BS.ByteString -> BS.ByteString +pgQuoteUnsafe = (`BSC.snoc` '\'') . BSC.cons '\'' + +-- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes. +pgQuote :: BS.ByteString -> BS.ByteString +pgQuote s + | '\0' `BSC.elem` s = error "pgQuote: unhandled null in literal" + | otherwise = pgQuoteUnsafe $ BSC.intercalate (BSC.pack "''") $ BSC.split '\'' s + +-- |Shorthand for @'BSL.toStrict' . 'BSB.toLazyByteString'@ +buildPGValue :: BSB.Builder -> BS.ByteString +buildPGValue = BSL.toStrict . BSB.toLazyByteString + +-- |Double-quote a value (e.g., as an identifier). +-- Does not properly handle unicode escaping (yet). +pgDQuote :: BS.ByteString -> BSB.Builder +pgDQuote s = dq <> BSBP.primMapByteStringBounded ec s <> dq where + dq = BSB.char7 '"' + ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8) + bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) + +-- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument. +pgDQuoteFrom :: [Char] -> BS.ByteString -> BSB.Builder +pgDQuoteFrom unsafe s + | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" = pgDQuote s + | otherwise = BSB.byteString s + +-- |Parse double-quoted values ala 'pgDQuote'. +parsePGDQuote :: Bool -> [Char] -> (BS.ByteString -> Bool) -> P.Parser (Maybe BS.ByteString) +parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where + q = P.char '"' *> (BS.concat <$> qs) + qs = do + p <- P.takeTill (\c -> c == '"' || c == '\\') + e <- P.anyChar + if e == '"' + then return [p] + else do + c <- P.anyWord8 + (p :) . (BS.singleton c :) <$> qs + uq = (if blank then P.takeWhile else P.takeWhile1) (`notElem` ('"':'\\':unsafe)) + mnul s + | isnul s = Nothing + | otherwise = Just s + +#ifdef VERSION_postgresql_binary +binEnc :: BinEncoder a -> a -> BS.ByteString +binEnc = (.) +#if MIN_VERSION_postgresql_binary(0,12,0) + BinE.encodingBytes + +type BinDecoder = BinD.Value +type BinEncoder a = a -> BinE.Encoding +#else + buildPGValue + +type BinDecoder = BinD.Decoder +type BinEncoder a = BinE.Encoder a +#endif + +binDec :: PGType t => BinDecoder a -> PGTypeID t -> PGBinaryValue -> a +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ show (pgTypeName t) ++ ": " ++ show e) id . +#if MIN_VERSION_postgresql_binary(0,12,0) + BinD.valueParser +#else + BinD.run +#endif + d + +#define BIN_COL pgBinaryColumn _ _ = True +#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . binEnc (F) +#define BIN_DEC(F) pgDecodeBinary _ = binDec (F) +#else +#define BIN_COL +#define BIN_ENC(F) +#define BIN_DEC(F) +#endif + +instance PGType "any" where + type PGVal "any" = PGValue +instance PGType t => PGColumn t PGValue where + pgDecode _ = PGTextValue + pgDecodeBinary _ _ = PGBinaryValue + pgDecodeValue _ _ = id +instance PGParameter "any" PGValue where + pgEncode _ (PGTextValue v) = v + pgEncode _ PGNullValue = error "pgEncode any: NULL" + pgEncode _ (PGBinaryValue _) = error "pgEncode any: binary" + pgEncodeValue _ _ = id + +instance PGType "void" where + type PGVal "void" = () +instance PGParameter "void" () where + pgEncode _ _ = BSC.empty +instance PGColumn "void" () where + pgDecode _ _ = () + pgDecodeBinary _ _ _ = () + pgDecodeValue _ _ _ = () + +instance PGType "boolean" where + type PGVal "boolean" = Bool + BIN_COL +instance PGParameter "boolean" Bool where + pgEncode _ False = BSC.singleton 'f' + pgEncode _ True = BSC.singleton 't' + pgLiteral _ False = BSC.pack "false" + pgLiteral _ True = BSC.pack "true" + BIN_ENC(BinE.bool) +instance PGColumn "boolean" Bool where + pgDecode _ s = case BSC.head s of + 'f' -> False + 't' -> True + c -> error $ "pgDecode boolean: " ++ [c] + BIN_DEC(BinD.bool) + +type OID = Word32 +instance PGType "oid" where + type PGVal "oid" = OID + BIN_COL +instance PGParameter "oid" OID where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.int4_word32) +instance PGColumn "oid" OID where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.int) + +instance PGType "smallint" where + type PGVal "smallint" = Int16 + BIN_COL +instance PGParameter "smallint" Int16 where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.int2_int16) +instance PGColumn "smallint" Int16 where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.int) + +instance PGType "integer" where + type PGVal "integer" = Int32 + BIN_COL +instance PGParameter "integer" Int32 where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.int4_int32) +instance PGColumn "integer" Int32 where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.int) + +instance PGType "bigint" where + type PGVal "bigint" = Int64 + BIN_COL +instance PGParameter "bigint" Int64 where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.int8_int64) +instance PGColumn "bigint" Int64 where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.int) + +instance PGType "real" where + type PGVal "real" = Float + BIN_COL +instance PGParameter "real" Float where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.float4) +instance PGColumn "real" Float where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.float4) +instance PGColumn "real" Double where + pgDecode _ = read . BSC.unpack + BIN_DEC(realToFrac <$> BinD.float4) + +instance PGType "double precision" where + type PGVal "double precision" = Double + BIN_COL +instance PGParameter "double precision" Double where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.float8) +instance PGParameter "double precision" Float where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.float8 . realToFrac) +instance PGColumn "double precision" Double where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.float8) + +-- XXX need real encoding as text +-- but then no one should be using this type really... +instance PGType "\"char\"" where + type PGVal "\"char\"" = Word8 + BIN_COL +instance PGParameter "\"char\"" Word8 where + pgEncode _ = BS.singleton + pgEncodeValue _ _ = PGBinaryValue . BS.singleton +instance PGColumn "\"char\"" Word8 where + pgDecode _ = BS.head + pgDecodeBinary _ _ = BS.head +instance PGParameter "\"char\"" Char where + pgEncode _ = BSC.singleton + pgEncodeValue _ _ = PGBinaryValue . BSC.singleton +instance PGColumn "\"char\"" Char where + pgDecode _ = BSC.head + pgDecodeBinary _ _ = BSC.head + + +class PGType t => PGStringType t + +instance PGStringType t => PGParameter t String where + pgEncode _ = BSU.fromString + BIN_ENC(BinE.text_strict . T.pack) +instance PGStringType t => PGColumn t String where + pgDecode _ = BSU.toString + BIN_DEC(T.unpack <$> BinD.text_strict) + +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGParameter t BS.ByteString where + pgEncode _ = id + BIN_ENC(BinE.text_strict . TE.decodeUtf8) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGColumn t BS.ByteString where + pgDecode _ = id + BIN_DEC(TE.encodeUtf8 <$> BinD.text_strict) + +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGParameter t PGName where + pgEncode _ = pgNameBS + BIN_ENC(BinE.text_strict . TE.decodeUtf8 . pgNameBS) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGColumn t PGName where + pgDecode _ = PGName . BS.unpack + BIN_DEC(PGName . BS.unpack . TE.encodeUtf8 <$> BinD.text_strict) + +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGParameter t BSL.ByteString where + pgEncode _ = BSL.toStrict + BIN_ENC(BinE.text_lazy . TLE.decodeUtf8) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGColumn t BSL.ByteString where + pgDecode _ = BSL.fromStrict + BIN_DEC(TLE.encodeUtf8 <$> BinD.text_lazy) + +#ifdef VERSION_text +instance PGStringType t => PGParameter t T.Text where + pgEncode _ = TE.encodeUtf8 + BIN_ENC(BinE.text_strict) +instance PGStringType t => PGColumn t T.Text where + pgDecode _ = TE.decodeUtf8 + BIN_DEC(BinD.text_strict) + +instance PGStringType t => PGParameter t TL.Text where + pgEncode _ = BSL.toStrict . TLE.encodeUtf8 + BIN_ENC(BinE.text_lazy) +instance PGStringType t => PGColumn t TL.Text where + pgDecode _ = TL.fromStrict . TE.decodeUtf8 + BIN_DEC(BinD.text_lazy) +#define PGVALSTRING T.Text +#else +#define PGVALSTRING String +#endif + +instance PGType "text" where + type PGVal "text" = PGVALSTRING + BIN_COL +instance PGType "character varying" where + type PGVal "character varying" = PGVALSTRING + BIN_COL +instance PGType "name" where + type PGVal "name" = PGVALSTRING + BIN_COL +instance PGType "bpchar" where + type PGVal "bpchar" = PGVALSTRING + BIN_COL +instance PGStringType "text" +instance PGStringType "character varying" +instance PGStringType "name" -- limit 63 characters; not strictly textsend but essentially the same +instance PGStringType "bpchar" -- blank padded + + +encodeBytea :: BSB.Builder -> PGTextValue +encodeBytea h = buildPGValue $ BSB.string7 "\\x" <> h + +decodeBytea :: PGTextValue -> [Word8] +decodeBytea s + | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm + | otherwise = pd $ BS.unpack d where + (m, d) = BS.splitAt 2 s + sm = BSC.unpack m + pd [] = [] + pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r + pd [x] = error $ "pgDecode bytea: " ++ show x + unhex = fromIntegral . digitToInt . w2c + +instance PGType "bytea" where + type PGVal "bytea" = BS.ByteString + BIN_COL +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGParameter "bytea" BSL.ByteString where + pgEncode _ = encodeBytea . BSB.lazyByteStringHex + pgLiteral t = pgQuoteUnsafe . pgEncode t + BIN_ENC(BinE.bytea_lazy) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGColumn "bytea" BSL.ByteString where + pgDecode _ = BSL.pack . decodeBytea + BIN_DEC(BinD.bytea_lazy) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGParameter "bytea" BS.ByteString where + pgEncode _ = encodeBytea . BSB.byteStringHex + pgLiteral t = pgQuoteUnsafe . pgEncode t + BIN_ENC(BinE.bytea_strict) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGColumn "bytea" BS.ByteString where + pgDecode _ = BS.pack . decodeBytea + BIN_DEC(BinD.bytea_strict) + +readTime :: Time.ParseTime t => String -> String -> t +readTime = +#if MIN_VERSION_time(1,5,0) + Time.parseTimeOrError False +#else + Time.readTime +#endif + defaultTimeLocale + +instance PGType "date" where + type PGVal "date" = Time.Day + BIN_COL +instance PGParameter "date" Time.Day where + pgEncode _ = BSC.pack . Time.showGregorian + pgLiteral t = pgQuoteUnsafe . pgEncode t + BIN_ENC(BinE.date) +instance PGColumn "date" Time.Day where + pgDecode _ = readTime "%F" . BSC.unpack + BIN_DEC(BinD.date) + +binColDatetime :: PGTypeEnv -> PGTypeID t -> Bool +#ifdef VERSION_postgresql_binary +binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True +#endif +binColDatetime _ _ = False + +#ifdef VERSION_postgresql_binary +binEncDatetime :: PGParameter t a => BinEncoder a -> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue +binEncDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } _ = PGBinaryValue . binEnc ff +binEncDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } _ = PGBinaryValue . binEnc fi +binEncDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } t = PGTextValue . pgEncode t + +binDecDatetime :: PGColumn t a => BinDecoder a -> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a +binDecDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } = binDec ff +binDecDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } = binDec fi +binDecDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } = error "pgDecodeBinary: unknown integer_datetimes value" +#endif + +-- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. +-- readTime can successfully parse both formats, but PostgreSQL needs the colon. +fixTZ :: String -> String +fixTZ "" = "" +fixTZ ['+',h1,h2] | isDigit h1 && isDigit h2 = ['+',h1,h2,':','0','0'] +fixTZ ['-',h1,h2] | isDigit h1 && isDigit h2 = ['-',h1,h2,':','0','0'] +fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['+',h1,h2,':',m1,m2] +fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2] +fixTZ (c:s) = c:fixTZ s + +instance PGType "time without time zone" where + type PGVal "time without time zone" = Time.TimeOfDay + pgBinaryColumn = binColDatetime +instance PGParameter "time without time zone" Time.TimeOfDay where + pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" + pgLiteral t = pgQuoteUnsafe . pgEncode t +#ifdef VERSION_postgresql_binary + pgEncodeValue = binEncDatetime BinE.time_int BinE.time_float +#endif +instance PGColumn "time without time zone" Time.TimeOfDay where + pgDecode _ = readTime "%T%Q" . BSC.unpack +#ifdef VERSION_postgresql_binary + pgDecodeBinary = binDecDatetime BinD.time_int BinD.time_float +#endif + +instance PGType "time with time zone" where + type PGVal "time with time zone" = (Time.TimeOfDay, Time.TimeZone) + pgBinaryColumn = binColDatetime +instance PGParameter "time with time zone" (Time.TimeOfDay, Time.TimeZone) where + pgEncode _ (t, z) = BSC.pack $ Time.formatTime defaultTimeLocale "%T%Q" t ++ fixTZ (Time.formatTime defaultTimeLocale "%z" z) + pgLiteral t = pgQuoteUnsafe . pgEncode t +#ifdef VERSION_postgresql_binary + pgEncodeValue = binEncDatetime BinE.timetz_int BinE.timetz_float +#endif +instance PGColumn "time with time zone" (Time.TimeOfDay, Time.TimeZone) where + pgDecode _ = (Time.localTimeOfDay . Time.zonedTimeToLocalTime &&& Time.zonedTimeZone) . readTime "%T%Q%z" . fixTZ . BSC.unpack +#ifdef VERSION_postgresql_binary + pgDecodeBinary = binDecDatetime BinD.timetz_int BinD.timetz_float +#endif + +instance PGType "timestamp without time zone" where + type PGVal "timestamp without time zone" = Time.LocalTime + pgBinaryColumn = binColDatetime +instance PGParameter "timestamp without time zone" Time.LocalTime where + pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" + pgLiteral t = pgQuoteUnsafe . pgEncode t +#ifdef VERSION_postgresql_binary + pgEncodeValue = binEncDatetime BinE.timestamp_int BinE.timestamp_float +#endif +instance PGColumn "timestamp without time zone" Time.LocalTime where + pgDecode _ = readTime "%F %T%Q" . BSC.unpack +#ifdef VERSION_postgresql_binary + pgDecodeBinary = binDecDatetime BinD.timestamp_int BinD.timestamp_float +#endif + +instance PGType "timestamp with time zone" where + type PGVal "timestamp with time zone" = Time.UTCTime + pgBinaryColumn = binColDatetime +instance PGParameter "timestamp with time zone" Time.UTCTime where + pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" + -- pgLiteral t = pgQuoteUnsafe . pgEncode t +#ifdef VERSION_postgresql_binary + pgEncodeValue = binEncDatetime BinE.timestamptz_int BinE.timestamptz_float +#endif +instance PGColumn "timestamp with time zone" Time.UTCTime where + pgDecode _ = readTime "%F %T%Q%z" . fixTZ . BSC.unpack +#ifdef VERSION_postgresql_binary + pgDecodeBinary = binDecDatetime BinD.timestamptz_int BinD.timestamptz_float +#endif + +instance PGType "interval" where + type PGVal "interval" = Time.DiffTime + pgBinaryColumn = binColDatetime +instance PGParameter "interval" Time.DiffTime where + pgEncode _ = BSC.pack . show + pgLiteral t = pgQuoteUnsafe . pgEncode t +#ifdef VERSION_postgresql_binary + pgEncodeValue = binEncDatetime BinE.interval_int BinE.interval_float +#endif +-- |Representation of DiffTime as interval. +-- PostgreSQL stores months and days separately in intervals, but DiffTime does not. +-- We collapse all interval fields into seconds +instance PGColumn "interval" Time.DiffTime where + pgDecode _ a = either (error . ("pgDecode interval (" ++) . (++ ("): " ++ BSC.unpack a))) realToFrac $ P.parseOnly ps a where + ps = do + _ <- P.char 'P' + d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)] + ((d +) <$> pt) <> (d <$ P.endOfInput) + pt = do + _ <- P.char 'T' + t <- units [('H', 3600), ('M', 60), ('S', 1)] + P.endOfInput + return t + units l = fmap sum $ P.many' $ do + x <- P.signed P.scientific + u <- P.choice $ map (\(c, u) -> u <$ P.char c) l + return $ x * u + day = 86400 + month = 2629746 +#ifdef VERSION_postgresql_binary + pgDecodeBinary = binDecDatetime BinD.interval_int BinD.interval_float +#endif + +instance PGType "numeric" where + type PGVal "numeric" = +#ifdef VERSION_scientific + Scientific +#else + Rational +#endif + BIN_COL +instance PGParameter "numeric" Rational where + pgEncode _ r + | denominator r == 0 = BSC.pack "NaN" -- this can't happen + | otherwise = BSC.pack $ take 30 (showRational (r / (10 ^^ e))) ++ 'e' : show e where + e = floor $ logBase (10 :: Double) $ fromRational $ abs r :: Int -- not great, and arbitrarily truncate somewhere + pgLiteral _ r + | denominator r == 0 = BSC.pack "'NaN'" -- this can't happen + | otherwise = BSC.pack $ '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" + BIN_ENC(BinE.numeric . realToFrac) +-- |High-precision representation of Rational as numeric. +-- Unfortunately, numeric has an NaN, while Rational does not. +-- NaN numeric values will produce exceptions. +instance PGColumn "numeric" Rational where + pgDecode _ bs + | s == "NaN" = 0 % 0 -- this won't work + | otherwise = ur $ readFloat s where + ur [(x,"")] = x + ur _ = error $ "pgDecode numeric: " ++ s + s = BSC.unpack bs + BIN_DEC(realToFrac <$> BinD.numeric) + +-- This will produce infinite(-precision) strings +showRational :: Rational -> String +showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where + (ri, rf) = properFraction r + frac 0 = "" + frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) + +#ifdef VERSION_scientific +instance PGParameter "numeric" Scientific where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.numeric) +instance PGColumn "numeric" Scientific where + pgDecode _ = read . BSC.unpack + BIN_DEC(BinD.numeric) +#endif + +#ifdef VERSION_uuid +instance PGType "uuid" where + type PGVal "uuid" = UUID.UUID + BIN_COL +instance PGParameter "uuid" UUID.UUID where + pgEncode _ = UUID.toASCIIBytes + pgLiteral t = pgQuoteUnsafe . pgEncode t + BIN_ENC(BinE.uuid) +instance PGColumn "uuid" UUID.UUID where + pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u + BIN_DEC(BinD.uuid) +#endif + +-- |Generic class of composite (row or record) types. +newtype PGRecord = PGRecord [Maybe PGTextValue] +class PGType t => PGRecordType t +instance PGRecordType t => PGParameter t PGRecord where + pgEncode _ (PGRecord l) = + buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuoteFrom "(),")) l) <> BSB.char7 ')' + pgLiteral _ (PGRecord l) = + BSC.pack "ROW(" <> BS.intercalate (BSC.singleton ',') (map (maybe (BSC.pack "NULL") pgQuote) l) `BSC.snoc` ')' +instance PGRecordType t => PGColumn t PGRecord where + pgDecode _ a = either (error . ("pgDecode record (" ++) . (++ ("): " ++ BSC.unpack a))) PGRecord $ P.parseOnly pa a where + pa = P.char '(' *> P.sepBy el (P.char ',') <* P.char ')' <* P.endOfInput + el = parsePGDQuote True "()," BS.null + +instance PGType "record" where + type PGVal "record" = PGRecord +-- |The generic anonymous record type, as created by @ROW@. +-- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). +instance PGRecordType "record" + +#ifdef VERSION_aeson +instance PGType "json" where + type PGVal "json" = JSON.Value + BIN_COL +instance PGParameter "json" JSON.Value where + pgEncode _ = BSL.toStrict . JSON.encode + BIN_ENC(BinE.json_ast) +instance PGColumn "json" JSON.Value where + pgDecode _ j = either (error . ("pgDecode json (" ++) . (++ ("): " ++ BSC.unpack j))) id $ JSON.eitherDecodeStrict j + BIN_DEC(BinD.json_ast) + +instance PGType "jsonb" where + type PGVal "jsonb" = JSON.Value + BIN_COL +instance PGParameter "jsonb" JSON.Value where + pgEncode _ = BSL.toStrict . JSON.encode + BIN_ENC(BinE.jsonb_ast) +instance PGColumn "jsonb" JSON.Value where + pgDecode _ j = either (error . ("pgDecode jsonb (" ++) . (++ ("): " ++ BSC.unpack j))) id $ JSON.eitherDecodeStrict j + BIN_DEC(BinD.jsonb_ast) +#endif + +{- +--, ( 142, 143, "xml", ?) +--, ( 600, 1017, "point", ?) +--, ( 650, 651, "cidr", ?) +--, ( 790, 791, "money", Centi? Fixed?) +--, ( 829, 1040, "macaddr", ?) +--, ( 869, 1041, "inet", ?) +--, (1266, 1270, "timetz", ?) +--, (1560, 1561, "bit", Bool?) +--, (1562, 1563, "varbit", ?) +-} diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs deleted file mode 100644 index 8aeef1b..0000000 --- a/Database/TemplatePG.hs +++ /dev/null @@ -1,165 +0,0 @@ --- Copyright 2010, 2011, 2012, 2013 Chris Forno - -module Database.TemplatePG (-- *Introduction - -- $intro - - -- *Usage - -- $usage - - -- **Compile-Time Parameters - -- $compiletime - - -- *Caveats - -- $caveats - - -- *Limitations and Workarounds - -- **A Note About NULL - -- $nulls - - -- **Tips - -- $tips - - -- **Other Workarounds - -- $other - PGException(..) - , pgConnect - , pgDisconnect - , queryTuples - , queryTuple - , execute - , withTransaction - , rollback - , insertIgnore ) where - -import Database.TemplatePG.Protocol -import Database.TemplatePG.SQL - --- $intro --- TemplatePG is designed with 2 goals in mind: safety and performance. The --- primary focus is on safety. --- --- To help ensure safety, it uses the PostgreSQL server to parse every query --- and statement in your code to infer types at compile-time. This means that --- in theory you cannot get a syntax error at runtime. Getting proper types at --- compile time has the nice side-effect that it eliminates run-time type --- casting and usually results in less code. This approach was inspired by --- MetaHDBC () and PG'OCaml --- (). --- --- While compile-time query analysis eliminates many errors, it doesn't --- eliminate all of them. If you modify the database without recompilation or --- have an error in a trigger or function, for example, you can still trigger a --- 'PGException'. --- --- With that in mind, TemplatePG currently does a number of unsafe things. It --- doesn't properly close the connection with the PostgreSQL server. It doesn't --- handle unexpected messages from the server very gracefully, and it's not --- entirely safe when working with nullable result fields. I hope to fix all of --- these at some point in the future. In the meantime, use the software at your --- own risk. Note however that TemplatePG is currently powering --- with no problems yet. (For usage examples, you --- can see the Vocabulink source code at ). --- --- To improve performance, TemplatePG does not use prepared statements. In --- theory, this saves bandwidth (and a potential round-trip) and time for the --- extra step of binding parameters. Again in theory, this is also safe because --- we know the types of parameters at compile time. However, it still feels --- risky (and I would appreciate any audit of the code doing this, especially --- 'escapeString'). - --- $usage --- 'queryTuples' does all the work ('queryTuple' and 'execute' are convenience --- functions). --- --- It's a Template Haskell function, so you need to splice it into your program --- with @$()@. It requires a 'Handle' to a PostgreSQL server, but can't be --- given one at compile-time, so you need to pass it after the splice: --- --- @h <- pgConnect ... --- --- tuples <- $(queryTuples \"SELECT * FROM pg_database\") h --- @ --- --- To pass parameters to a query, include them in the string with {}. Most --- Haskell expressions should work. For example: --- --- @let owner = 33 --- --- tuples <- $(queryTuples \"SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3}\") h --- @ --- --- Note that parameters may only be used where PostgreSQL will allow them. This --- will not work: --- --- @tuples <- $(queryTuples \"SELECT * FROM {tableName}\") h@ --- --- And in general, you cannot construct queries at run-time, since they --- wouldn't be available to be analyzed at compile time. - --- $compiletime --- TemplatePG needs information about the database to connect to at compile --- time (in the form of environment variables). --- --- You must set at least @TPG_DB@: --- --- [@TPG_DB@] the database name to use --- --- [@TPG_USER@] the username to connect as (default: @postgres@) --- --- [@TPG_PASS@] the password to use (default: /empty/) --- --- [@TPG_HOST@] the host to connect to (default: @localhost@) --- --- [@TPG_PORT@] the port number to connect on (default: @5432@) --- --- You can set @TPG_DEBUG@ to get a rough protocol-level trace (pipe to --- @hexdump@). - --- $caveats --- TemplatePG assumes that it has a UTF-8 connection to a UTF-8 database. --- --- TemplatePG does not bind parameters with prepared statements (at run-time), --- instead it relies on its own type conversion and string escaping. The --- technique might have a security vulnerability. You should also set --- @standard_conforming_strings = on@ in your @postgresql.conf@. --- --- I've included 'withTransaction', 'rollback', and 'insertIgnore', but they've --- not been thoroughly tested, so use them at your own risk. - --- $nulls --- Sometimes TemplatePG cannot determine whether or not a result field can --- potentially be @NULL@. In those cases it will assume that it can. Basically, --- any time a result field is not immediately tracable to an originating table --- and column (such as when a function is applied to a result column), it's --- assumed to be nullable and will be returned as a 'Maybe' value. --- --- Additionally, you cannot directly use @NULL@ values in parameters. As a --- workaround, you might have to use 2 or more separate queries (and @DEFAULT --- NULL@) to @INSERT@ rows with @NULL@s. --- --- Nullability is indicated incorrectly in the case of outer joins. TemplatePG --- incorrectly infers that a field cannot be @NULL@ when it's able to trace the --- result field back to a non-@NULL@ table column. As a workround, you can wrap --- columns with @COALESCE()@ to force them to be returned as 'Maybe' values. --- --- Because TemplatePG has to prepare statements at compile time and --- placeholders can't be used in place of lists in PostgreSQL (such as @IN --- (?)@), it's not currently possible to use non-static @IN ()@ clauses. - --- $other --- There's no support for reading time intervals yet. As a workaround, you can --- use @extract(epoch from ...)::int@ to get the interval as a number of --- seconds. - --- $tips --- If you find yourself pattern matching on result tuples just to pass them on --- to functions, you can use @uncurryN@ from the tuple package. The following --- examples are equivalent. --- --- @(a, b, c) <- $(queryTuple \"SELECT a, b, c FROM {tableName} LIMIT 1\") --- --- someFunction a b c --- @ --- --- @uncurryN someFunction \`liftM\` $(queryTuple \"SELECT a, b, c FROM {tableName} LIMIT 1\") --- @ diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs deleted file mode 100644 index b76d5b3..0000000 --- a/Database/TemplatePG/Protocol.hs +++ /dev/null @@ -1,358 +0,0 @@ --- Copyright 2010, 2011, 2012, 2013 Chris Forno - --- |The Protocol module allows for direct, low-level communication with a --- PostgreSQL server over TCP/IP. You probably don't want to use this module --- directly. - -module Database.TemplatePG.Protocol ( PGException(..) - , pgConnect - , pgDisconnect - , describeStatement - , executeSimpleQuery - , executeSimpleStatement - ) where - -import Database.TemplatePG.Types - -import Control.Exception -import Control.Monad (liftM, replicateM) -import Data.Binary -import qualified Data.Binary.Builder as B -import qualified Data.Binary.Get as G -import qualified Data.Binary.Put as P -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.ByteString.Lazy as L hiding (take, repeat, map, any, zipWith) -import Data.ByteString.Lazy.UTF8 hiding (length, decode, take) -import Data.Monoid -import Data.Typeable -import Network -import System.Environment -import System.IO hiding (putStr, putStrLn) -import System.IO.Error (isDoesNotExistError) - -import Prelude hiding (putStr, putStrLn) - --- |PGMessage represents a PostgreSQL protocol message that we'll either send --- or receive. See --- . -data PGMessage = Authentication - | BackendKeyData - -- |CommandComplete is bare for now, although it could be made - -- to contain the number of rows affected by statements in a - -- later version. - | CommandComplete - -- |Each DataRow (result of a query) is a list of ByteStrings - -- (or just Nothing for null values, to distinguish them from - -- emtpy strings). The ByteStrings can then be converted to - -- the appropriate type by 'pgStringToType'. - | DataRow [Maybe ByteString] - -- |Describe a SQL query/statement. The SQL string can contain - -- parameters ($1, $2, etc.). - | Describe String - | EmptyQueryResponse - -- |An ErrorResponse contains the severity, "SQLSTATE", and - -- message of an error. See - -- . - | ErrorResponse String String String - | Execute - | Flush - | NoData - | NoticeResponse - -- |A ParameterDescription describes the type of a given SQL - -- query/statement parameter ($1, $2, etc.). Unfortunately, - -- PostgreSQL does not give us nullability information for the - -- parameter. - | ParameterDescription [PGType] - | ParameterStatus - -- |Parse SQL Destination (prepared statement) - | Parse String String - | ParseComplete - | ReadyForQuery - -- |A RowDescription contains the name, type, table OID, and - -- column number of the resulting columns(s) of a query. The - -- column number is useful for inferring nullability. - | RowDescription [(String, PGType, Integer, Int)] - -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, - -- etc.) aren't allowed. - | SimpleQuery String - | UnknownMessage - --- |PGException is thrown upon encountering an 'ErrorResponse' with severity of --- ERROR, FATAL, or PANIC. It holds the SQLSTATE and message of the error. -data PGException = PGException String String - deriving (Show, Typeable) - -instance Exception PGException - -protocolVersion :: Word32 -protocolVersion = 0x30000 - --- |Determine whether or not to print debug output based on the value of the --- TPG_DEBUG environment variable. -debug :: IO (Bool) -debug = catchJust (\e -> if isDoesNotExistError e - then Just () - else Nothing) - (getEnv "TPG_DEBUG" >> return True) (\ _ -> return False) - --- |Connect to a PostgreSQL server. -pgConnect :: HostName -- ^ the host to connect to - -> PortID -- ^ the port to connect on - -> String -- ^ the database to connect to - -> String -- ^ the username to connect as - -> String -- ^ the password to connect with - -> IO Handle -- ^ a handle to communicate with the PostgreSQL server on -pgConnect host port db user _ = do - h <- connectTo host port - hPut h $ B.toLazyByteString $ pgMessage handshake - hFlush h - _ <- pgWaitFor h [pgMessageID ReadyForQuery] - return h - -- These are here since the handshake message differs a bit from other - -- messages (it's missing the inital identifying character). I could probably - -- get rid of it with some refactoring. - where handshake = mconcat - [ B.putWord32be protocolVersion - , pgString "user", pgString user - , pgString "database", pgString db - , B.singleton 0 ] - pgMessage :: B.Builder -> B.Builder - pgMessage msg = B.append len msg - where len = B.putWord32be $ fromIntegral $ (L.length $ B.toLazyByteString msg) + 4 - --- |Disconnect from a PostgreSQL server. Note that this currently doesn't send --- a close message. -pgDisconnect :: Handle -- ^ a handle from 'pgConnect' - -> IO () -pgDisconnect = hClose - --- |Convert a string to a NULL-terminated UTF-8 string. The PostgreSQL --- protocol transmits most strings in this format. --- I haven't yet found a function for doing this without requiring manual --- memory management. -pgString :: String -> B.Builder -pgString = B.fromLazyByteString . flip snoc 0 . fromString - -pgMessageID :: PGMessage -> Word8 -pgMessageID m = c2w $ case m of - Authentication -> 'R' - BackendKeyData -> 'K' - CommandComplete -> 'C' - (DataRow _) -> 'D' - (Describe _) -> 'D' - EmptyQueryResponse -> 'I' - (ErrorResponse _ _ _) -> 'E' - Execute -> 'E' - Flush -> 'H' - NoData -> 'n' - NoticeResponse -> 'N' - (ParameterDescription _) -> 't' - ParameterStatus -> 'S' - (Parse _ _) -> 'P' - ParseComplete -> '1' - ReadyForQuery -> 'Z' - (RowDescription _) -> 'T' - (SimpleQuery _) -> 'Q' - UnknownMessage -> error "Unknown message type" - --- |All PostgreSQL messages have a common header: an identifying character and --- a 32-bit size field. -instance Binary PGMessage where - -- |Putting a message automatically adds the necessary message type and - -- message size fields. - put m = do - let body = B.toLazyByteString $ putMessageBody m - P.putWord8 $ pgMessageID m - P.putWord32be $ fromIntegral $ (L.length body) + 4 - P.putLazyByteString body - -- |Getting a message takes care of reading the message type and message size - -- and ensures that just the necessary amount is read and given to - -- 'getMessageBody' (so that if a 'getMessageBody' parser doesn't read the - -- entire message it doesn't leave data to interfere with later messages). - get = do - (typ, len) <- getMessageHeader - body <- G.getLazyByteString ((fromIntegral len) - 4) - return $ G.runGet (getMessageBody typ) body - --- |Given a message, build the over-the-wire representation of it. Note that we --- send fewer messages than we receive. -putMessageBody :: PGMessage -> B.Builder -putMessageBody (Describe n) = mconcat [B.singleton $ c2w 'S', pgString n] -putMessageBody Execute = mconcat [pgString "", B.putWord32be 0] -putMessageBody Flush = B.empty -putMessageBody (Parse s n) = mconcat [pgString n, pgString s, B.putWord16be 0] -putMessageBody (SimpleQuery s) = pgString s -putMessageBody _ = undefined - --- |Get the type and size of an incoming message. -getMessageHeader :: Get (Word8, Int) -getMessageHeader = do - typ <- G.getWord8 - len <- G.getWord32be - return (typ, fromIntegral len) - --- |Parse an incoming message. -getMessageBody :: Word8 -- ^ the type of the message to parse - -> Get PGMessage -getMessageBody typ = - case w2c typ of - 'R' -> do return Authentication - 't' -> do numParams <- fromIntegral `liftM` G.getWord16be - ps <- replicateM numParams readParam - return $ ParameterDescription ps - where readParam = do typ' <- fromIntegral `liftM` G.getWord32be - return $ pgTypeFromOID typ' - 'T' -> do numFields <- fromIntegral `liftM` G.getWord16be - ds <- replicateM numFields readField - return $ RowDescription ds - where readField = do name <- toString `liftM` G.getLazyByteStringNul - oid <- fromIntegral `liftM` G.getWord32be -- table OID - col <- fromIntegral `liftM` G.getWord16be -- column number - typ' <- fromIntegral `liftM` G.getWord32be -- type - _ <- G.getWord16be -- type size - _ <- G.getWord32be -- type modifier - _ <- G.getWord16be -- format code - return (name, pgTypeFromOID typ', oid, col) - 'Z' -> G.getWord8 >> return ReadyForQuery - '1' -> return ParseComplete - 'C' -> return CommandComplete - 'S' -> return ParameterStatus - 'D' -> do numFields <- fromIntegral `liftM` G.getWord16be - ds <- replicateM numFields readField - return $ DataRow ds - where readField = do len <- fromIntegral `liftM` G.getWord32be - s <- case len of - 0xFFFFFFFF -> return Nothing - _ -> Just `liftM` G.getLazyByteString len - return s - 'K' -> return BackendKeyData - 'E' -> do fs <- readFields - case (lookup (c2w 'S') fs, - lookup (c2w 'C') fs, - lookup (c2w 'M') fs) of - (Just s, Just c, Just m) -> return $ ErrorResponse s c m - _ -> error "Unreadable error response" - where readFields :: Get [(Word8, String)] - readFields = do f <- G.getWord8 - case f of - 0 -> return [] - _ -> do s <- G.getLazyByteStringNul - f' <- readFields - return ((f,toString s):f') - 'I' -> return EmptyQueryResponse - 'n' -> return NoData - 'N' -> return NoticeResponse -- Ignore the notice body for now. - _ -> return UnknownMessage - --- |Send a message to PostgreSQL (low-level). -pgSend :: Handle -> PGMessage -> IO () -pgSend h msg = do - d <- debug - if d then B8.putStrLn (encode msg) else return () - hPut h (encode msg) >> hFlush h - --- |Receive the next message from PostgreSQL (low-level). Note that this will --- block until it gets a message. -pgReceive :: Handle -> IO PGMessage -pgReceive h = do - d <- debug - (typ, len) <- G.runGet getMessageHeader `liftM` hGet h 5 - body <- hGet h (len - 4) - if d - then do putStr (P.runPut (do P.putWord8 typ - P.putWord32be (fromIntegral len))) - B8.putStrLn body - hFlush stdout - else return () - let msg = decode $ cons typ (append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) - case msg of - (ErrorResponse _ c m) -> throwIO (PGException c m) - _ -> return msg - --- |Wait for a message of a given type. -pgWaitFor :: Handle - -> [Word8] -- ^ A list of message identifiers, the first of which - -- found while reading messages from PostgreSQL will be - -- returned. - -> IO PGMessage -pgWaitFor h ids = do - response <- pgReceive h - if any (pgMessageID response ==) ids - then return response - else pgWaitFor h ids - --- |Describe a SQL statement/query. A statement description consists of 0 or --- more parameter descriptions (a PostgreSQL type) and zero or more result --- field descriptions (for queries) (consist of the name of the field, the --- type of the field, and a nullability indicator). -describeStatement :: Handle - -> String -- ^ SQL string - -> IO ([PGType], [(String, PGType, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. -describeStatement h sql = do - pgSend h $ Parse sql "" - pgSend h $ Describe "" - pgSend h $ Flush - _ <- pgWaitFor h [pgMessageID ParseComplete] - (ParameterDescription ps) <- pgReceive h - m <- pgWaitFor h $ map c2w ['n', 'T'] - case m of - NoData -> return (ps, []) - (RowDescription r) -> do - r' <- zipWith (\ (name, typ, _, _) n -> (name, typ, n)) r `liftM` mapM nullable r - return (ps, r') - _ -> error "" - where - nullable (_, _, oid, col) = - -- We don't get nullability indication from PostgreSQL, at least not - -- directly. - if oid == 0 - -- Without any hints, we have to assume that the result can be null and - -- leave it up to the developer to figure it out. - then return True - -- In cases where the resulting field is tracable to the column of a - -- table, we can check there. - else do r <- executeSimpleQuery ("SELECT attnotnull FROM pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) h - case r of - [[Just s]] -> return $ case toString s of - "t" -> False - "f" -> True - _ -> error "Unexpected result from PostgreSQL" - _ -> error $ "Can't determine nullability of column #" ++ show col - --- |A simple query is one which requires sending only a single 'SimpleQuery' --- message to the PostgreSQL server. The query is sent as a single string; you --- cannot bind parameters. Note that queries can return 0 results (an empty --- list). -executeSimpleQuery :: String -- ^ SQL string - -> Handle - -> IO ([[Maybe ByteString]]) -- ^ A list of result rows, - -- which themselves are a list - -- of fields. -executeSimpleQuery sql h = do - pgSend h $ SimpleQuery sql - m <- pgWaitFor h $ map c2w ['C', 'I', 'T'] - case m of - EmptyQueryResponse -> return [[]] - (RowDescription _) -> readDataRows - _ -> error "executeSimpleQuery: Unexpected Message" - where readDataRows = do - m <- pgWaitFor h $ map c2w ['C', 'D'] - case m of - CommandComplete -> return [] - (DataRow fs) -> do rs <- readDataRows - return (fs:rs) - _ -> error "" - --- |While not strictly necessary, this can make code a little bit clearer. It --- executes a 'SimpleQuery' but doesn't look for results. -executeSimpleStatement :: String -- ^ SQL string - -> Handle - -> IO () -executeSimpleStatement sql h = do - pgSend h $ SimpleQuery sql - m <- pgWaitFor h $ map c2w ['C', 'I'] - case m of - CommandComplete -> return () - EmptyQueryResponse -> return () - _ -> error "executeSimpleStatement: Unexpected Message" diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs deleted file mode 100644 index 7316e9c..0000000 --- a/Database/TemplatePG/SQL.hs +++ /dev/null @@ -1,215 +0,0 @@ --- Copyright 2010, 2011, 2012, 2013 Chris Forno - --- |This module exposes the high-level Template Haskell interface for querying --- and manipulating the PostgreSQL server. --- --- All SQL string arguments support expression interpolation. Just enclose your --- expression in @{}@ in the SQL string. --- --- Note that transactions are messy and untested. Attempt to use them at your --- own risk. - -module Database.TemplatePG.SQL ( queryTuples - , queryTuple - , execute - , insertIgnore - , withTransaction - , rollback - , thConnection - ) where - -import Database.TemplatePG.Protocol -import Database.TemplatePG.Types - -import Control.Exception -import Control.Monad -import Data.ByteString.Lazy.UTF8 hiding (length, decode, take, foldr) -import Data.Maybe -import Language.Haskell.Meta.Parse -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (returnQ) -import Network -import System.Environment -import System.IO -import System.IO.Error (isDoesNotExistError) -import Text.ParserCombinators.Parsec - -import Prelude hiding (exp) - --- |Grab a PostgreSQL connection for compile time. We do so through the --- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and --- @TPG_PASS@. Only TPG_DB is required. -thConnection :: IO Handle -thConnection = do - database <- getEnv "TPG_DB" - hostName <- catchUndef (getEnv "TPG_HOST") (\ _ -> return "localhost") - portNum <- catchUndef (getEnv "TPG_PORT") (\ _ -> return "5432") - username <- catchUndef (getEnv "TPG_USER") (\ _ -> return "postgres") - password <- catchUndef (getEnv "TPG_PASS") (\ _ -> return "") - let portNum' = PortNumber $ fromIntegral $ ((read portNum)::Integer) - pgConnect hostName portNum' database username password - where catchUndef = catchJust (\e -> if isDoesNotExistError e - then Just () - else Nothing) - --- |This is where most of the magic happens. --- This doesn't result in a PostgreSQL prepared statement, it just creates one --- to do type inference. --- This returns a prepared SQL string with all values (as an expression) -prepareSQL :: String -- ^ a SQL string, with - -> Q (Exp, [(String, PGType, Bool)]) -- ^ a prepared SQL string and result descriptions -prepareSQL sql = do - -- TODO: It's a bit silly to establish a connection for every query to be - -- analyzed. - h <- runIO thConnection - let (sqlStrings, expStrings) = parseSql sql - (pTypes, fTypes) <- runIO $ describeStatement h $ holdPlaces sqlStrings expStrings - s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings - return (s, fTypes) - where holdPlaces ss es = concat $ weave ss (take (length es) placeholders) - placeholders = map (('$' :) . show) ([1..]::[Integer]) - stringify typ s = [| $(pgTypeToString typ) $(returnQ $ parseExp' s) |] - parseExp' e = (either (\ _ -> error ("Failed to parse expression: " ++ e)) id) $ parseExp e - --- |"weave" 2 lists of equal length into a single list. -weave :: [a] -> [a] -> [a] -weave x [] = x -weave [] y = y -weave (x:xs) (y:ys) = x:y:(weave xs ys) - --- |"weave" a list of SQL fragements an Haskell expressions into a single SQL string. -weaveString :: [String] -- ^ SQL fragments - -> [Exp] -- ^ Haskell expressions - -> Q Exp -weaveString [x] [] = [| x |] -weaveString [] [y] = returnQ y -weaveString (x:[]) (y:[]) = [| x ++ $(returnQ y) |] -weaveString (x:xs) (y:ys) = [| x ++ $(returnQ y) ++ $(weaveString xs ys) |] -weaveString _ _ = error "Weave mismatch (possible parse problem)" - --- |@queryTuples :: String -> (Handle -> IO [(column1, column2, ...)])@ --- --- Query a PostgreSQL server and return the results as a list of tuples. --- --- Example (where @h@ is a handle from 'pgConnect'): --- --- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h --- --- => IO [(Maybe String, Maybe Integer)] --- @ -queryTuples :: String -> Q Exp -queryTuples sql = do - (sql', types) <- prepareSQL sql - [| liftM (map $(convertRow types)) . executeSimpleQuery $(returnQ sql') |] - --- |@queryTuple :: String -> (Handle -> IO (Maybe (column1, column2, ...)))@ --- --- Convenience function to query a PostgreSQL server and return the first --- result as a tuple. If the query produces no results, return 'Nothing'. --- --- Example (where @h@ is a handle from 'pgConnect'): --- --- @let sysid = 10::Integer; --- --- $(queryTuple \"SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}\") h --- --- => IO (Maybe (Maybe String, Maybe Integer)) --- @ -queryTuple :: String -> Q Exp -queryTuple sql = [| liftM maybeHead . $(queryTuples sql) |] - -maybeHead :: [a] -> Maybe a -maybeHead [] = Nothing -maybeHead (x:_) = Just x - --- |@execute :: String -> (Handle -> IO ())@ --- --- Convenience function to execute a statement on the PostgreSQL server. --- --- Example (where @h@ is a handle from 'pgConnect'): --- --- @let rolename = \"BOfH\" --- --- $(execute \"CREATE ROLE {rolename}\") h --- @ -execute :: String -> Q Exp -execute sql = do - (sql', types) <- prepareSQL sql - case types of - [] -> [| executeSimpleStatement $(returnQ sql') |] - _ -> error "Execute can't be used on queries, only statements." - --- |Run a sequence of IO actions (presumably SQL statements) wrapped in a --- transaction. Unfortunately you're restricted to using this in the 'IO' --- Monad for now due to the use of 'onException'. I'm debating adding a --- 'MonadPeelIO' version. -withTransaction :: Handle -> IO a -> IO a -withTransaction h a = - onException (do executeSimpleStatement "BEGIN" h - c <- a - executeSimpleStatement "COMMIT" h - return c) - (executeSimpleStatement "ROLLBACK" h) - --- |Roll back a transaction. -rollback :: Handle -> IO () -rollback = executeSimpleStatement "ROLLBACK" - --- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. -insertIgnore :: IO () -> IO () -insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) - where uniquenessError e = case e of - (PGException c _) -> case c of - "23505" -> Just e - _ -> Nothing - --- |Given a result description, create a function to convert a result to a --- tuple. -convertRow :: [(String, PGType, Bool)] -- ^ result description - -> Q Exp -- ^ A function for converting a row of the given result description -convertRow types = do - n <- newName "result" - lamE [varP n] $ tupE $ map (convertColumn n) $ zip types [0..] - --- |Given a raw PostgreSQL result and a result field type, convert the --- appropriate field to a Haskell value. -convertColumn :: Name -- ^ the name of the variable containing the result list (of 'Maybe' 'ByteString') - -> ((String, PGType, Bool), Int) -- ^ the result field type and index - -> Q Exp -convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) ($(varE name) !! i) |] - --- |Like 'pgStringToType', but deal with possible @NULL@s. If the boolean --- argument is 'False', that means that we know that the value is not nullable --- and we can use 'fromJust' to keep the code simple. If it's 'True', then we --- don't know if the value is nullable and must return a 'Maybe' value in case --- it is. -pgStringToType' :: PGType - -> Bool -- ^ nullability indicator - -> Q Exp -pgStringToType' t False = [| ($(pgStringToType t)) . toString . fromJust |] -pgStringToType' t True = [| liftM (($(pgStringToType t)) . toString) |] - --- SQL Parser -- - --- |Given a SQL string return a list of SQL parts and expression parts. --- For example: @\"SELECT * FROM table WHERE id = {someID} AND age > {baseAge * 1.5}\"@ --- becomes: @(["SELECT * FROM table WHERE id = ", " AND age > "], --- ["someID", "baseAge * 1.5"])@ -parseSql :: String -> ([String], [String]) -parseSql sql = case (parse sqlStatement "" sql) of - Left err -> error (show err) - Right ss -> every2nd ss - -every2nd :: [a] -> ([a], [a]) -every2nd = foldr (\a ~(x,y) -> (a:y,x)) ([],[]) - -sqlStatement :: Parser [String] -sqlStatement = many1 $ choice [sqlText, sqlParameter] - -sqlText :: Parser String -sqlText = many1 (noneOf "{") - --- |Parameters are enclosed in @{}@ and can be any Haskell expression supported --- by haskell-src-meta. -sqlParameter :: Parser String -sqlParameter = between (char '{') (char '}') $ many1 (noneOf "}") \ No newline at end of file diff --git a/Database/TemplatePG/TODO b/Database/TemplatePG/TODO deleted file mode 100644 index 0cd7d6f..0000000 --- a/Database/TemplatePG/TODO +++ /dev/null @@ -1 +0,0 @@ -* Fix defect when trying to use Days for timestamp fields (the last digit of dates are truncated). Temporary workaround: bind parameters to date manually (e.g. {haskellDay}::date). diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs deleted file mode 100644 index 6a47edb..0000000 --- a/Database/TemplatePG/Types.hs +++ /dev/null @@ -1,112 +0,0 @@ --- Copyright 2010, 2011, 2013 Chris Forno - --- |All type conversion to and from the PostgreSQL server is handled here. - -module Database.TemplatePG.Types ( PGType(..) - , pgTypeFromOID - , pgStringToType - , pgTypeToString - ) where - -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Format -import Language.Haskell.TH -import System.Locale -import Text.Regex - --- |TemplatePG currenly only supports a handful of types. It also doesn't --- distinguish between numeric types with different ranges. More types are the --- most likely feature of future TemplatePG releases. -data PGType = PGBoolean -- ^ bool - | PGInteger -- ^ integer - | PGReal -- ^ float - | PGText -- ^ text/varchar - | PGTimestampTZ -- ^ timestamptz (timestamp with time zone) - | PGDate -- ^ date (day without time) - | PGInterval -- ^ interval (a time interval), send-only - deriving (Eq, Show) - --- |Convert a type OID from PostgreSQL's catalog to a TemplatePG --- representation. To get a list of types: @SELECT typname, oid FROM pg_type@ --- Note that I have assumed, but not tested, that type OIDs for these basic --- types are consistent across installations. If not, I'm going to have to --- switch to using the text descriptions -pgTypeFromOID :: Int -- ^ PostgreSQL type OID - -> PGType -pgTypeFromOID 16 = PGBoolean -- bool --- treating all ints alike for now -pgTypeFromOID 20 = PGInteger -- int8 -pgTypeFromOID 21 = PGInteger -- int2 -pgTypeFromOID 23 = PGInteger -- int4 -pgTypeFromOID 25 = PGText -- text --- as with ints, sacrificing precision/safety for floats -pgTypeFromOID 700 = PGReal -- float4 -pgTypeFromOID 701 = PGReal -- float8 --- I don't currently treat varchars differently from text. It would make sense --- to do so if I could enforce length limits at compile time. -pgTypeFromOID 1043 = PGText -- varchar -pgTypeFromOID 1082 = PGDate -- date -pgTypeFromOID 1184 = PGTimestampTZ -- timestamptz -pgTypeFromOID 1186 = PGInterval -- interval -pgTypeFromOID n = error $ "Unknown PostgreSQL type: " ++ show n - --- |This is PostgreSQL's canonical timestamp format. --- Time conversions are complicated a bit because PostgreSQL doesn't support --- timezones with minute parts, and Haskell only supports timezones with --- minutes parts. We'll need to truncate and pad timestamp strings accordingly. --- This means with minute parts will not work. -pgTimestampTZFormat :: String -pgTimestampTZFormat = "%F %T%z" - -readIntegral :: (Read a, Integral a) => String -> a -readIntegral = read - -readReal :: (Read a, Real a) => String -> a -readReal = read - -showIntegral :: (Show a, Integral a) => a -> String -showIntegral = show - -showReal :: (Show a, Real a) => a -> String -showReal = show - --- |Convert a Haskell value to a string of the given PostgreSQL type. Or, more --- accurately, given a PostgreSQL type, create a function for converting --- compatible Haskell values into a string of that type. --- @pgTypeToString :: PGType -> (? -> String)@ -pgTypeToString :: PGType -> Q Exp -pgTypeToString PGInteger = [| showIntegral |] -pgTypeToString PGReal = [| showReal |] -pgTypeToString PGText = [| escapeString |] -pgTypeToString PGBoolean = [| (\ b -> if b then "'t'" else "'f'") |] -pgTypeToString PGTimestampTZ = [| \t -> let ts = formatTime defaultTimeLocale pgTimestampTZFormat t in - "TIMESTAMP WITH TIME ZONE '" ++ - (take (length ts - 2) ts) ++ "'" |] -pgTypeToString PGDate = [| \d -> "'" ++ showGregorian d ++ "'" |] -pgTypeToString PGInterval = [| \s -> "'" ++ show (s::DiffTime) ++ "'" |] - --- |Convert a string from PostgreSQL of the given type into an appropriate --- Haskell value. Or, more accurately, given a PostgreSQL type, create a --- function for converting a string of that type into a compatible Haskell --- value. --- @pgStringToType :: PGType -> (String -> ?)@ -pgStringToType :: PGType -> Q Exp --- TODO: Is reading to any integral type too unsafe to justify the convenience? -pgStringToType PGInteger = [| readIntegral |] -pgStringToType PGReal = [| readReal |] -pgStringToType PGText = [| id |] -pgStringToType PGBoolean = [| \s -> case s of - "t" -> True - "f" -> False - _ -> error "unrecognized boolean type from PostgreSQL" |] -pgStringToType PGTimestampTZ = [| \t -> readTime defaultTimeLocale pgTimestampTZFormat (t ++ "00") |] -pgStringToType PGDate = [| readTime defaultTimeLocale "%F" |] -pgStringToType PGInterval = error "Reading PostgreSQL intervals isn't supported (yet)." - --- |Make a string safe for interpolation (escape single-quotes). This relies on --- standard_conforming_strings = on in postgresql.conf. I'm not 100% sure that --- this makes all strings safe for execution. I don't know if it's possible to --- inject SQL with strange (possibly Unicode) characters. -escapeString :: String -> String -escapeString s = "'" ++ (subRegex (mkRegex "'") s "''") ++ "'" diff --git a/README b/README deleted file mode 100644 index 4f0b2b3..0000000 --- a/README +++ /dev/null @@ -1,11 +0,0 @@ -TemplatePG is designed with 2 goals in mind: safety and performance. The primary focus is on safety. - -To help ensure safety, it uses the PostgreSQL server to parse every query and statement in your code to infer types at compile-time. This means that in theory you cannot get a syntax error at runtime. Getting proper types at compile time has the nice side-effect that it eliminates run-time type casting and usually results in less code. This approach was inspired by MetaHDBC (http://haskell.org/haskellwiki/MetaHDBC) and PG'OCaml (http://pgocaml.berlios.de/). - -While compile-time query analysis eliminates many errors, it doesn't eliminate all of them. If you modify the database without recompilation or have an error in a trigger or function, for example, you can still trigger a PGException. - -With that in mind, TemplatePG currently does a number of unsafe things. It doesn't properly close the connection with the PostgreSQL server. It doesn't handle unexpected messages from the server very gracefully, and it's not entirely safe when working with nullable result fields. I hope to fix all of these at some point in the future. In the meantime, use the software at your own risk. Note however that TemplatePG is currently powering http://www.vocabulink.com/ with no problems yet. (For usage examples, you can see the Vocabulink source code at http://jekor.com/vocabulink/vocabulink.tar.gz). - -To improve performance, TemplatePG does not use prepared statements. In theory, this saves bandwidth (and a potential round-trip) and time for the extra step of binding parameters. Again in theory, this is also safe because we know the types of parameters at compile time. However, it still feels risky (and I would appreciate any audit of the code doing this, especially escapeString). - -See the Haddock documentation at http://hackage.haskell.org/package/templatepg for how to use TemplatePG. diff --git a/README.md b/README.md new file mode 100644 index 0000000..9c17c9d --- /dev/null +++ b/README.md @@ -0,0 +1,107 @@ +# Haskell PostgreSQL-typed + +A Haskell PostgreSQL interface that provides type-safety through compile-time (template Haskell) database access. +See the [Haddock](http://hackage.haskell.org/package/postgresql-typed) documentation in [Database.PostgreSQL.Typed](http://hackage.haskell.org/package/postgresql-typed/docs/Database-PostgreSQL-Typed.html) or the [test cases](test/Main.hs) for simple examples. + +## Getting started + +### Installation + +Use your preferred package manager to install or add to your package dependencies: + +- `stack install postgresql-typed` or +- `cabal install postgresql-typed` + +You'll also likely need to add `network` as a dependency. + +### Enable ghc extensions + +Make sure you enable `TemplateHaskell`, `QuasiQuotes`, and `DataKinds` language extensions, either in your cabal `default-extensions` or in a `{-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-}` pragma in your source. + +### Setup compile-time database connection + +Either set the following environment variables: + +- `TPG_DB` the database name to use (default: same as user) +- `TPG_USER` the username to connect as (default: `$USER` or `postgres`) +- `TPG_PASS` the password to use (default: *empty*) +- `TPG_HOST` the host to connect to (default: `localhost`) +- `TPG_PORT` or `TPG_SOCK` the port number or local socket path to connect on (default port: `5432`) + +*Or* in your code call `Database.PostgreSQL.Typed.useTPGDatabase` with a database config as a top-level quote in each code file where you have SQL queries. +It's often helpful to make your own utility function to do this: + +```haskell +-- |Call this at top-level at the beginning of every file (rather than 'useTPGDatabase') +useMyTPGConfig :: Language.Haskell.TH.DecsQ +useMyTPGConfig = useTPGDatabase PGDatabase{ ... } -- or load config from file +``` + +### Setup your database schema + +Your tables and other schema need to be created in your development (compile-time) database before you compile your code. +No queries will actually be executed, so there does not need to be any data, but it will do query parsing with the database (prepare queries) so any referenced objects must exist. + +### Setup run-time database connection + +Use `pgConnect` to connect to your database using a `PGDatabase` configuration. +The run-time database does not need to be the same as the build-time database (though it can be), but it *must* have the same schema. +It's recommended to use `bracket (pgConnect PGDatabase{..}) pgDisconnect`. +If you need a pool of connections, consider `resource-pool` (while `PGConnection`s are mostly thread-safe, they can't be used for multiple queries simultaneously). + +### Complete example + +schema.sql: +```sql +CREATE TABLE thing (id SERIAL PRIMARY KEY, name TEXT NOT NULL); +``` + +DBConfig.hs: +```haskell +{-# LANGUAGE OverloadedStrings #-} +module DBConfig where + +import qualified Database.PostgreSQL.Typed as PG +import Network.Socket (SockAddr(SockAddrUnix)) + +myPGDatabase :: PG.PGDatabase +myPGDatabase = PG.defaultPGDatabase + { PG.pgDBAddr = if tcp then Left ("localhost", "5432") else Right (SockAddrUnix "/run/postgresql/.s.PGSQL.5432") + , PG.pgDBUser = "user" + , PG.pgDBName = "db" + } where tcp = False +``` + +Main.hs: +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Exception (bracket) +import Control.Monad (void, unless) +import Data.Int (Int32) +import Data.Maybe (listToMaybe) +import qualified Database.PostgreSQL.Typed as PG + +import DBConfig + +PG.useTPGDatabase myPGDatabase + +data Thing = Thing Int32 String + deriving (Eq) + +createThing :: PG.PGConnection -> Thing -> IO () +createThing pg (Thing tid tname) = + void $ PG.pgExecute pg [PG.pgSQL|INSERT INTO thing (id, name) VALUES (${tid}, ${tname})|] + +lookupThing :: PG.PGConnection -> Int32 -> IO (Maybe Thing) +lookupThing pg tid = fmap (uncurry Thing) . listToMaybe <$> + PG.pgQuery pg [PG.pgSQL|SELECT id, name FROM thing WHERE id = ${tid}|] + +main = bracket (PG.pgConnect myPGDatabase) PG.pgDisconnect $ \pg -> do + let myt = Thing 1 "cat" + createThing pg myt + t <- lookupThing pg 1 + unless (t == Just myt) $ fail "wrong thing!" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO b/TODO deleted file mode 100644 index 19ec724..0000000 --- a/TODO +++ /dev/null @@ -1,23 +0,0 @@ -* See if we can get rid of -XConstraintKinds (ShowIntegral and ShowReal). -* Bail when standard_conforming_string is off (can be seen in connection details returned from server). -* Handle bounds for integers better (automatically allow anything smaller through, but block bigger values). -* Add support for returning records (instead of tuples). -* Make insertIgnore useable in transactions. -* On disconnect, send a close message? -* Figure out how to make withTransaction useable in other monads. -* Add support for enumerated types (look in pg_enum with unknown types). -* Support IS NULL insertion for = Nothing. -* Add explicit casts to all values going in: - $(execute - "UPDATE link_to_review \ - \SET target_time = {reviewedAt} + {diff} \ - \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h - -reviewedAt is a UTCTime and diff is a DiffTime, but to PostgreSQL it's ambigious (PGException "42725" "operator is not unique: unknown + unknown"). To fix it: - - $(execute - "UPDATE link_to_review \ - \SET target_time = {reviewedAt}::timestamp with time zone + {diff}::interval \ - \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h - -But easier for the programmer would be to have TemplatePG add explicit casts to all values it sends in. This is probably safer in the long run as well, although possibly less flexible. diff --git a/errcodes.hs b/errcodes.hs new file mode 100644 index 0000000..5d4b7c2 --- /dev/null +++ b/errcodes.hs @@ -0,0 +1,115 @@ +-- Parses postgresql/src/backend/utils/errcodes.txt into ErrCodes.hs +-- Based on generate-errcodes.pl +import Data.Char (isSpace, isLower, toLower) +import Data.List (intercalate, isPrefixOf, find, sortOn) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time.Clock (getCurrentTime) +import System.Directory (doesDirectoryExist) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.FilePath (()) +import System.IO (stderr, readFile, hPutStrLn) + +path :: FilePath +path = "src" "backend" "utils" "errcodes.txt" + +data ErrType + = Error + | Warning + | Success + deriving (Show) + +data ErrCode = ErrCode + { errCode :: String + , errMacro :: String + , errName :: Maybe String + , errType :: ErrType + } + +data Line + = Line ErrCode + | Section String + +macroName :: String -> String +macroName ('E':'R':'R':'C':'O':'D':'E':'_':n) = n +macroName n = n + +descName :: ErrCode -> String +descName ErrCode{ errName = Just n } = n +descName ErrCode{ errMacro = n } = n + +macroPrefixes :: [String] +macroPrefixes = ["WARNING_", "S_R_E_", "E_R_E_", "E_R_I_E_"] + +varName :: ErrCode -> String +varName ErrCode{ errName = Just n@(h:_), errMacro = m } + | Just p <- find (`isPrefixOf` m) macroPrefixes = map toLower p ++ n + | isLower h = n +varName e = '_':descName e + +parseType :: String -> Maybe ErrType +parseType "E" = Just Error +parseType "W" = Just Warning +parseType "S" = Just Success +parseType _ = Nothing + +parseWords :: [String] -> Maybe ErrCode +parseWords [c@[_,_,_,_,_], t, m, n] = ErrCode c (macroName m) (Just n) <$> parseType t +parseWords [c@[_,_,_,_,_], t, m] = ErrCode c (macroName m) Nothing <$> parseType t +parseWords _ = Nothing + +parseLine :: String -> Maybe Line +parseLine ('#':_) = Nothing +parseLine ('S':'e':'c':'t':'i':'o':'n':':':s) = Just $ Section $ dropWhile isSpace s +parseLine s + | all isSpace s = Nothing + | otherwise = Just $ Line $ fromMaybe (error $ "invalid line: " ++ s) $ parseWords $ words s + +exportLine :: Line -> IO () +exportLine (Section s) = putStrLn $ " -- * " ++ s +exportLine (Line e) = putStrLn $ " , " ++ varName e + +lineErr :: Line -> Maybe ErrCode +lineErr (Line e) = Just e +lineErr _ = Nothing + +line :: ErrCode -> IO () +line e = do + putStrLn $ "" + putStrLn $ "-- |@" ++ errMacro e ++ "@: " ++ errCode e ++ " (" ++ show (errType e) ++ ")" + putStrLn $ varName e ++ " :: ByteString" + putStrLn $ varName e ++ " = " ++ show (errCode e) + +name :: ErrCode -> Maybe String +name e = Just $ "(" ++ varName e ++ "," ++ show (descName e) ++ ")" + +main :: IO () +main = do + prog <- getProgName + args <- getArgs + arg <- case args of + [f] -> return f + _ -> do + hPutStrLn stderr $ "Usage: " ++ prog ++ " POSTGRESQLSRCDIR[/" ++ path ++ "] > ErrCodes.hs" + exitFailure + argd <- doesDirectoryExist arg + let file | argd = arg path + | otherwise = arg + l <- mapMaybe parseLine . lines <$> readFile file + let e = mapMaybe lineErr l + now <- getCurrentTime + putStrLn $ "-- Automatically generated from " ++ file ++ " using " ++ prog ++ " " ++ show now ++ "." + putStrLn $ "{-# LANGUAGE OverloadedStrings #-}" + putStrLn $ "-- |PostgreSQL error codes." + putStrLn $ "module Database.PostgreSQL.Typed.ErrCodes (names" + mapM_ exportLine l + putStrLn $ ") where" + putStrLn $ "" + putStrLn $ "import Data.ByteString (ByteString)" + putStrLn $ "import Data.Map.Strict (Map, fromDistinctAscList)" + mapM_ line e + putStrLn $ "" + putStrLn $ "-- |All known error code names by code." + putStrLn $ "names :: Map ByteString String" + putStrLn $ "names = fromDistinctAscList\n [" ++ intercalate "\n ," (mapMaybe name $ sortOn errCode e) ++ "]" + return () diff --git a/nix/default.nix b/nix/default.nix new file mode 100644 index 0000000..466fd6d --- /dev/null +++ b/nix/default.nix @@ -0,0 +1,92 @@ +{ pkgsPath ? null +, compiler ? "ghc864" +, postgresql ? "postgresql" +}: +let + # We pin the nixpkgs version here to ensure build reproducibility + pinnedNixpkgs = + import ./fetch-nixpkgs.nix + { # Latest HEAD of the release-19.03 branch as of 2019-05-22 + rev = "23a3bda4da71f6f6a7a248c593e14c838b75d40b"; + # This sha256 can be obtained with: + # `$ nix-prefetch-url https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz` + sha256 = "0v2r8xr3nvpc5xfqr4lr6i3mrcn6d5np1dr26q4iks5hj2zlxl97"; + # This one with: + # `$ nix-prefetch-url --unpack https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz` + outputSha256 = "1sgi9zi4h3mhvjq2wkzkvq2zdvh6p9qg19yv7c01sqin23s6yqr1"; + }; + + # Use pkgsPath if provided, else the pinned checkout + realPkgsPath = + if pkgsPath == null then pinnedNixpkgs else pkgsPath; + + # This overlay extends the nixpkgs' package set a custom haskell package set + # which includes postgresql-typed + overlay = self: super: + { + myHaskellPackages = self.haskell.packages."${compiler}".override (_ : { + overrides = haskellOverlay self; + }); + }; + + # This overlay extends a haskell package set with postgresql-typed + haskellOverlay = pkgs: self: super: with pkgs.haskell.lib; + { + # version with TLS + postgresql-typed = + let + src = pkgs.lib.cleanSource ../.; + drv = self.callCabal2nix "postgresql-typed" src {}; + drvWithPostgres = withPostgres pkgs.${postgresql} drv; + in pkgs.lib.overrideDerivation drvWithPostgres (old: { + checkPhase = '' + ${pkgs.openssl}/bin/openssl req -x509 -newkey rsa:2048 \ + -keyout $PGDATA/server.key \ + -out $PGDATA/server.crt \ + -days 1 -nodes \ + -subj "/C=US/ST=Somewhere/L=Earth/O=Test Network/OU=IT Department/CN=localhost" + chmod 0600 $PGDATA/server.key + echo 'ssl = on' >> $PGDATA/postgresql.conf + + # disallow non-ssl connections to make sure we're doing TLS + echo 'hostssl templatepg templatepg all trust' > $PGDATA/pg_hba.conf + echo 'hostnossl all all all reject' >> $PGDATA/pg_hba.conf + + pg_ctl restart + + export PGTLS=1 + + # First test TlsNoValidate + ./Setup test + + # Test TlsValidateCA + export PGTLS_ROOTCERT=$(cat $PGDATA/server.crt) + ./Setup test + + # Test TlsValidateFull + export PGTLS_VALIDATEFULL=1 + ./Setup test + + # Test that cert validation fails with invalid cert + ${pkgs.openssl}/bin/openssl req -x509 -newkey rsa:2048 \ + -keyout other.key \ + -out other.crt \ + -days 1 -nodes \ + -subj "/C=US/ST=Somewhere/L=Earth/O=Test Network/OU=IT Department/CN=localhost" + export PGTLS_ROOTCERT=$(cat other.crt) + ./Setup test && false || true + ''; + }); + + # version without TLS + postgresql-typed-notls = pkgs.lib.overrideDerivation self.postgresql-typed (old: { + configureFlags = old.configureFlags or [] ++ ["-f-tls"]; + checkPhase = "./Setup test"; + }); + }; +in import realPkgsPath + { overlays = + [ overlay + (import ./utilities.nix) + ]; + } diff --git a/nix/fetch-nixpkgs.nix b/nix/fetch-nixpkgs.nix new file mode 100644 index 0000000..f9d9c29 --- /dev/null +++ b/nix/fetch-nixpkgs.nix @@ -0,0 +1,64 @@ +# Stolen from https://github.com/awakesecurity/gRPC-haskell/blob/master/fetch-nixpkgs.nix +# +# This function is used to pin nixpkgs to a specific version +# +{ rev # The Git revision of nixpkgs to fetch +, sha256 # The SHA256 of the downloaded data +, outputSha256 ? null # The SHA256 output hash +, system ? builtins.currentSystem # This is overridable if necessary +}: + +with { + ifThenElse = { bool, thenValue, elseValue }: ( + if bool then thenValue else elseValue); +}; + +ifThenElse { + bool = (0 <= builtins.compareVersions builtins.nixVersion "1.12"); + + # In Nix 1.12, we can just give a `sha256` to `builtins.fetchTarball`. + thenValue = ( + builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + + # builtins.fetchTarball does not need the sha256 hash of the + # packed and compressed tarball but it _does_ need the + # fixed-output sha256 hash. + sha256 = outputSha256; + }); + + # This hack should at least work for Nix 1.11 + elseValue = ( + (rec { + tarball = import { + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + inherit sha256; + }; + + builtin-paths = import ; + + script = builtins.toFile "nixpkgs-unpacker" '' + "$coreutils/mkdir" "$out" + cd "$out" + "$gzip" --decompress < "$tarball" | "$tar" -x --strip-components=1 + ''; + + nixpkgs = builtins.derivation ({ + name = "nixpkgs-${builtins.substring 0 6 rev}"; + + builder = builtins.storePath builtin-paths.shell; + + args = [ script ]; + + inherit tarball system; + + tar = builtins.storePath builtin-paths.tar; + gzip = builtins.storePath builtin-paths.gzip; + coreutils = builtins.storePath builtin-paths.coreutils; + } // (if null == outputSha256 then { } else { + outputHashMode = "recursive"; + outputHashAlgo = "sha256"; + outputHash = outputSha256; + })); + }).nixpkgs); +} diff --git a/nix/release.nix b/nix/release.nix new file mode 100644 index 0000000..8e4747c --- /dev/null +++ b/nix/release.nix @@ -0,0 +1,11 @@ +{ pkgsPath ? null +, compiler ? "ghc864" +, postgresql ? "postgresql" +}@args: +let pkgs = import ./. args; +in +{ + inherit (pkgs.myHaskellPackages) + postgresql-typed + postgresql-typed-notls; +} diff --git a/nix/utilities.nix b/nix/utilities.nix new file mode 100644 index 0000000..15c2dcb --- /dev/null +++ b/nix/utilities.nix @@ -0,0 +1,167 @@ +let + # bash magic so we can set several traps without removin any existing one. + # Brought to you by https://stackoverflow.com/questions/16115144/save-and-restore-trap-state-easy-way-to-manage-multiple-handlers-for-traps/16115145 + trapMagic = '' + trap_stack_name() { + local sig=''${1//[^a-zA-Z0-9]/_} + echo "__trap_stack_$sig" + } + + extract_trap() { + echo ''${@:3:$(($#-3))} + } + + get_trap() { + eval echo $(extract_trap `trap -p $1`) + } + + trap_push() { + local new_trap=$1 + shift + local sigs=$* + for sig in $sigs; do + local stack_name=`trap_stack_name "$sig"` + local old_trap=$(get_trap $sig) + eval "''${stack_name}"'[''${#'"''${stack_name}"'[@]}]=$old_trap' + trap "''${new_trap}" "$sig" + done + } + + trap_prepend() { + local new_trap=$1 + shift + local sigs=$* + for sig in $sigs; do + if [[ -z $(get_trap $sig) ]]; then + trap_push "$new_trap" "$sig" + else + trap_push "$new_trap ; $(get_trap $sig)" "$sig" + fi + done + } + ''; + +in self: super: { + + lib = super.lib // + { + + # This function filters out stuff we don't want to consider part of the source + # when building with nix. Any change in one of these files would cause a + # re-build otherwise + cleanSource = + let + fldSourceFilter = name: type: let baseName = baseNameOf (toString name); in ! ( + # Filter out Subversion and CVS directories. + (type == "directory" && + ( baseName == ".git" || + baseName == ".circleci" || + baseName == ".nix-cache" || + baseName == ".cache" || + baseName == "nix" || + baseName == "dist" || + baseName == "dist-newstyle" + ) + ) || + # Filter out editor backup / swap files. + self.lib.hasSuffix "~" baseName || + builtins.match "^\\.sw[a-z]$" baseName != null || + builtins.match "^\\..*\\.sw[a-z]$" baseName != null || + + # filter out .ghc.environment + builtins.match "^\\.ghc.environment.*" baseName != null || + + # Filter out nix-build result symlinks + (type == "symlink" && self.lib.hasPrefix "result" baseName) || + + # Filter other random crap we have lying around for development + # which we don't need to properly build + (baseName == "develop.sh") || + (baseName == "Setup") || + (baseName == "Setup.o") || + (baseName == "Setup.hi") || + (baseName == ".bash_history") || + (baseName == "README.md") + ); + in builtins.filterSource fldSourceFilter; + }; + + haskell = super.haskell // { + lib = super.haskell.lib // { + # This function provides an ephemeral postgresql instance for development in + # the shellHook and at build/test time of the package it wraps + withPostgres = pg: drv: + let functions = '' + ${trapMagic} + + function initPG() { + ${super.lib.optionalString super.stdenv.isDarwin "export TMPDIR=/tmp"} + ${super.lib.optionalString (!super.stdenv.isDarwin) "export LANG=C.UTF-8"} + ${super.lib.optionalString (!super.stdenv.isDarwin) "export LC_ALL=C.UTF-8"} + ${super.lib.optionalString (!super.stdenv.isDarwin) "export LC_CTYPE=C.UTF-8"} + export TZ='UTC' + export PGHOST=$(mktemp -d) + export PGDATA=$PGHOST/db + export PGPORT=5433 + export PGSOCK=$PGHOST/.s.PGSQL.$PGPORT + export PGDATABASE=templatepg + export PGUSER=templatepg + # We set these environment variables so postgresql-typed knows how + # to connect to the database at compile-time to make sure all SQL + # queries are well typed and well formed + export TPG_SOCK=$PGSOCK + export TPG_DB=$PGDATABASE + export TPG_USER=$PGUSER + # + ${pg}/bin/initdb -E UTF8 $PGDATA + # avoid conflicts on travis and elsewhere + echo "port = $PGPORT" >> $PGDATA/postgresql.conf + ${pg}/bin/postgres -D $PGDATA -k $PGHOST & + echo -n "Waiting for database to start up..." + while [[ ! -e $PGSOCK ]]; do sleep 0.1; done + ${pg}/bin/createuser -h $PGHOST -U $(id -u --name) -s $PGUSER + ${pg}/bin/createdb -h $PGHOST -O $PGUSER $PGDATABASE + + echo "Created database PGDATABASE=$PGDATABASE at PGHOST=$PGHOST." + echo "Call killPG to stop and delete it. Call initPG to re-create it" + } + function killPG() { + echo "Killing postgres database at $PGHOST" + pg_ctl stop || true + echo "Waiting for postgres database to die ..." + while [[ -e $PGSOCK ]]; do sleep 0.1; done + echo "Postgres is dead, deleting its data dir" + rm -rf $PGHOST + } + function reinitPG { + killPG && initPG + } + # export the functions so they're available in the development nix-shell + # so the database can be re-created easly + export -f initPG + export -f killPG + export -f reinitPG + + trap_prepend "killPG" EXIT + ''; + + in super.haskell.lib.overrideCabal drv (old: { + buildDepends = (old.buildDepends or []) ++ [ pg ]; + preBuild = '' + ${old.preBuild or ""} + ${functions} + initPG + ''; + shellHook = '' + ${old.shellHook or ""} + ${functions} + initPG + ''; + postInstall = '' + killPG + ${old.postInstall or ""} + ''; + }); + }; + }; +} diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal new file mode 100644 index 0000000..07fd076 --- /dev/null +++ b/postgresql-typed.cabal @@ -0,0 +1,174 @@ +Name: postgresql-typed +Version: 0.6.2.5 +Cabal-Version: >= 1.10 +License: BSD3 +License-File: COPYING +Copyright: 2010-2013 Chris Forno, 2014-2019 Dylan Simon +Author: Dylan Simon +Maintainer: Dylan Simon +Stability: provisional +Bug-Reports: https://github.com/dylex/postgresql-typed/issues +Homepage: https://github.com/dylex/postgresql-typed +Category: Database +Synopsis: PostgreSQL interface with compile-time SQL type checking, optional HDBC backend +Description: Automatically type-check SQL statements at compile time. + Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statements at compile time and provide appropriate type marshalling for both parameters and results. + Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell. + Supports many built-in PostgreSQL types already, including arrays and ranges, and can be easily extended in user code to support any other types. + . + Also includes an optional HDBC backend that, since it uses the raw PostgreSQL protocol, may be more efficient than the normal libpq backend in some cases (though provides no more type safety than HDBC-postgresql when used without templates). + . + Originally based on Chris Forno's templatepg library. +Tested-With: GHC == 7.10.3, GHC == 8.0.1 +Build-Type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: git://github.com/dylex/postgresql-typed + +Flag md5 + Description: Enable md5 password authentication method. + Default: True + +Flag binary + Description: Use binary protocol encoding via postgresql-binary. This may put additional restrictions on supported PostgreSQL server versions. + Default: True + +Flag text + Description: Support Text string values via text (implied by binary). + Default: True + +Flag uuid + Description: Support the UUID type via uuid (implied by binary). + Default: True + +Flag scientific + Description: Support decoding numeric via scientific (implied by binary). + Default: True + +Flag aeson + Description: Support decoding json via aeson. + Default: True + +Flag HDBC + Description: Provide an HDBC driver backend using the raw PostgreSQL protocol. + +Flag tls + Description: Enable TLS (SSL) support in PostgreSQL server connections. + Default: True + +Flag crypton + Description: Use crypton rather than cryptonite. + Default: True + +Library + default-language: Haskell2010 + Build-Depends: + base >= 4.8 && < 5, + array, + binary, + containers, + old-locale, + time, + bytestring >= 0.10.2, + template-haskell, + haskell-src-meta, + network, + attoparsec >= 0.12 && < 0.15, + utf8-string + Exposed-Modules: + Database.PostgreSQL.Typed + Database.PostgreSQL.Typed.Protocol + Database.PostgreSQL.Typed.Types + Database.PostgreSQL.Typed.TH + Database.PostgreSQL.Typed.Query + Database.PostgreSQL.Typed.Enum + Database.PostgreSQL.Typed.Array + Database.PostgreSQL.Typed.Range + Database.PostgreSQL.Typed.Inet + Database.PostgreSQL.Typed.Dynamic + Database.PostgreSQL.Typed.TemplatePG + Database.PostgreSQL.Typed.SQLToken + Database.PostgreSQL.Typed.ErrCodes + Database.PostgreSQL.Typed.Relation + Other-Modules: + Paths_postgresql_typed + Database.PostgreSQL.Typed.TypeCache + GHC-Options: -Wall + if flag(md5) + Build-Depends: memory >= 0.5 + if flag(crypton) + Build-Depends: crypton + else + Build-Depends: cryptonite >= 0.5 + if flag(binary) + Build-Depends: postgresql-binary >= 0.8, text >= 1, uuid >= 1.3, scientific >= 0.3 + else + if flag(text) + Build-Depends: text >= 1 + if flag(uuid) + Build-Depends: uuid >= 1.3 + if flag(scientific) + Build-Depends: scientific >= 0.3 + if flag(aeson) + Build-Depends: aeson >= 0.7 && < 2.3 + if flag(HDBC) + Build-Depends: HDBC >= 2.2 + Exposed-Modules: + Database.PostgreSQL.Typed.HDBC + if flag(tls) + Build-Depends: data-default + if flag(crypton) + Build-Depends: tls >= 1.7, crypton-x509, crypton-x509-store, crypton-x509-validation + else + Build-Depends: tls < 1.7, x509, x509-store, x509-validation + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + Other-Modules: Connect + default-Extensions: TemplateHaskell, QuasiQuotes + build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck + GHC-Options: -Wall + if flag(tls) + Build-Depends: tls + +test-suite hdbc + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test/hdbc, test + main-is: runtests.hs + other-modules: + Connect + SpecificDB + TestMisc + TestSbasics + TestTime + TestUtils + Testbasics + Tests + if flag(HDBC) + build-depends: base, bytestring, network, time, containers, convertible, postgresql-typed, HDBC, HUnit + else + buildable: False + if flag(tls) + Build-Depends: tls + +benchmark bench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Bench.hs + other-modules: Connect + build-depends: + base, + bytestring, + time, + network, + criterion, + postgresql-typed + if flag(tls) + Build-Depends: tls diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..1df7966 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-19.33 +packages: +- '.' diff --git a/templatepg.cabal b/templatepg.cabal deleted file mode 100644 index 9084323..0000000 --- a/templatepg.cabal +++ /dev/null @@ -1,52 +0,0 @@ -Name: templatepg -Version: 0.2.6 -Cabal-Version: >= 1.6 -License: BSD3 -License-File: COPYING -Copyright: 2010, 2011, 2012, 2013 Chris Forno -Author: Chris Forno (jekor) -Maintainer: jekor@jekor.com -Stability: alpha -Bug-Reports: https://github.com/jekor/templatepg/issues -Homepage: https://github.com/jekor/templatepg -Package-URL: https://github.com/jekor/templatepg/archive/master.tar.gz -Category: Database -Synopsis: A PostgreSQL access library with compile-time SQL type inference -Description: TemplatePG provides PostgreSQL access from Haskell via the - PostgreSQL protocol. It also provides a higher-level Template - Haskell interface. It eliminates a class of runtime errors by - checking queries against a PostgreSQL database at compile-time. - This also reduces boilerplate code for dealing with query - results, as the type and number of result columns are known at - compile-time. -Tested-With: GHC == 7.6.3 -Build-Type: Simple - -source-repository head - type: git - location: git://github.com/jekor/templatepg.git - -Library - Build-Depends: - base >= 4 && < 6, - binary, - bytestring, - haskell-src-meta, - mtl, - network, - old-locale, - parsec, - regex-compat, - regex-posix, - template-haskell, - time, - utf8-string - Exposed-Modules: - Database.TemplatePG - Database.TemplatePG.Protocol - Database.TemplatePG.SQL - Database.TemplatePG.Types - Extensions: DeriveDataTypeable, - ExistentialQuantification, - TemplateHaskell - GHC-Options: -Wall -fno-warn-type-defaults diff --git a/test/Bench.hs b/test/Bench.hs new file mode 100644 index 0000000..a95314e --- /dev/null +++ b/test/Bench.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-} +module Main (main) where + +import qualified Data.ByteString as BS +import Data.Int (Int16, Int32, Int64) +import qualified Data.Time as Time +import qualified Criterion.Main as C +import System.Exit (exitSuccess, exitFailure) + +import Database.PostgreSQL.Typed +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Query + +import Connect + +useTPGDatabase db + +selectTypes :: PGConnection -> IO [(String, OID, Int16, Bool, Maybe BS.ByteString)] +selectTypes c = pgQuery c [pgSQL|SELECT typname, typnamespace, typlen, typbyval, typdefault FROM pg_catalog.pg_type|] + +selectTypesLazy :: PGConnection -> IO [(String, OID, Int16, Bool, Maybe BS.ByteString)] +selectTypesLazy c = pgLazyQuery c [pgSQL|$SELECT typname, typnamespace, typlen, typbyval, typdefault FROM pg_catalog.pg_type|] 1 + +selectParams :: PGConnection -> IO [(Maybe String, Maybe Int64, Maybe Double, Maybe BS.ByteString, Maybe Bool)] +selectParams c = pgQuery c [pgSQL|$SELECT ${"hello"}::text, ${123::Int64}::bigint, ${123.4::Double}::float, ${BS.pack [120..220]}::bytea, ${Nothing::Maybe Bool}::boolean|] + +selectValues :: PGConnection -> IO [(Int32, Time.UTCTime)] +selectValues c = pgQuery c [pgSQL|!SELECT generate_series, now() FROM generate_series(8,256)|] + +selectValuesLazy :: PGConnection -> IO [(Int32, Time.UTCTime)] +selectValuesLazy c = pgLazyQuery c [pgSQL|$!SELECT generate_series, now() FROM generate_series(8,256)|] 5 + +main :: IO () +main = do + c <- pgConnect db + C.defaultMain + [ C.bench "types" $ C.nfIO $ selectTypes c + , C.bench "types lazy" $ C.nfIO $ selectTypesLazy c + , C.bench "params" $ C.nfIO $ selectParams c + , C.bench "values" $ C.nfIO $ selectValues c + , C.bench "values lazy" $ C.nfIO $ selectValuesLazy c + ] diff --git a/test/Connect.hs b/test/Connect.hs new file mode 100644 index 0000000..c93d095 --- /dev/null +++ b/test/Connect.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Connect where + +#ifdef VERSION_tls +import Control.Exception (throwIO) +#endif +import qualified Data.ByteString.Char8 as BSC +import Data.Maybe (fromMaybe, isJust) +import Database.PostgreSQL.Typed (PGDatabase (..), + defaultPGDatabase) +#ifdef VERSION_tls +import Database.PostgreSQL.Typed.Protocol (PGTlsMode (..), + PGTlsValidateMode (..), + pgTlsValidate) +#endif +import Network.Socket (SockAddr (SockAddrUnix)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +db :: PGDatabase +db = unsafePerformIO $ do + mPort <- lookupEnv "PGPORT" + pgDBAddr <- case mPort of + Nothing -> +#ifndef mingw32_HOST_OS + Right . SockAddrUnix . fromMaybe "/tmp/.s.PGSQL.5432" <$> lookupEnv "PGSOCK" +#else + pure $ pgDBAddr defaultPGDatabase +#endif + Just port -> pure $ Left ("localhost", port) +#ifdef VERSION_tls + pgDBTLS <- do + enabled <- isJust <$> lookupEnv "PGTLS" + validateFull <- isJust <$> lookupEnv "PGTLS_VALIDATEFULL" + rootcert <- fmap BSC.pack <$> lookupEnv "PGTLS_ROOTCERT" + case (enabled,validateFull,rootcert) of + (False,_,_) -> pure TlsDisabled + (True,False,Nothing) -> pure TlsNoValidate + (True,True,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateFull cert + (True,True,Nothing) -> throwIO $ userError "Need to pass the root certificate on the PGTLS_ROOTCERT environment variable to validate FQHN" + (True,False,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateCA cert +#endif + pgDBPass <- maybe BSC.empty BSC.pack <$> lookupEnv "PG_PASS" + pgDBDebug <- isJust <$> lookupEnv "PG_DEBUG" + pure $ defaultPGDatabase + { pgDBName = "templatepg" + , pgDBUser = "templatepg" + , pgDBParams = [("TimeZone", "UTC")] + , pgDBDebug +#ifdef VERSION_tls + , pgDBTLS +#endif + , pgDBAddr + , pgDBPass + } +{-# NOINLINE db #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..c4873e8 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies, PatternGuards, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans -Wincomplete-uni-patterns #-} +--{-# OPTIONS_GHC -ddump-splices #-} +module Main (main) where + +import Control.Exception (try) +import Control.Monad (unless) +import Data.Char (isDigit, toUpper) +import Data.Int (Int32) +import qualified Data.Time as Time +import Data.Word (Word8) +import System.Exit (exitSuccess, exitFailure) +import qualified Test.QuickCheck as Q +import Test.QuickCheck.Test (isSuccess) + +import Database.PostgreSQL.Typed +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.Query (PGSimpleQuery, getQueryString) +import Database.PostgreSQL.Typed.Array () +import qualified Database.PostgreSQL.Typed.Range as Range +import Database.PostgreSQL.Typed.Enum +import Database.PostgreSQL.Typed.Inet +import Database.PostgreSQL.Typed.SQLToken +import Database.PostgreSQL.Typed.Relation +import qualified Database.PostgreSQL.Typed.ErrCodes as PGErr + +import Connect + +assert :: Bool -> IO () +assert False = exitFailure +assert True = return () + +useTPGDatabase db + +-- This runs at compile-time: +[pgSQL|!CREATE TYPE myenum AS enum ('abc', 'DEF', 'XX_ye')|] + +[pgSQL|!DROP TABLE myfoo|] +[pgSQL|!CREATE TABLE myfoo (id serial primary key, adé myenum, bar float)|] + +dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) + +deriving instance Show MyEnum + +dataPGRelation "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) + +instance Q.Arbitrary MyEnum where + arbitrary = Q.arbitraryBoundedEnum +instance Q.Arbitrary MyFoo where + arbitrary = MyFoo 0 <$> Q.arbitrary <*> Q.arbitrary +instance Eq MyFoo where + MyFoo _ a b == MyFoo _ a' b' = a == a' && b == b' +deriving instance Show MyFoo + +instance Q.Arbitrary Time.Day where + arbitrary = Time.ModifiedJulianDay <$> Q.arbitrary +instance Q.Arbitrary Time.DiffTime where + arbitrary = Time.picosecondsToDiffTime . (1000000 *) <$> Q.arbitrary +instance Q.Arbitrary Time.UTCTime where + arbitrary = Time.UTCTime <$> Q.arbitrary <*> ((Time.picosecondsToDiffTime . (1000000 *)) <$> Q.choose (0,86399999999)) +instance Q.Arbitrary Time.LocalTime where + arbitrary = Time.utcToLocalTime Time.utc <$> Q.arbitrary + +instance Q.Arbitrary a => Q.Arbitrary (Range.Bound a) where + arbitrary = do + u <- Q.arbitrary + if u + then return $ Range.Unbounded + else Range.Bounded <$> Q.arbitrary <*> Q.arbitrary +instance (Ord a, Q.Arbitrary a) => Q.Arbitrary (Range.Range a) where + arbitrary = Range.range <$> Q.arbitrary <*> Q.arbitrary + +instance Q.Arbitrary PGInet where + arbitrary = do + v6 <- Q.arbitrary + if v6 + then PGInet6 <$> Q.arbitrary <*> ((`mod` 129) <$> Q.arbitrary) + else PGInet <$> Q.arbitrary <*> ((`mod` 33) <$> Q.arbitrary) + +instance Q.Arbitrary SQLToken where + arbitrary = Q.oneof + [ SQLToken <$> Q.arbitrary + , SQLParam <$> Q.arbitrary + , SQLExpr <$> Q.arbitrary + , SQLQMark <$> Q.arbitrary + ] + +newtype SafeString = SafeString Q.UnicodeString + deriving (Eq, Ord, Show) +instance Q.Arbitrary SafeString where + arbitrary = SafeString <$> Q.suchThat Q.arbitrary (notElem '\0' . Q.getUnicodeString) + +getSafeString :: SafeString -> String +getSafeString (SafeString s) = Q.getUnicodeString s + +simple :: PGConnection -> OID -> IO [String] +simple c t = pgQuery c [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] +simpleApply :: PGConnection -> OID -> IO [Maybe String] +simpleApply c = pgQuery c . [pgSQL|?SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] +prepared :: PGConnection -> OID -> String -> IO [Maybe String] +prepared c t = pgQuery c . [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND typname = $2|] +preparedApply :: PGConnection -> Int32 -> IO [String] +preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] + +selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> SafeString -> [Maybe SafeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp pgc b c i f t z d p s l r e a = Q.ioProperty $ do + [(Just b', Just c', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc + [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${getSafeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap getSafeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + return $ Q.conjoin + [ i Q.=== i' + , c Q.=== c' + , b Q.=== b' + , getSafeString s Q.=== s' + , f Q.=== f' + , d Q.=== d' + , t Q.=== t' + , z Q.=== z' + , p Q.=== p' + , map (fmap getSafeString) l Q.=== l' + , Range.normalize' r Q.=== r' + , e Q.=== e' + , a Q.=== a' + ] + +selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> SafeString -> [Maybe SafeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp' pgc b i f t z d p s l r e a = Q.ioProperty $ do + [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc + [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${getSafeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap getSafeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + return $ Q.conjoin + [ i Q.=== i' + , b Q.=== b' + , getSafeString s Q.=== s' + , f Q.=== f' + , d Q.=== d' + , t Q.=== t' + , z Q.=== z' + , p Q.=== p' + , map (fmap getSafeString) l Q.=== l' + , Range.normalize' r Q.=== r' + , e Q.=== e' + , a Q.=== a' + ] + +selectFoo :: PGConnection -> [MyFoo] -> Q.Property +selectFoo pgc l = Q.ioProperty $ do + _ <- pgExecute pgc [pgSQL|TRUNCATE myfoo|] + let loop [] = return () + loop [x] = do + 1 <- pgExecute pgc [pgSQL|INSERT INTO myfoo (bar, adé) VALUES (${fooBar x}, ${fooAdé x})|] + return () + loop (x:y:r) = do + 1 <- pgExecute pgc [pgSQL|INSERT INTO myfoo (adé, bar) VALUES (${fooAdé x}, ${fooBar x})|] + 1 <- pgExecute pgc [pgSQL|$INSERT INTO myfoo (adé, bar) VALUES (${fooAdé y}, ${fooBar y})|] + loop r + loop l + r <- pgQuery pgc [pgSQL|SELECT * FROM myfoo ORDER BY id|] + return $ l Q.=== map (\(i,a,b) -> MyFoo i a b) r + +tokenProp :: String -> Q.Property +tokenProp s = + not (has0 s) Q.==> s Q.=== show (sqlTokens s) where + has0 ('$':'0':c:_) | isDigit c = True + has0 (_:r) = has0 r + has0 [] = False + +main :: IO () +main = do + c <- pgConnect db + + r <- Q.quickCheckResult + $ selectProp c + Q..&&. selectProp' c + Q..&&. selectFoo c + Q..&&. tokenProp + Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" + Q..&&. getQueryString (pgTypeEnv c) ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" + Q..&&. pgEnumValues Q.=== [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] + Q..&&. Q.conjoin (map (\(s, t) -> sqlTokens s Q.=== t) + [ ("", + []) + , ( "SELECT a from b WHERE c = ?" + , ["SELECT a from b WHERE c = ", SQLQMark False]) + , ( "INSERT INTO foo VALUES (?,?)" + , ["INSERT INTO foo VALUES (", SQLQMark False, ",", SQLQMark False, ")"]) + , ( "INSERT INTO foo VALUES ('?','''?')" + , ["INSERT INTO foo VALUES ('?','''?')"]) + , ( "-- really?\n-- yes'?\nINSERT INTO ? VALUES ('', ?, \"?asd\", e'?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ?)" + , ["-- really?\n-- yes'?\nINSERT INTO ", SQLQMark False, " VALUES ('', ", SQLQMark False, ", \"?asd\", e'?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ", SQLQMark False, ")"]) + , ( "some ${things? {don't}} change$1 $1\\?" + , ["some ", SQLExpr "things? {don't}", " change$1 ", SQLParam 1, SQLQMark True]) + ]) + assert $ isSuccess r + + ["box"] <- simple c 603 + [Just "box"] <- simpleApply c 603 + [Just "box"] <- prepared c 603 "box" + ["box"] <- preparedApply c 603 + [Just "line"] <- prepared c 628 "line" + ["line"] <- preparedApply c 628 + + pgSimpleQueries_ c "LISTEN channame; NOTIFY channame, 'oh hello'; SELECT pg_notify('channame', 'there')" + PGNotification _ "channame" "oh hello" <- pgGetNotification c + (-1, []) <- pgSimpleQuery c "NOTIFY channame" + + pgTransaction c $ do + (1, [[PGTextValue "1"]]) <- pgSimpleQuery c "SELECT 1" + (-1, []) <- pgSimpleQuery c "NOTIFY channame, 'nope'" + Left e1 <- try $ pgSimpleQuery c "SYNTAX_ERROR" + assert $ pgErrorCode e1 == PGErr.syntax_error + Left e2 <- try $ pgSimpleQuery c "SELECT 1" + assert $ pgErrorCode e2 == PGErr.in_failed_sql_transaction + + unless (pgSupportsTls c) $ do + [PGNotification _ "channame" "there", PGNotification _ "channame" ""] <- pgGetNotifications c + [] <- pgGetNotifications c + pure () + + pgDisconnect c + exitSuccess diff --git a/test/hdbc/LICENSE b/test/hdbc/LICENSE new file mode 100644 index 0000000..c49d345 --- /dev/null +++ b/test/hdbc/LICENSE @@ -0,0 +1,29 @@ +Based on HDBC-postgresql testsrc + +Copyright (c) 2005-2011 John Goerzen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* 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. + +* Neither the name of John Goerzen 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. diff --git a/test/hdbc/SpecificDB.hs b/test/hdbc/SpecificDB.hs new file mode 100644 index 0000000..1b86949 --- /dev/null +++ b/test/hdbc/SpecificDB.hs @@ -0,0 +1,27 @@ +module SpecificDB where +import Database.HDBC +import Database.PostgreSQL.Typed.HDBC + +import Connect + +connectDB :: IO Connection +connectDB = + handleSqlError (do dbh <- connect db + _ <- run dbh "SET client_min_messages=WARNING" [] + return dbh) + +dateTimeTypeOfSqlValue :: SqlValue -> String +dateTimeTypeOfSqlValue (SqlLocalDate _) = "date" +dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone" +dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone" +dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone" +dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone" +dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone" +dateTimeTypeOfSqlValue (SqlDiffTime _) = "interval" +dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric" +dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer" +dateTimeTypeOfSqlValue (SqlTimeDiff _) = "interval" +dateTimeTypeOfSqlValue _ = "text" + +supportsFracTime :: Bool +supportsFracTime = True diff --git a/test/hdbc/TestMisc.hs b/test/hdbc/TestMisc.hs new file mode 100644 index 0000000..15372f0 --- /dev/null +++ b/test/hdbc/TestMisc.hs @@ -0,0 +1,181 @@ +module TestMisc(tests, setup) where +import Test.HUnit +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception +import Data.Char +import Control.Monad +import qualified Data.Map as Map + +rowdata = + [[SqlInt32 0, toSql "Testing", SqlNull], + [SqlInt32 1, toSql "Foo", SqlInt32 5], + [SqlInt32 2, toSql "Bar", SqlInt32 9]] + +colnames = ["testid", "teststring", "testint"] +alrows :: [[(String, SqlValue)]] +alrows = map (zip colnames) rowdata + +setup f = dbTestCase $ \dbh -> + do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] + sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rowdata + finish sth + commit dbh + finally (f dbh) + (do run dbh "DROP TABLE hdbctest2" [] + commit dbh + ) + +cloneTest dbh a = + do dbh2 <- clone dbh + finally (handleSqlError (a dbh2)) + (handleSqlError (disconnect dbh2)) + +testgetColumnNames = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2" + execute sth [] + cols <- getColumnNames sth + finish sth + ["testid", "teststring", "testint"] @=? map (map toLower) cols + +testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` + ["sqlite3"])) $ + do sth <- prepare dbh "SELECT * from hdbctest2" + execute sth [] + cols <- describeResult sth + ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols + let coldata = map snd cols + assertBool "r0 type" (colType (coldata !! 0) `elem` + [SqlBigIntT, SqlIntegerT]) + assertBool "r1 type" (colType (coldata !! 1) `elem` + [SqlVarCharT, SqlLongVarCharT]) + assertBool "r2 type" (colType (coldata !! 2) `elem` + [SqlBigIntT, SqlIntegerT]) + finish sth + +testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` + ["sqlite3"])) $ + do cols <- describeTable dbh "hdbctest2" + ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols + let coldata = map snd cols + assertBool "r0 type" (colType (coldata !! 0) `elem` + [SqlBigIntT, SqlIntegerT]) + assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0)) + assertBool "r1 type" (colType (coldata !! 1) `elem` + [SqlVarCharT, SqlLongVarCharT]) + assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1)) + assertBool "r2 type" (colType (coldata !! 2) `elem` + [SqlBigIntT, SqlIntegerT]) + assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) + +testquickQuery = setup $ \dbh -> + do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + rowdata @=? results + +testfetchRowAL = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchRowAL sth >>= (Just (head alrows) @=?) + fetchRowAL sth >>= (Just (alrows !! 1) @=?) + fetchRowAL sth >>= (Just (alrows !! 2) @=?) + fetchRowAL sth >>= (Nothing @=?) + finish sth + +testfetchRowMap = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) + fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) + fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) + fetchRowMap sth >>= (Nothing @=?) + finish sth + +testfetchAllRowsAL = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchAllRowsAL sth >>= (alrows @=?) + +testfetchAllRowsMap = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) + +testexception = setup $ \dbh -> + catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" + execute sth [] + assertFailure "No exception was raised" + ) + (\e -> commit dbh) + +testrowcount = setup $ \dbh -> + do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] + assertEqual "UPDATE with no change" 0 r + r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] + assertEqual "UPDATE with 1 change" 1 r + r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] + assertEqual "UPDATE with 2 changes" 2 r + commit dbh + res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + assertEqual "final results" + [[SqlInt32 0, toSql "Testing", SqlInt32 26], + [SqlInt32 1, toSql "Foo", SqlInt32 27], + [SqlInt32 2, toSql "Bar", SqlInt32 27]] res + +{- Since we might be running against a live DB, we can't look at a specific +list here (though a SpecificDB test case may be able to). We can ensure +that our test table is, or is not, present, as appropriate. -} + +testgetTables1 = setup $ \dbh -> + do r <- getTables dbh + True @=? "hdbctest2" `elem` r + +testgetTables2 = dbTestCase $ \dbh -> + do r <- getTables dbh + False @=? "hdbctest2" `elem` r + +testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> + do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + rowdata @=? results + +testnulls = setup $ \dbh -> + do let dn = hdbcDriverName dbh + when (not (dn `elem` ["postgresql", "odbc", "postgresql-typed"])) ( + do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rows + finish sth + res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + seq (length res) rows @=? res + ) + where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], + [SqlInt32 101, SqlString "bar\NUL", SqlNull], + [SqlInt32 102, SqlString "\NUL", SqlNull], + [SqlInt32 103, SqlString "\xFF", SqlNull], + [SqlInt32 104, SqlString "regular", SqlNull]] + +testunicode = setup $ \dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rows + finish sth + res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + seq (length res) rows @=? res + where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], + [SqlInt32 101, SqlString "bar\x00A3", SqlNull], + [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] + +tests = TestList [TestLabel "getColumnNames" testgetColumnNames, + TestLabel "describeResult" testdescribeResult, + TestLabel "describeTable" testdescribeTable, + TestLabel "quickQuery" testquickQuery, + TestLabel "fetchRowAL" testfetchRowAL, + TestLabel "fetchRowMap" testfetchRowMap, + TestLabel "fetchAllRowsAL" testfetchAllRowsAL, + TestLabel "fetchAllRowsMap" testfetchAllRowsMap, + TestLabel "sql exception" testexception, + TestLabel "clone" testclone, + TestLabel "update rowcount" testrowcount, + TestLabel "get tables1" testgetTables1, + TestLabel "get tables2" testgetTables2, + TestLabel "nulls" testnulls, + TestLabel "unicode" testunicode] diff --git a/test/hdbc/TestSbasics.hs b/test/hdbc/TestSbasics.hs new file mode 100644 index 0000000..87cf761 --- /dev/null +++ b/test/hdbc/TestSbasics.hs @@ -0,0 +1,170 @@ +module TestSbasics(tests) where +import Test.HUnit +import Data.List +import Database.HDBC +import TestUtils +import Control.Exception + +openClosedb = sqlTestCase $ + do dbh <- connectDB + disconnect dbh + +multiFinish = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + sExecute sth [] + finish sth + finish sth + finish sth + ) + +runRawTest = dbTestCase (\dbh -> + do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" + tables <- getTables dbh + assertBool "valid1 table not created!" ("valid1" `elem` tables) + assertBool "valid2 table not created!" ("valid2" `elem` tables) + ) + +runRawErrorTest = dbTestCase (\dbh -> + let expected = "ERROR: syntax error at or near \"INVALID\"" + in do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` + (return . seErrorMsg) + assertBool "Error message inappropriate" (expected `isPrefixOf` err) + rollback dbh + tables <- getTables dbh + assertBool "valid1 table created!" (not $ "valid1" `elem` tables) + ) + + +basicQueries = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + sExecute sth [] + sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) + sFetchRow sth >>= (assertEqual "last row" Nothing) + ) + +createTable = dbTestCase (\dbh -> + do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + commit dbh + ) + +dropTable = dbTestCase (\dbh -> + do sRun dbh "DROP TABLE hdbctest1" [] + commit dbh + ) + +runReplace = dbTestCase (\dbh -> + do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" + sExecute sth [] + sFetchRow sth >>= (assertEqual "r1" (Just r1)) + sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", + Just "2", Nothing])) + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] + r2 = [Just "runReplace", Just "2", Nothing] + +executeReplace = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" + sExecute sth [Just "1", Just "1234", Just "Foo"] + sExecute sth [Just "2", Nothing, Just "Bar"] + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + sExecute sth [Just "executeReplace"] + sFetchRow sth >>= (assertEqual "r1" + (Just $ map Just ["executeReplace", "1", "1234", + "Foo"])) + sFetchRow sth >>= (assertEqual "r2" + (Just [Just "executeReplace", Just "2", Nothing, + Just "Bar"])) + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + +testExecuteMany = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" + sExecuteMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + sExecute sth [] + mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + where rows = [map Just ["1", "1234", "foo"], + map Just ["2", "1341", "bar"], + [Just "3", Nothing, Nothing]] + +testsFetchAllRows = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" + sExecuteMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + sExecute sth [] + results <- sFetchAllRows sth + assertEqual "" rows results + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +basicTransactions = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" + sExecute sth [Just "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) + + -- Now try a rollback + sExecuteMany sth rows + rollback dbh + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) + + -- Now try another commit + sExecuteMany sth rows + commit dbh + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +testWithTransaction = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" + sExecute sth [Just "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) + + -- Let's try a rollback. + catch (withTransaction dbh (\_ -> do sExecuteMany sth rows + fail "Foo")) + (\SomeException{} -> return ()) + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) + + -- And now a commit. + withTransaction dbh (\_ -> sExecuteMany sth rows) + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +tests = TestList + [ + TestLabel "openClosedb" openClosedb, + TestLabel "multiFinish" multiFinish, + TestLabel "runRawTest" runRawTest, + TestLabel "runRawErrorTest" runRawErrorTest, + TestLabel "basicQueries" basicQueries, + TestLabel "createTable" createTable, + TestLabel "runReplace" runReplace, + TestLabel "executeReplace" executeReplace, + TestLabel "executeMany" testExecuteMany, + TestLabel "sFetchAllRows" testsFetchAllRows, + TestLabel "basicTransactions" basicTransactions, + TestLabel "withTransaction" testWithTransaction, + TestLabel "dropTable" dropTable + ] diff --git a/test/hdbc/TestTime.hs b/test/hdbc/TestTime.hs new file mode 100644 index 0000000..55f990b --- /dev/null +++ b/test/hdbc/TestTime.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} + +module TestTime(tests) where +import Test.HUnit +import Database.HDBC +import TestUtils +import Control.Exception +import Data.Time (UTCTime, Day, NominalDiffTime) +import Data.Time.LocalTime +import Data.Time.Clock.POSIX +import Data.Maybe +import Data.Convertible +import SpecificDB +import Data.Time (parseTimeM, defaultTimeLocale, TimeLocale) +import Database.HDBC.Locale (iso8601DateFormat) + +instance Eq ZonedTime where + a == b = zonedTimeToUTC a == zonedTimeToUTC b + +testZonedTime :: ZonedTime +testZonedTime = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T %z")) + "1989-08-01 15:33:01 -0500" + +testZonedTimeFrac :: ZonedTime +testZonedTimeFrac = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) + "1989-08-01 15:33:01.536 -0500" + + +testDTType :: (Convertible SqlValue a, Show b, Eq b) => + a + -> (a -> SqlValue) + -> (a -> b) + -> Test +testDTType inputdata convToSqlValue toComparable = dbTestCase $ \dbh -> + do _ <- run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] + commit dbh + finally (testDT dbh) (do commit dbh + _ <- run dbh "DROP TABLE hdbctesttime" [] + commit dbh + ) + where testDT dbh = + do _ <- run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" + [iToSql 5, value] + commit dbh + r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] + case r of + ~[[testidsv, testvaluesv]] -> + do assertEqual "testid" (5::Int) (fromSql testidsv) + assertEqual "testvalue" + (toComparable inputdata) + (toComparable$ fromSql testvaluesv) + value = convToSqlValue inputdata + +mkTest :: (Eq b, Show b, Convertible SqlValue a) => String -> a -> (a -> SqlValue) -> (a -> b) -> Test +mkTest label inputdata convfunc toComparable = + TestLabel label (testDTType inputdata convfunc toComparable) + +tests :: Test +tests = TestList $ + ((TestLabel "Non-frac" $ testIt testZonedTime) : + if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) + +testIt :: ZonedTime -> Test +testIt baseZonedTime = + TestList [ mkTest "Day" baseDay toSql id + , mkTest "TimeOfDay" baseTimeOfDay toSql id + , mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql id + , mkTest "LocalTime" baseLocalTime toSql id + , mkTest "ZonedTime" baseZonedTime toSql id + , mkTest "UTCTime" baseUTCTime toSql id + , mkTest "DiffTime" baseDiffTime toSql id + , mkTest "POSIXTime" basePOSIXTime posixToSql id + ] + where + baseDay :: Day + baseDay = localDay baseLocalTime + + baseTimeOfDay :: TimeOfDay + baseTimeOfDay = localTimeOfDay baseLocalTime + + baseZonedTimeOfDay :: (TimeOfDay, TimeZone) + baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) + + baseLocalTime :: LocalTime + baseLocalTime = zonedTimeToLocalTime baseZonedTime + + baseUTCTime :: UTCTime + baseUTCTime = convert baseZonedTime + + baseDiffTime :: NominalDiffTime + baseDiffTime = basePOSIXTime + + basePOSIXTime :: POSIXTime + basePOSIXTime = convert baseZonedTime + +parseTime' :: TimeLocale -> String -> String -> Maybe ZonedTime +parseTime' = parseTimeM True diff --git a/test/hdbc/TestUtils.hs b/test/hdbc/TestUtils.hs new file mode 100644 index 0000000..f70627d --- /dev/null +++ b/test/hdbc/TestUtils.hs @@ -0,0 +1,29 @@ +module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where +import Database.HDBC +import Database.PostgreSQL.Typed.HDBC +import Test.HUnit +import Control.Exception +import SpecificDB(connectDB) + +sqlTestCase :: IO () -> Test +sqlTestCase a = + TestCase (handleSqlError a) + +dbTestCase :: (Connection -> IO ()) -> Test +dbTestCase a = + TestCase (do dbh <- connectDB + finally (handleSqlError (a dbh)) + (handleSqlError (disconnect dbh)) + ) + +printDBInfo :: IO () +printDBInfo = handleSqlError $ + do dbh <- connectDB + putStrLn "+-------------------------------------------------------------------------" + putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++ + ", bound to client: " ++ hdbcClientVer dbh + putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++ + ", bound to version: " ++ proxiedClientVer dbh + putStrLn $ "| Connected to server version: " ++ dbServerVer dbh + putStrLn "+-------------------------------------------------------------------------\n" + disconnect dbh diff --git a/test/hdbc/Testbasics.hs b/test/hdbc/Testbasics.hs new file mode 100644 index 0000000..1e0fa9d --- /dev/null +++ b/test/hdbc/Testbasics.hs @@ -0,0 +1,168 @@ +module Testbasics(tests) where +import Test.HUnit +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception + +openClosedb = sqlTestCase $ + do dbh <- connectDB + disconnect dbh + +multiFinish = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + r <- execute sth [] + assertEqual "basic count" 0 r + finish sth + finish sth + finish sth + ) + +basicQueries = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + execute sth [] >>= (0 @=?) + r <- fetchAllRows sth + assertEqual "converted from" [["2"]] (map (map fromSql) r) + assertEqual "int32 compare" [[SqlInt32 2]] r + assertEqual "iToSql compare" [[iToSql 2]] r + assertEqual "num compare" [[toSql (2::Int)]] r + assertEqual "nToSql compare" [[nToSql (2::Int)]] r + assertEqual "string compare" [[SqlString "2"]] r + ) + +createTable = dbTestCase (\dbh -> + do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + commit dbh + ) + +dropTable = dbTestCase (\dbh -> + do run dbh "DROP TABLE hdbctest1" [] + commit dbh + ) + +runReplace = dbTestCase (\dbh -> + do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + assertEqual "insert retval" 1 r + run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" + rv2 <- execute sth [] + assertEqual "select retval" 0 rv2 + r <- fetchAllRows sth + assertEqual "" [r1, r2] r + ) + where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] + +executeReplace = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" + execute sth [iToSql 1, iToSql 1234, toSql "Foo"] + execute sth [SqlInt32 2, SqlNull, toSql "Bar"] + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + execute sth [SqlString "executeReplace"] + r <- fetchAllRows sth + assertEqual "result" + [[toSql "executeReplace", iToSql 1, toSql "1234", + toSql "Foo"], + [toSql "executeReplace", iToSql 2, SqlNull, + toSql "Bar"]] + r + ) + +testExecuteMany = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + execute sth [] + r <- fetchAllRows sth + assertEqual "" rows r + ) + where rows = [map toSql ["1", "1234", "foo"], + map toSql ["2", "1341", "bar"], + [toSql "3", SqlNull, SqlNull]] + +testFetchAllRows = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + execute sth [] + results <- fetchAllRows sth + assertEqual "" rows results + ) + where rows = map (\x -> [iToSql x]) [1..9] + +testFetchAllRows' = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid" + execute sth [] + results <- fetchAllRows' sth + assertEqual "" rows results + ) + where rows = map (\x -> [iToSql x]) [1..9] + +basicTransactions = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" + execute sth [iToSql 0] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) + + -- Now try a rollback + executeMany sth rows + rollback dbh + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) + + -- Now try another commit + executeMany sth rows + commit dbh + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) + ) + where rows = map (\x -> [iToSql $ x]) [1..9] + +testWithTransaction = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" + execute sth [toSql "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) + + -- Let's try a rollback. + catch (withTransaction dbh (\_ -> do executeMany sth rows + fail "Foo")) + (\SomeException{} -> return ()) + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) + + -- And now a commit. + withTransaction dbh (\_ -> executeMany sth rows) + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) + ) + where rows = map (\x -> [iToSql x]) [1..9] + +tests = TestList + [ + TestLabel "openClosedb" openClosedb, + TestLabel "multiFinish" multiFinish, + TestLabel "basicQueries" basicQueries, + TestLabel "createTable" createTable, + TestLabel "runReplace" runReplace, + TestLabel "executeReplace" executeReplace, + TestLabel "executeMany" testExecuteMany, + TestLabel "fetchAllRows" testFetchAllRows, + TestLabel "fetchAllRows'" testFetchAllRows', + TestLabel "basicTransactions" basicTransactions, + TestLabel "withTransaction" testWithTransaction, + TestLabel "dropTable" dropTable + ] diff --git a/test/hdbc/Tests.hs b/test/hdbc/Tests.hs new file mode 100644 index 0000000..a924cab --- /dev/null +++ b/test/hdbc/Tests.hs @@ -0,0 +1,19 @@ +{- arch-tag: Tests main file +-} + +module Tests(tests) where +import Test.HUnit +import qualified Testbasics +import qualified TestSbasics +import qualified TestMisc +import qualified TestTime + +test1 = TestCase ("x" @=? "x") + +tests = TestList + [ TestLabel "test1" test1 + , TestLabel "String basics" TestSbasics.tests + , TestLabel "SqlValue basics" Testbasics.tests + , TestLabel "Misc tests" TestMisc.tests + , TestLabel "Time tests" TestTime.tests + ] diff --git a/test/hdbc/runtests.hs b/test/hdbc/runtests.hs new file mode 100644 index 0000000..c60979b --- /dev/null +++ b/test/hdbc/runtests.hs @@ -0,0 +1,16 @@ +{- arch-tag: Test runner +-} + +module Main where + +import Test.HUnit +import System.Exit +import Tests +import TestUtils + +main = do + printDBInfo + r <- runTestTT tests + if errors r == 0 && failures r == 0 + then exitSuccess + else exitFailure