mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-11 23:08:30 +01:00
Delete and ignore tmp folders created by ./verify-package/.
This commit is contained in:
Andreas Ländle
parent
0700c9110f
commit
4dcebea5e5
1
.gitignore
vendored
1
.gitignore
vendored
@ -1,5 +1,6 @@
|
||||
/builds/
|
||||
/logs/
|
||||
/tmp.*/
|
||||
nightly-*.yaml
|
||||
lts-*.yaml
|
||||
*.swp
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@ -1,25 +0,0 @@
|
||||
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
|
||||
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 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
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL CHRIS FORNO 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.
|
||||
@ -1,218 +0,0 @@
|
||||
-- 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 (<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
|
||||
-- '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")
|
||||
@ -1,336 +0,0 @@
|
||||
{-# 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"
|
||||
|
||||
@ -1,157 +0,0 @@
|
||||
{-# 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)
|
||||
@ -1,150 +0,0 @@
|
||||
{-# 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
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,347 +0,0 @@
|
||||
-- |
|
||||
-- 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
|
||||
@ -1,135 +0,0 @@
|
||||
{-# 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
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,292 +0,0 @@
|
||||
{-# 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 <http://www.postgresql.org/docs/current/static/sql-prepare.html> 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
|
||||
}
|
||||
@ -1,290 +0,0 @@
|
||||
{-# 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"
|
||||
|
||||
@ -1,217 +0,0 @@
|
||||
{-# 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
|
||||
@ -1,131 +0,0 @@
|
||||
-- |
|
||||
-- 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
|
||||
@ -1,198 +0,0 @@
|
||||
{-# 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
|
||||
@ -1,133 +0,0 @@
|
||||
{-# 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
|
||||
}
|
||||
@ -1,67 +0,0 @@
|
||||
{-# 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
|
||||
@ -1,827 +0,0 @@
|
||||
{-# 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 $ P.parseOnly JSON.json 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 $ P.parseOnly JSON.json 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", ?)
|
||||
-}
|
||||
@ -1,107 +0,0 @@
|
||||
# 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!"
|
||||
```
|
||||
@ -1,2 +0,0 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
@ -1,174 +0,0 @@
|
||||
Name: postgresql-typed
|
||||
Version: 0.6.2.3
|
||||
Cabal-Version: >= 1.10
|
||||
License: BSD3
|
||||
License-File: COPYING
|
||||
Copyright: 2010-2013 Chris Forno, 2014-2019 Dylan Simon
|
||||
Author: Dylan Simon
|
||||
Maintainer: Dylan Simon <dylan-pgtyped@dylex.net>
|
||||
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
|
||||
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
|
||||
@ -1,67 +0,0 @@
|
||||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
#
|
||||
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver:
|
||||
filepath: /home/andreas/stackage/stackage/snapshot.yaml
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||
# These entries can reference officially published versions as well as
|
||||
# forks / in-progress versions pinned to a git hash. For example:
|
||||
#
|
||||
# extra-deps:
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of Stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=2.11"
|
||||
#
|
||||
# Override the architecture used by Stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by Stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
# extra-lib-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
@ -1,42 +0,0 @@
|
||||
{-# 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
|
||||
]
|
||||
@ -1,58 +0,0 @@
|
||||
{-# 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 #-}
|
||||
@ -1,220 +0,0 @@
|
||||
{-# 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
|
||||
@ -1,27 +0,0 @@
|
||||
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
|
||||
@ -1,181 +0,0 @@
|
||||
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]
|
||||
@ -1,170 +0,0 @@
|
||||
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
|
||||
]
|
||||
@ -1,97 +0,0 @@
|
||||
{-# 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
|
||||
@ -1,29 +0,0 @@
|
||||
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
|
||||
@ -1,168 +0,0 @@
|
||||
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
|
||||
]
|
||||
@ -1,19 +0,0 @@
|
||||
{- 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
|
||||
]
|
||||
@ -1,16 +0,0 @@
|
||||
{- 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
|
||||
Loading…
Reference in New Issue
Block a user