diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +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 Chris Forno nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +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. diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed.hs @@ -0,0 +1,210 @@ +-- 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 + + -- **TemplatePG compatibility + -- $templatepg + + -- *Advanced usage + + -- **Types + -- $types + + -- **A Note About NULL + -- $nulls + + -- *Caveats + -- $caveats + + -- **Tips + -- $tips + + ) where + +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.Query + +-- $intro +-- PostgreSQL-Typed is designed with 2 goals in mind: safety and performance. The +-- primary focus is on safety. +-- +-- To help ensure safety, it uses the PostgreSQL server to parse every query +-- and statement in your code to infer types at compile-time. This means that +-- in theory you cannot get a syntax error at runtime. Getting proper types at +-- compile time has the nice side-effect that it eliminates run-time type +-- casting and usually results in less code. This approach was inspired by +-- MetaHDBC () and PG'OCaml +-- (). +-- +-- While compile-time query analysis eliminates many errors, it doesn't +-- eliminate all of them. If you modify the database without recompilation or +-- have an error in a trigger or function, for example, you can still trigger a +-- 'PGException' 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 'useTHConnection' at the top level: +-- +-- > myConnect = pgConnect ... +-- > useTHConnection myConnect +-- +-- Note that due to TH limitations, @myConnect@ must be in-line or in a different module, and 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 that does not contain @{}@) 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 by 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, 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 '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 'withTransaction', 'rollback', and '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). +-- Currenly only 1-dimentional arrays are supported. +-- +-- However you can add support for your own types or add flexibility to existing types by creating new instances of 'PGParameter' (for encoding) and 'PGColumn' (for decoding). +-- If you also want to support arrays of a new type, you should also provide a 'PGArrayType' instance (or 'PGRangeType' for new ranges): +-- +-- > instance PGParameter "mytype" MyType where +-- > pgEncode _ (v :: MyType) = ... :: ByteString +-- > instance PGColumn "mytype" MyType where +-- > pgDecode _ (s :: ByteString) = ... :: 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. +-- However, some features have even stronger requirements: +-- +-- * The @$(type, ...)@ feature stores OIDs for user types, so the resulting code can only be run 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 this construct. + +-- $tips +-- If you find yourself pattern matching on result tuples just to pass them on +-- to functions, you can use @uncurryN@ from the tuple package. The following +-- examples are equivalent. +-- +-- > (a, b, c) <- $(queryTuple \"SELECT a, b, c FROM table LIMIT 1\") +-- > someFunction a b c +-- > uncurryN someFunction \`liftM\` $(queryTuple \"SELECT a, b, c FROM table LIMIT 1\") diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +-- | +-- Module: Database.PostgreSQL.Typed.Enum +-- Copyright: 2015 Dylan Simon +-- +-- Support for PostgreSQL enums. + +module Database.PostgreSQL.Typed.Enum + ( makePGEnum + ) where + +import Control.Monad (when) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.UTF8 as U +import Data.Foldable (toList) +import qualified Data.Sequence as Seq +import qualified Language.Haskell.TH as TH + +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.Types + +-- |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 +-- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: +-- +-- @ +-- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded) +-- instance PGType Foo where ... +-- registerPGType \"foo\" (ConT ''Foo) +-- @ +-- +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds +makePGEnum :: String -- ^ PostgreSQL enum type name + -> String -- ^ Haskell type to create + -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ + -> TH.DecsQ +makePGEnum name typs valnf = do + (_, vals) <- TH.runIO $ withTPGConnection $ \c -> + pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type t ON enumtypid = t.oid WHERE typtype = 'e' AND format_type(t.oid, -1) = " ++ pgQuote name ++ " ORDER BY enumsortorder" + when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" + let + valn = map (\[PGTextValue v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) $ toList vals + dv <- TH.newName "x" + ds <- TH.newName "s" + return + [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded] + , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` TH.LitT (TH.StrTyLit name) `TH.AppT` typt) + [ TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.WildP, TH.ConP n []] + (TH.NormalB $ TH.VarE 'BSC.pack `TH.AppE` TH.LitE l) []) valn ] + , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` TH.LitT (TH.StrTyLit name) `TH.AppT` typt) + [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.NormalB $ TH.CaseE (TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv) $ map (\(l, n) -> + TH.Match (TH.LitP l) (TH.NormalB $ TH.ConE n) []) valn ++ + [TH.Match (TH.VarP ds) (TH.NormalB $ TH.AppE (TH.VarE 'error) $ + TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE ds)) + []]) + []] ] + ] + where + typn = TH.mkName typs + typt = TH.ConT typn diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -0,0 +1,618 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards, DataKinds #-} +-- Copyright 2010, 2011, 2012, 2013 Chris Forno +-- Copyright 2014-2015 Dylan Simon + +-- |The Protocol module allows for direct, low-level communication with a +-- PostgreSQL server over TCP/IP. You probably don't want to use this module +-- directly. + +module Database.PostgreSQL.Typed.Protocol ( + PGDatabase(..) + , defaultPGDatabase + , PGConnection + , PGError(..) + , pgMessageCode + , pgTypeEnv + , pgConnect + , pgDisconnect + , pgReconnect + , pgDescribe + , pgSimpleQuery + , pgPreparedQuery + , pgPreparedLazyQuery + , pgCloseStatement + ) where + +import Control.Applicative ((<$>), (<$)) +import Control.Arrow (second) +import Control.Exception (Exception, throwIO) +import Control.Monad (liftM2, replicateM, when, unless) +#ifdef USE_MD5 +import qualified Crypto.Hash as Hash +#endif +import qualified Data.Binary.Get as G +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Lazy.Internal (smallChunkSize) +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.Foldable as Fold +import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) +import qualified Data.Map.Lazy as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, (<>)) +import qualified Data.Sequence as Seq +import Data.Typeable (Typeable) +import Data.Word (Word32) +import Network (HostName, PortID(..), connectTo) +import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) +import System.IO.Unsafe (unsafeInterleaveIO) +import Text.Read (readMaybe) + +import Database.PostgreSQL.Typed.Types + +data PGState + = StateUnknown + | StateIdle + | StateTransaction + | StateTransactionFailed + | StateClosed + deriving (Show, Eq) + +-- |Information for how to connect to a database, to be passed to 'pgConnect'. +data PGDatabase = PGDatabase + { pgDBHost :: HostName -- ^ The hostname (ignored if 'pgDBPort' is 'UnixSocket') + , pgDBPort :: PortID -- ^ The port, likely either @PortNumber 5432@ or @UnixSocket \"/tmp/.s.PGSQL.5432\"@ + , pgDBName :: String -- ^ The name of the database + , pgDBUser, pgDBPass :: String + , pgDBDebug :: Bool -- ^ Log all low-level server messages + , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) + } + +instance Eq PGDatabase where + PGDatabase h1 s1 n1 u1 p1 _ _ == PGDatabase h2 s2 n2 u2 p2 _ _ = + h1 == h2 && s1 == s2 && n1 == n2 && u1 == u2 && p1 == p2 + +-- |An established connection to the PostgreSQL server. +-- These objects are not thread-safe and must only be used for a single request at a time. +data PGConnection = PGConnection + { connHandle :: Handle + , connDatabase :: !PGDatabase + , connPid :: !Word32 -- unused + , connKey :: !Word32 -- unused + , connParameters :: Map.Map String String + , connTypeEnv :: PGTypeEnv + , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) + , connState :: IORef PGState + , connInput :: IORef (G.Decoder PGBackendMessage) + } + +data ColDescription = ColDescription + { colName :: String + , colTable :: !OID + , colNumber :: !Int + , colType :: !OID + , colModifier :: !Word32 + , colBinary :: !Bool + } deriving (Show) + +type MessageFields = Map.Map Char String + +-- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. +-- See . +data PGFrontendMessage + = StartupMessage [(String, String)] -- only sent first + | CancelRequest !Word32 !Word32 -- sent first on separate connection + | Bind { statementName :: String, bindParameters :: PGValues, binaryColumns :: [Bool] } + | Close { statementName :: String } + -- |Describe a SQL query/statement. The SQL string can contain + -- parameters ($1, $2, etc.). + | Describe { statementName :: String } + | Execute !Word32 + | Flush + -- |Parse SQL Destination (prepared statement) + | Parse { statementName :: String, queryString :: String, parseTypes :: [OID] } + | PasswordMessage BS.ByteString + -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, + -- etc.) aren't allowed. + | SimpleQuery { queryString :: String } + | Sync + | Terminate + deriving (Show) + +-- |PGBackendMessage represents a PostgreSQL protocol message that we'll receive. +-- See . +data PGBackendMessage + = AuthenticationOk + | AuthenticationCleartextPassword + | AuthenticationMD5Password BS.ByteString + -- AuthenticationSCMCredential + | BackendKeyData Word32 Word32 + | BindComplete + | CloseComplete + -- |CommandComplete is bare for now, although it could be made + -- to contain the number of rows affected by statements in a + -- later version. + | CommandComplete BS.ByteString + -- |Each DataRow (result of a query) is a list of ByteStrings + -- (or just Nothing for null values, to distinguish them from + -- emtpy strings). The ByteStrings can then be converted to + -- the appropriate type by 'pgStringToType'. + | DataRow PGValues + | EmptyQueryResponse + -- |An ErrorResponse contains the severity, "SQLSTATE", and + -- message of an error. See + -- . + | ErrorResponse { messageFields :: MessageFields } + | NoData + | NoticeResponse { messageFields :: MessageFields } + -- |A ParameterDescription describes the type of a given SQL + -- query/statement parameter ($1, $2, etc.). Unfortunately, + -- PostgreSQL does not give us nullability information for the + -- parameter. + | ParameterDescription [OID] + | ParameterStatus String String + | ParseComplete + | PortalSuspended + | ReadyForQuery PGState + -- |A RowDescription contains the name, type, table OID, and + -- column number of the resulting columns(s) of a query. The + -- column number is useful for inferring nullability. + | RowDescription [ColDescription] + deriving (Show) + +-- |PGException is thrown upon encountering an 'ErrorResponse' with severity of +-- ERROR, FATAL, or PANIC. It holds the message of the error. +data PGError = PGError MessageFields + deriving (Typeable) + +instance Show PGError where + show (PGError m) = displayMessage m + +instance Exception PGError + +-- |Produce a human-readable string representing the message +displayMessage :: MessageFields -> String +displayMessage m = "PG" ++ f 'S' ++ " [" ++ f 'C' ++ "]: " ++ f 'M' ++ '\n' : f 'D' + where f c = Map.findWithDefault "" c m + +makeMessage :: String -> String -> MessageFields +makeMessage m d = Map.fromAscList [('D', d), ('M', m)] + +-- |Message SQLState code. +-- See . +pgMessageCode :: MessageFields -> String +pgMessageCode = Map.findWithDefault "" 'C' + +defaultLogMessage :: MessageFields -> IO () +defaultLogMessage = hPutStrLn stderr . displayMessage + +-- |A database connection with sane defaults: +-- localhost:5432:postgres +defaultPGDatabase :: PGDatabase +defaultPGDatabase = PGDatabase "localhost" (PortNumber 5432) "postgres" "postgres" "" False defaultLogMessage + +connDebug :: PGConnection -> Bool +connDebug = pgDBDebug . connDatabase + +connLogMessage :: PGConnection -> MessageFields -> IO () +connLogMessage = pgDBLogMessage . connDatabase + +pgTypeEnv :: PGConnection -> PGTypeEnv +pgTypeEnv = connTypeEnv + +#ifdef USE_MD5 +md5 :: BS.ByteString -> BS.ByteString +md5 = Hash.digestToHexByteString . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) +#endif + + +nul :: B.Builder +nul = B.word8 0 + +-- |Convert a string to a NULL-terminated UTF-8 string. The PostgreSQL +-- protocol transmits most strings in this format. +pgString :: String -> B.Builder +pgString s = B.stringUtf8 s <> nul + +-- |Given a message, determinal the (optional) type ID and the body +messageBody :: PGFrontendMessage -> (Maybe Char, B.Builder) +messageBody (StartupMessage kv) = (Nothing, B.word32BE 0x30000 + <> Fold.foldMap (\(k, v) -> pgString k <> pgString v) kv <> nul) +messageBody (CancelRequest pid key) = (Nothing, B.word32BE 80877102 + <> B.word32BE pid <> B.word32BE key) +messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = (Just 'B', + nul <> pgString n + <> (if any fmt p + then B.word16BE (fromIntegral $ length p) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum . fmt) p + else B.word16BE 0) + <> B.word16BE (fromIntegral $ length p) <> Fold.foldMap val p + <> (if or bc + then B.word16BE (fromIntegral $ length bc) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum) bc + else B.word16BE 0)) + where + fmt (PGBinaryValue _) = True + fmt _ = False + val PGNullValue = B.int32BE (-1) + val (PGTextValue v) = B.word32BE (fromIntegral $ BS.length v) <> B.byteString v + val (PGBinaryValue v) = B.word32BE (fromIntegral $ BS.length v) <> B.byteString v +messageBody Close{ statementName = n } = (Just 'C', + B.char7 'S' <> pgString n) +messageBody Describe{ statementName = n } = (Just 'D', + B.char7 'S' <> pgString n) +messageBody (Execute r) = (Just 'E', + nul <> B.word32BE r) +messageBody Flush = (Just 'H', mempty) +messageBody Parse{ statementName = n, queryString = s, parseTypes = t } = (Just 'P', + pgString n <> pgString s + <> B.word16BE (fromIntegral $ length t) <> Fold.foldMap B.word32BE t) +messageBody (PasswordMessage s) = (Just 'p', + B.byteString s <> nul) +messageBody SimpleQuery{ queryString = s } = (Just 'Q', + pgString s) +messageBody Sync = (Just 'S', mempty) +messageBody Terminate = (Just 'X', mempty) + +-- |Send a message to PostgreSQL (low-level). +pgSend :: PGConnection -> PGFrontendMessage -> IO () +pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do + writeIORef sr StateUnknown + when (connDebug c) $ putStrLn $ "> " ++ show msg + B.hPutBuilder h $ Fold.foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + BS.length b) + BS.hPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length + where (t, b) = second (BSL.toStrict . B.toLazyByteString) $ messageBody msg + +pgFlush :: PGConnection -> IO () +pgFlush = hFlush . connHandle + + +getPGString :: G.Get String +getPGString = BSLU.toString <$> G.getLazyByteStringNul + +getByteStringNul :: G.Get BS.ByteString +getByteStringNul = fmap BSL.toStrict G.getLazyByteStringNul + +getMessageFields :: G.Get MessageFields +getMessageFields = g . w2c =<< G.getWord8 where + g '\0' = return Map.empty + g f = liftM2 (Map.insert f . BSU.toString) getByteStringNul getMessageFields + +-- |Parse an incoming message. +getMessageBody :: Char -> G.Get PGBackendMessage +getMessageBody 'R' = auth =<< G.getWord32be where + auth 0 = return AuthenticationOk + auth 3 = return AuthenticationCleartextPassword + auth 5 = AuthenticationMD5Password <$> G.getByteString 4 + auth op = fail $ "pgGetMessage: unsupported authentication type: " ++ show op +getMessageBody 't' = do + numParams <- G.getWord16be + ParameterDescription <$> replicateM (fromIntegral numParams) G.getWord32be +getMessageBody 'T' = do + numFields <- G.getWord16be + RowDescription <$> replicateM (fromIntegral numFields) getField where + getField = do + name <- getPGString + oid <- G.getWord32be -- table OID + col <- G.getWord16be -- column number + typ' <- G.getWord32be -- type + _ <- G.getWord16be -- type size + tmod <- G.getWord32be -- type modifier + fmt <- G.getWord16be -- format code + return $ ColDescription + { colName = name + , colTable = oid + , colNumber = fromIntegral col + , colType = typ' + , colModifier = tmod + , colBinary = toEnum (fromIntegral fmt) + } +getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where + rs 'I' = return StateIdle + rs 'T' = return StateTransaction + rs 'E' = return StateTransactionFailed + rs s = fail $ "pgGetMessage: unknown ready state: " ++ show s +getMessageBody '1' = return ParseComplete +getMessageBody '2' = return BindComplete +getMessageBody '3' = return CloseComplete +getMessageBody 'C' = CommandComplete <$> getByteStringNul +getMessageBody 'S' = liftM2 ParameterStatus getPGString getPGString +getMessageBody 'D' = do + numFields <- G.getWord16be + DataRow <$> replicateM (fromIntegral numFields) (getField =<< G.getWord32be) where + getField 0xFFFFFFFF = return PGNullValue + getField len = PGTextValue <$> G.getByteString (fromIntegral len) + -- could be binary, too, but we don't know here, so have to choose one +getMessageBody 'K' = liftM2 BackendKeyData G.getWord32be G.getWord32be +getMessageBody 'E' = ErrorResponse <$> getMessageFields +getMessageBody 'I' = return EmptyQueryResponse +getMessageBody 'n' = return NoData +getMessageBody 's' = return PortalSuspended +getMessageBody 'N' = NoticeResponse <$> getMessageFields +getMessageBody t = fail $ "pgGetMessage: unknown message type: " ++ show t + +getMessage :: G.Decoder PGBackendMessage +getMessage = G.runGetIncremental $ do + typ <- G.getWord8 + s <- G.bytesRead + len <- G.getWord32be + msg <- getMessageBody (w2c typ) + e <- G.bytesRead + let r = fromIntegral len - fromIntegral (e - s) + when (r > 0) $ G.skip r + when (r < 0) $ fail "pgReceive: decoder overran message" + return msg + +pgRecv :: Bool -> PGConnection -> IO (Maybe PGBackendMessage) +pgRecv block c@PGConnection{ connHandle = h, connInput = dr } = + go =<< readIORef dr where + next = writeIORef dr + state s d = writeIORef (connState c) s >> next d + new = G.pushChunk getMessage + go (G.Done b _ m) = do + when (connDebug c) $ putStrLn $ "< " ++ show m + got (new b) m + go (G.Fail _ _ r) = next (new BS.empty) >> fail r -- not clear how can recover + go d@(G.Partial r) = do + b <- (if block then BS.hGetSome else BS.hGetNonBlocking) h smallChunkSize + if BS.null b + then Nothing <$ next d + else go $ r (Just b) + got :: G.Decoder PGBackendMessage -> PGBackendMessage -> IO (Maybe PGBackendMessage) + got d (NoticeResponse m) = connLogMessage c m >> go d + got d m@(ReadyForQuery s) = Just m <$ state s d + got d m@(ErrorResponse _) = Just m <$ state StateUnknown d + got d m = Just m <$ next d + +-- |Receive the next message from PostgreSQL (low-level). Note that this will +-- block until it gets a message. +pgReceive :: PGConnection -> IO PGBackendMessage +pgReceive c = do + r <- pgRecv True c + case r of + Nothing -> do + writeIORef (connState c) StateClosed + fail $ "pgReceive: connection closed" + Just ErrorResponse{ messageFields = m } -> throwIO (PGError m) + Just m -> return m + +-- |Connect to a PostgreSQL server. +pgConnect :: PGDatabase -> IO PGConnection +pgConnect db = do + state <- newIORef StateUnknown + prep <- newIORef (0, Map.empty) + input <- newIORef getMessage + h <- connectTo (pgDBHost db) (pgDBPort db) + let c = PGConnection + { connHandle = h + , connDatabase = db + , connPid = 0 + , connKey = 0 + , connParameters = Map.empty + , connPreparedStatements = prep + , connState = state + , connTypeEnv = undefined + , connInput = input + } + pgSend c $ StartupMessage + [ ("user", pgDBUser db) + , ("database", pgDBName db) + , ("client_encoding", "UTF8") + , ("standard_conforming_strings", "on") + , ("bytea_output", "hex") + , ("DateStyle", "ISO, YMD") + , ("IntervalStyle", "iso_8601") + ] + pgFlush c + conn c + where + conn c = pgReceive c >>= msg c + msg c (ReadyForQuery _) = return c + { connTypeEnv = PGTypeEnv + { pgIntegerDatetimes = (connParameters c Map.! "integer_datetimes") == "on" + } + } + msg c (BackendKeyData p k) = conn c{ connPid = p, connKey = k } + msg c (ParameterStatus k v) = conn c{ connParameters = Map.insert k v $ connParameters c } + msg c AuthenticationOk = conn c + msg c AuthenticationCleartextPassword = do + pgSend c $ PasswordMessage $ BSU.fromString $ pgDBPass db + pgFlush c + conn c +#ifdef USE_MD5 + msg c (AuthenticationMD5Password salt) = do + pgSend c $ PasswordMessage $ BSC.pack "md5" `BS.append` md5 (md5 (BSU.fromString (pgDBPass db ++ pgDBUser db)) `BS.append` salt) + pgFlush c + conn c +#endif + msg _ m = fail $ "pgConnect: unexpected response: " ++ show m + +-- |Disconnect cleanly from the PostgreSQL server. +pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' + -> IO () +pgDisconnect c@PGConnection{ connHandle = h, connState = s } = do + pgSend c Terminate + writeIORef s StateClosed + hClose h + +-- |Possibly re-open a connection to a different database, either reusing the connection if the given database is already connected or closing it and opening a new one. +-- Regardless, the input connection must not be used afterwards. +pgReconnect :: PGConnection -> PGDatabase -> IO PGConnection +pgReconnect c@PGConnection{ connDatabase = cd, connState = cs } d = do + s <- readIORef cs + if cd == d && s /= StateClosed + then return c{ connDatabase = d } + else do + when (s /= StateClosed) $ pgDisconnect c + pgConnect d + +pgSync :: PGConnection -> IO () +pgSync c@PGConnection{ connState = sr } = do + s <- readIORef sr + when (s == StateClosed) $ fail "pgSync: operation on closed connection" + when (s == StateUnknown) $ wait False where + wait s = do + r <- pgRecv s c + case r of + Nothing -> do + pgSend c Sync + pgFlush c + wait True + (Just (ErrorResponse{ messageFields = m })) -> do + connLogMessage c m + wait s + (Just (ReadyForQuery _)) -> return () + (Just m) -> do + connLogMessage c $ makeMessage ("Unexpected server message: " ++ show m) "Each statement should only contain a single query" + wait s + +-- |Describe a SQL statement/query. A statement description consists of 0 or +-- more parameter descriptions (a PostgreSQL type) and zero or more result +-- field descriptions (for queries) (consist of the name of the field, the +-- type of the field, and a nullability indicator). +pgDescribe :: PGConnection -> String -- ^ SQL string + -> [OID] -- ^ Optional type specifications + -> Bool -- ^ Guess nullability, otherwise assume everything is + -> IO ([OID], [(String, OID, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. +pgDescribe h sql types nulls = do + pgSync h + pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = types } + pgSend h $ Describe "" + pgSend h Flush + pgSend h Sync + pgFlush h + ParseComplete <- pgReceive h + ParameterDescription ps <- pgReceive h + m <- pgReceive h + (,) ps <$> case m of + NoData -> return [] + RowDescription r -> mapM desc r + _ -> fail $ "describeStatement: unexpected response: " ++ show m + where + desc (ColDescription{ colName = name, colTable = tab, colNumber = col, colType = typ }) = do + n <- nullable tab col + return (name, typ, n) + -- We don't get nullability indication from PostgreSQL, at least not directly. + -- Without any hints, we have to assume that the result can be null and + -- leave it up to the developer to figure it out. + nullable oid col + | nulls && oid /= 0 = do + -- In cases where the resulting field is tracable to the column of a + -- table, we can check there. + (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) + case Fold.toList r of + [[PGTextValue s]] -> return $ not $ pgDecode (PGTypeProxy :: PGTypeName "boolean") s + [] -> return True + _ -> fail $ "Failed to determine nullability of column #" ++ show col + | otherwise = return True + +rowsAffected :: BS.ByteString -> Int +rowsAffected = ra . BSC.words where + ra [] = -1 + ra l = fromMaybe (-1) $ readMaybe $ BSC.unpack $ last l + +-- Do we need to use the ColDescription here always, or are the request formats okay? +fixBinary :: [Bool] -> PGValues -> PGValues +fixBinary (False:b) (PGBinaryValue x:r) = PGTextValue x : fixBinary b r +fixBinary (True :b) (PGTextValue x:r) = PGBinaryValue x : fixBinary b r +fixBinary (_:b) (x:r) = x : fixBinary b r +fixBinary _ l = l + +-- |A simple query is one which requires sending only a single 'SimpleQuery' +-- message to the PostgreSQL server. The query is sent as a single string; you +-- cannot bind parameters. Note that queries can return 0 results (an empty +-- list). +pgSimpleQuery :: PGConnection -> String -- ^ SQL string + -> IO (Int, Seq.Seq PGValues) -- ^ The number of rows affected and a list of result rows +pgSimpleQuery h sql = do + pgSync h + pgSend h $ SimpleQuery sql + pgFlush h + go start where + go = (pgReceive h >>=) + start (RowDescription rd) = go $ row (map colBinary rd) Seq.empty + start (CommandComplete c) = got c Seq.empty + start EmptyQueryResponse = return (0, Seq.empty) + start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m + row bc s (DataRow fs) = go $ row bc (s Seq.|> fixBinary bc fs) + row _ s (CommandComplete c) = got c s + row _ _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m + got c s = return (rowsAffected c, s) + +pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) +pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do + pgSync c + (p, n) <- atomicModifyIORef' psr $ \(i, m) -> + maybe ((succ i, m), (False, i)) ((,) (i, m) . (,) True) $ Map.lookup key m + let sn = show n + unless p $ + pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = types } + pgSend c $ Bind{ statementName = sn, bindParameters = bind, binaryColumns = bc } + let + go = pgReceive c >>= start + start ParseComplete = do + modifyIORef psr $ \(i, m) -> + (i, Map.insert key n m) + go + start BindComplete = return () + start m = fail $ "pgPrepared: unexpected response: " ++ show m + return go + where key = (sql, types) + +-- |Prepare a statement, bind it, and execute it. +-- If the given statement has already been prepared (and not yet closed) on this connection, it will be re-used. +pgPreparedQuery :: PGConnection -> String -- ^ SQL statement with placeholders + -> [OID] -- ^ Optional type specifications (only used for first call) + -> PGValues -- ^ Paremeters to bind to placeholders + -> [Bool] -- ^ Requested binary format for result columns + -> IO (Int, Seq.Seq PGValues) +pgPreparedQuery c sql types bind bc = do + start <- pgPreparedBind c sql types bind bc + pgSend c $ Execute 0 + pgSend c Flush + pgSend c Sync + pgFlush c + start + go Seq.empty + where + go = (pgReceive c >>=) . row + row s (DataRow fs) = go (s Seq.|> fixBinary bc fs) + row s (CommandComplete r) = return (rowsAffected r, s) + row s EmptyQueryResponse = return (0, s) + row _ m = fail $ "pgPreparedQuery: unexpected row: " ++ show m + +-- |Like 'pgPreparedQuery' but requests results lazily in chunks of the given size. +-- Does not use a named portal, so other requests may not intervene. +pgPreparedLazyQuery :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) + -> IO [PGValues] +pgPreparedLazyQuery c sql types bind bc count = do + start <- pgPreparedBind c sql types bind bc + unsafeInterleaveIO $ do + execute + start + go Seq.empty + where + execute = do + pgSend c $ Execute count + pgSend c $ Flush + pgFlush c + go = (pgReceive c >>=) . row + row s (DataRow fs) = go (s Seq.|> fixBinary bc fs) + row s PortalSuspended = (Fold.toList s ++) <$> unsafeInterleaveIO (execute >> go Seq.empty) + row s (CommandComplete _) = return $ Fold.toList s + row s EmptyQueryResponse = return $ Fold.toList s + row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m + +-- |Close a previously prepared query (if necessary). +pgCloseStatement :: PGConnection -> String -> [OID] -> IO () +pgCloseStatement c@PGConnection{ connPreparedStatements = psr } sql types = do + mn <- atomicModifyIORef psr $ \(i, m) -> + let (n, m') = Map.updateLookupWithKey (\_ _ -> Nothing) (sql, types) m in ((i, m'), n) + Fold.forM_ mn $ \n -> do + pgSync c + pgSend c $ Close{ statementName = show n } + pgFlush c + CloseComplete <- pgReceive c + return () diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/Query.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-} +module Database.PostgreSQL.Typed.Query + ( PGQuery(..) + , PGSimpleQuery + , PGPreparedQuery + , rawPGSimpleQuery + , rawPGPreparedQuery + , QueryFlags(..) + , simpleFlags + , makePGQuery + , pgSQL + , pgExecute + , pgQuery + , pgLazyQuery + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow ((***), first, second) +import Control.Exception (try) +import Control.Monad (when, mapAndUnzipM) +import Data.Array (listArray, (!), inRange) +import Data.Char (isDigit, isSpace) +import Data.Foldable (toList) +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe, isNothing) +import Data.Sequence (Seq) +import Data.Word (Word32) +import Language.Haskell.Meta.Parse (parseExp) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Numeric (readDec) + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TH + +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, Seq a) +class PGQuery q PGValues => PGRawQuery q + +-- |Execute a query that does not return result. +-- 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 = toList . snd <$> pgRunQuery c q + + +data SimpleQuery = SimpleQuery String +instance PGQuery SimpleQuery PGValues where + pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql +instance PGRawQuery SimpleQuery where + + +data PreparedQuery = PreparedQuery String [OID] PGValues [Bool] +instance PGQuery PreparedQuery PGValues where + pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc +instance PGRawQuery PreparedQuery where + + +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 + +instance Functor (QueryParser q) where + fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) + +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 :: String -> PGSimpleQuery PGValues +rawPGSimpleQuery = rawParser . SimpleQuery + +-- |Make a prepared query directly from a query string and bind parameters, with no type inference +rawPGPreparedQuery :: String -> 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 not understand strings or other SQL syntax, so any literal occurrence of the string @${@ must be escaped as @$${@. +-- Embedded expressions may not contain @{@ or @}@. +sqlPlaceholders :: String -> (String, [String]) +sqlPlaceholders = sph (1 :: Int) where + sph n ('$':'$':'{':s) = first (('$':) . ('{':)) $ sph n s + sph n ('$':'{':s) + | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = + (('$':show n) ++) *** (e :) $ sph (succ n) r + | otherwise = error $ "Error parsing SQL statement: could not find end of expression: ${" ++ s + sph n (c:s) = first (c:) $ sph n s + sph _ "" = ("", []) + +-- |Given a SQL statement with placeholders of the form @$N@ and a list of TH 'String' expressions, return a new 'String' expression that substitutes the expressions for the placeholders. +-- This does not understand strings or other SQL syntax, so any literal occurrence of a string like @$N@ must be escaped as @$$N@. +sqlSubstitute :: String -> [TH.Exp] -> TH.Exp +sqlSubstitute sql exprl = se 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); literal occurrences may need to be escaped with '$$'" + + se = uncurry ((+$+) . stringL) . ss + ss ('$':'$':d:r) | isDigit d = first (('$':) . (d:)) $ ss r + ss ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = ("", expr n +$+ se r) + ss (c:r) = first (c:) $ ss r + ss "" = ("", stringL "") + +stringL :: String -> TH.Exp +stringL = TH.LitE . TH.StringL + +(+$+) :: TH.Exp -> TH.Exp -> TH.Exp +infixr 5 +$+ +TH.LitE (TH.StringL "") +$+ e = e +e +$+ TH.LitE (TH.StringL "") = e +TH.LitE (TH.StringL l) +$+ TH.LitE (TH.StringL r) = stringL (l ++ r) +l +$+ r = TH.InfixE (Just l) (TH.VarE '(++)) (Just r) + +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 'makeQuery'. +data QueryFlags = QueryFlags + { flagNullable :: Bool -- ^ Assume all results are nullable and don't try to guess. + , 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. +simpleFlags :: QueryFlags +simpleFlags = QueryFlags False Nothing + +-- |Construct a 'PGQuery' from a SQL string. +makePGQuery :: QueryFlags -> String -> TH.ExpQ +makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do + (pt, rt) <- tpgDescribe sqlp (fromMaybe [] prep) (not nulls) + when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" + + e <- TH.newName "tenv" + (vars, vals) <- mapAndUnzipM (\t -> do + v <- TH.newName $ 'p':tpgValueName t + return (TH.VarP v, tpgTypeEncoder (isNothing prep) t e v)) pt + (pats, conv, bc) <- unzip3 <$> mapM (\t -> do + v <- TH.newName $ 'c':tpgValueName t + return (TH.VarP v, tpgTypeDecoder t e v, tpgValueBinary t)) rt + let pgq + | isNothing prep = TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals + | otherwise = TH.ConE 'PreparedQuery `TH.AppE` stringL sqlp `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE (map boolL bc) + foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser + `TH.AppE` TH.LamE [TH.VarP e] pgq + `TH.AppE` TH.LamE [TH.VarP e, TH.ListP pats] (TH.TupE conv)) + <$> mapM parse exprs + where + (sqlp, exprs) = sqlPlaceholders sqle + parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e + boolL False = TH.ConE 'False + boolL True = TH.ConE 'True + +qqQuery :: QueryFlags -> String -> TH.ExpQ +qqQuery f@QueryFlags{ flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q +qqQuery f@QueryFlags{ flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q +qqQuery f@QueryFlags{ flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = Just args } =<< sql r where + args = map trim $ splitCommas arg + (arg, r) = break (')' ==) s + sql (')':q) = return q + sql _ = fail "pgSQL: unterminated argument list" +qqQuery f q = makePGQuery f q + +qqTop :: Bool -> String -> TH.DecsQ +qqTop True ('!':sql) = qqTop False sql +qqTop err sql = do + r <- TH.runIO $ try $ withTPGConnection $ \c -> + pgSimpleQuery c 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'. +-- Note that all occurrences of @$N@ or @${@ will be treated as placeholders, regardless of their context in the SQL (e.g., even within SQL strings or other places placeholders are disallowed by PostgreSQL), which may cause invalid SQL or other errors. +-- If you need to pass a literal @$@ through in these contexts, you may double it to escape it as @$$N@ or @$${@. +-- +-- 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. +-- [@$@] To create a 'PGPreparedQuery' rather than a 'PGSimpleQuery', by default inferring parameter types. +-- [@$(type,...)@] To specify specific types to a prepared query (see for details). +-- +-- This 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. +pgSQL :: QuasiQuoter +pgSQL = QuasiQuoter + { quoteExp = qqQuery simpleFlags + , quoteType = const $ fail "pgSQL not supported in types" + , quotePat = const $ fail "pgSQL not supported in patterns" + , quoteDec = qqTop True + } diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/Range.hs @@ -0,0 +1,141 @@ +-- | +-- 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 + +import Control.Applicative ((<$)) +import Control.Monad (guard) +import Data.Monoid ((<>)) + +data Bound a + = Unbounded + | Bounded Bool a + deriving (Eq) + +instance Functor Bound where + fmap _ Unbounded = Unbounded + fmap f (Bounded c a) = Bounded c (f a) + +newtype LowerBound a = Lower (Bound a) deriving (Eq) + +instance Functor LowerBound where + fmap f (Lower b) = Lower (fmap f b) + +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 + +newtype UpperBound a = Upper (Bound a) deriving (Eq) + +instance Functor UpperBound where + fmap f (Upper b) = Upper (fmap f b) + +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 + +data Range a + = Empty + | Range (LowerBound a) (UpperBound a) + deriving (Eq) + +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 + +boundClosed :: Bound a -> Bool +boundClosed Unbounded = False +boundClosed (Bounded c _) = c + +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" + +lowerClosed :: Range a -> Bool +lowerClosed Empty = False +lowerClosed (Range (Lower b) _) = boundClosed b + +upperClosed :: Range a -> Bool +upperClosed Empty = False +upperClosed (Range _ (Upper b)) = boundClosed b + +isEmpty :: Ord a => Range a -> Bool +isEmpty Empty = True +isEmpty (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = l > u +isEmpty (Range (Lower (Bounded _ l)) (Upper (Bounded _ u))) = l >= u +isEmpty _ = False + +full :: Range a +full = Range (Lower Unbounded) (Upper Unbounded) + +isFull :: Range a -> Bool +isFull (Range (Lower Unbounded) (Upper Unbounded)) = True +isFull _ = False + +point :: Eq a => a -> Range a +point a = Range (Lower (Bounded True a)) (Upper (Bounded True a)) + +getPoint :: Eq a => Range a -> Maybe a +getPoint (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = u <$ guard (u == l) +getPoint _ = Nothing + +range :: Ord a => Bound a -> Bound a -> Range a +range l u = normalize $ Range (Lower l) (Upper u) + +normal :: Ord a => Maybe a -> Maybe a -> Range a +normal l u = range (mb True l) (mb False u) where + mb = maybe Unbounded . Bounded + +bounded :: Ord a => a -> a -> Range a +bounded l u = range (Bounded True l) (Bounded False u) + +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)) = 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) + _ -> l + +(@>), (<@) :: 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 + +(@>.) :: Ord a => Range a -> a -> Bool +r @>. a = r @> point a + +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 diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/TH.hs @@ -0,0 +1,192 @@ +{-# 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 + , withTPGConnection + , useTPGDatabase + , reloadTPGTypes + , TPGValueInfo(..) + , tpgDescribe + , tpgTypeEncoder + , tpgTypeDecoder + ) where + +import Control.Applicative ((<$>), (<$), (<|>)) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, modifyMVar_) +import Control.Exception (onException, finally) +import Control.Monad (liftM2) +import qualified Data.Foldable as Fold +import qualified Data.IntMap.Lazy as IntMap +import Data.List (find) +import Data.Maybe (isJust, fromMaybe) +import qualified Data.Traversable as Tv +import qualified Language.Haskell.TH as TH +import Network (PortID(UnixSocket, PortNumber), PortNumber) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol + +-- |A particular PostgreSQL type, identified by full formatted name (from @format_type@ or @\\dT@). +type TPGType = String + +-- |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 <- maybe (5432 :: PortNumber) ((fromIntegral :: Int -> PortNumber) . read) <$> lookupEnv "TPG_PORT" + port <- maybe (PortNumber pnum) UnixSocket <$> lookupEnv "TPG_SOCK" + pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" + debug <- isJust <$> lookupEnv "TPG_DEBUG" + return $ defaultPGDatabase + { pgDBHost = host + , pgDBPort = port + , pgDBName = db + , pgDBUser = user + , pgDBPass = pass + , pgDBDebug = debug + } + +tpgState :: MVar (PGDatabase, Maybe TPGState) +tpgState = unsafePerformIO $ + newMVar (unsafePerformIO getTPGDatabase, Nothing) + +data TPGState = TPGState + { tpgConnection :: PGConnection + , tpgTypes :: IntMap.IntMap TPGType -- keyed on fromIntegral OID + } + +tpgLoadTypes :: TPGState -> IO TPGState +tpgLoadTypes tpg = do + -- defer loading types until they're needed + tl <- unsafeInterleaveIO $ pgSimpleQuery (tpgConnection tpg) "SELECT typ.oid, format_type(CASE WHEN typtype = 'd' THEN typbasetype ELSE typ.oid END, -1) FROM pg_catalog.pg_type typ JOIN pg_catalog.pg_namespace nsp ON typnamespace = nsp.oid WHERE nspname <> 'pg_toast' AND nspname <> 'information_schema' ORDER BY typ.oid" + return $ tpg{ tpgTypes = IntMap.fromAscList $ map (\[PGTextValue to, PGTextValue tn] -> + (fromIntegral (pgDecode (PGTypeProxy :: PGTypeName "oid") to :: OID), pgDecode (PGTypeProxy :: PGTypeName "text") tn)) $ Fold.toList $ snd tl + } + +tpgInit :: PGConnection -> IO TPGState +tpgInit c = tpgLoadTypes TPGState{ tpgConnection = c, tpgTypes = undefined } + +-- |Run an action using the Template Haskell state. +withTPGState :: (TPGState -> IO a) -> IO a +withTPGState f = do + (db, tpg') <- takeMVar tpgState + tpg <- maybe (tpgInit =<< 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 = withTPGState (f . tpgConnection) + +-- |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 (tpgConnection t) db + return t{ tpgConnection = c }) tpg' + else Nothing <$ Fold.mapM_ (pgDisconnect . tpgConnection) 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 $ [] <$ modifyMVar_ tpgState (\(d, c) -> (,) d <$> Tv.mapM tpgLoadTypes c) + +-- |Lookup a type name by OID. +-- Error if not found. +tpgType :: TPGState -> OID -> TPGType +tpgType TPGState{ tpgTypes = types } t = + IntMap.findWithDefault (error $ "Unknown PostgreSQL type: " ++ show t) (fromIntegral t) types + +-- |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 :: Monad m => TPGState -> String -> m OID +getTPGTypeOID TPGState{ tpgTypes = types } t = + maybe (fail $ "Unknown PostgreSQL type: " ++ t ++ "; be sure to use the exact type name from \\dTS") (return . fromIntegral . fst) + $ find ((==) t . snd) $ IntMap.toList types + +-- |Determine if a type supports binary format marshalling. +-- Checks for a 'PGBinaryType' instance. Should be efficient. +tpgTypeIsBinary :: TPGType -> TH.Q Bool +tpgTypeIsBinary t = + TH.isInstance ''PGBinaryType [TH.LitT (TH.StrTyLit t)] + +data TPGValueInfo = TPGValueInfo + { tpgValueName :: String + , tpgValueTypeOID :: !OID + , tpgValueType :: TPGType + , tpgValueBinary :: Bool + , tpgValueNullable :: Bool + } + +-- |A type-aware wrapper to 'pgDescribe' +tpgDescribe :: String -> [String] -> Bool -> TH.Q ([TPGValueInfo], [TPGValueInfo]) +tpgDescribe sql types nulls = do + (pv, rv) <- TH.runIO $ withTPGState $ \tpg -> do + at <- mapM (getTPGTypeOID tpg) types + (pt, rt) <- pgDescribe (tpgConnection tpg) sql at nulls + return + ( map (\o -> TPGValueInfo + { tpgValueName = "" + , tpgValueTypeOID = o + , tpgValueType = tpgType tpg o + , tpgValueBinary = False + , tpgValueNullable = True + }) pt + , map (\(c, o, n) -> TPGValueInfo + { tpgValueName = c + , tpgValueTypeOID = o + , tpgValueType = tpgType tpg o + , tpgValueBinary = False + , tpgValueNullable = n + }) rt + ) +#ifdef USE_BINARY + -- now that we're back in Q (and have given up the TPGState) we go back to fill in binary: + liftM2 (,) (fillBin pv) (fillBin rv) + where + fillBin = mapM (\i -> do + b <- tpgTypeIsBinary (tpgValueType i) + return i{ tpgValueBinary = b }) +#else + return (pv, rv) +#endif + + +typeApply :: TPGType -> TH.Name -> TH.Name -> TH.Name -> TH.Exp +typeApply t f e v = + TH.VarE f `TH.AppE` TH.VarE e + `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit t))) + `TH.AppE` TH.VarE v + + +-- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. +tpgTypeEncoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Name -> TH.Exp +tpgTypeEncoder lit v = typeApply (tpgValueType v) $ if lit + then 'pgEscapeParameter + else if tpgValueBinary v then 'pgEncodeBinaryParameter else 'pgEncodeParameter + +-- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. +tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Name -> TH.Exp +tpgTypeDecoder v = typeApply (tpgValueType v) $ if tpgValueBinary v + then if tpgValueNullable v then 'pgDecodeBinaryColumn else 'pgDecodeBinaryColumnNotNull + else if tpgValueNullable v then 'pgDecodeColumn else 'pgDecodeColumnNotNull diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE TemplateHaskell #-} +-- 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 + , PG.pgDisconnect + ) where + +import Control.Exception (onException, catchJust) +import Control.Monad (liftM, void, guard) +import Data.Maybe (listToMaybe, isJust) +import qualified Language.Haskell.TH as TH +import Network (HostName, PortID(..)) +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 simpleFlags $ 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'): +-- +-- @let rolename = \"BOfH\" +-- +-- $(execute \"CREATE ROLE {rolename}\") h +-- @ +execute :: String -> TH.ExpQ +execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleFlags $ 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 h a = + onException (do void $ PG.pgSimpleQuery h "BEGIN" + c <- a + void $ PG.pgSimpleQuery h "COMMIT" + return c) + (void $ PG.pgSimpleQuery h "ROLLBACK") + +-- |Roll back a transaction. +rollback :: PG.PGConnection -> IO () +rollback h = void $ PG.pgSimpleQuery h "ROLLBACK" + +-- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. +insertIgnore :: IO () -> IO () +insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where + uniquenessError (PG.PGError m) = guard (PG.pgMessageCode m == "24505") + +type PGException = PG.PGError + +pgConnect :: HostName -- ^ the host to connect to + -> PortID -- ^ the port to connect on + -> String -- ^ the database to connect to + -> String -- ^ the username to connect as + -> String -- ^ the password to connect with + -> IO 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.pgDBHost = h + , PG.pgDBPort = n + , PG.pgDBName = d + , PG.pgDBUser = u + , PG.pgDBPass = p + , PG.pgDBDebug = debug + } diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Typed/Types.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} +-- | +-- 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 + , pgQuote + , PGTypeName(..) + , PGTypeEnv(..) + + -- * Marshalling classes + , PGParameter(..) + , PGBinaryParameter + , PGColumn(..) + , PGBinaryType + + -- * Marshalling utilities + , pgEncodeParameter + , pgEncodeBinaryParameter + , pgEscapeParameter + , pgDecodeColumn + , pgDecodeColumnNotNull + , pgDecodeBinaryColumn + , pgDecodeBinaryColumnNotNull + + -- * Specific type support + , PGArrayType + , PGRangeType + ) where + +import Control.Applicative ((<$>), (<$)) +import Control.Monad (mzero) +import Data.Bits (shiftL, (.|.)) +import Data.ByteString.Internal (w2c) +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) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.UTF8 as BSU +import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower) +import Data.Int +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>), mconcat, mempty) +import Data.Ratio ((%), numerator, denominator) +#ifdef USE_SCIENTIFIC +import Data.Scientific (Scientific) +#endif +#ifdef USE_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 +#ifdef USE_UUID +import qualified Data.UUID as UUID +#endif +import Data.Word (Word8, Word32) +import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) +import Numeric (readFloat) +#ifdef USE_BINARY +-- import qualified PostgreSQLBinary.Array as BinA +import qualified PostgreSQLBinary.Decoder as BinD +import qualified PostgreSQLBinary.Encoder as BinE +#endif +import System.Locale (defaultTimeLocale) +import qualified Text.Parsec as P +import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) + +import qualified Database.PostgreSQL.Typed.Range as Range + +type PGTextValue = BS.ByteString +type PGBinaryValue = BS.ByteString +-- |A value passed to or from PostgreSQL in raw format. +data PGValue + = PGNullValue + | PGTextValue PGTextValue -- ^ The standard text encoding format (also used for unknown formats) + | 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] + +-- |A proxy type for PostgreSQL types. The type argument should be an (internal) name of a database type (see @\\dT+@). +data PGTypeName (t :: Symbol) = PGTypeProxy + +class KnownSymbol t => PGBinaryType t + +pgTypeName :: KnownSymbol t => PGTypeName (t :: Symbol) -> String +pgTypeName = symbolVal + +-- |Parameters that affect how marshalling happens. +-- Currenly we force all other relevant parameters at connect time. +data PGTypeEnv = PGTypeEnv + { pgIntegerDatetimes :: Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. + } + +-- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@. +class KnownSymbol t => PGParameter (t :: Symbol) a where + -- |Encode a value to a PostgreSQL text representation. + pgEncode :: PGTypeName t -> a -> PGTextValue + -- |Encode a value to a (quoted) literal value for use in SQL statements. + -- Defaults to a quoted version of 'pgEncode' + pgLiteral :: PGTypeName t -> a -> String + pgLiteral t = pgQuote . BSU.toString . pgEncode t +class (PGParameter t a, PGBinaryType t) => PGBinaryParameter t a where + pgEncodeBinary :: PGTypeEnv -> PGTypeName t -> a -> PGBinaryValue + +-- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@. +class KnownSymbol t => PGColumn (t :: Symbol) a where + -- |Decode the PostgreSQL text representation into a value. + pgDecode :: PGTypeName t -> PGTextValue -> a +class (PGColumn t a, PGBinaryType t) => PGBinaryColumn t a where + pgDecodeBinary :: PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a + +-- |Support encoding of 'Maybe' values into NULL. +class PGParameterNull t a where + pgEncodeNull :: PGTypeName t -> a -> PGValue + pgLiteralNull :: PGTypeName t -> a -> String +class PGParameterNull t a => PGBinaryParameterNull t a where + pgEncodeBinaryNull :: PGTypeEnv -> PGTypeName t -> a -> PGValue + +-- |Support decoding of assumed non-null columns but also still allow decoding into 'Maybe'. +class PGColumnNotNull t a where + pgDecodeNotNull :: PGTypeName t -> PGValue -> a + + +instance PGParameter t a => PGParameterNull t a where + pgEncodeNull t = PGTextValue . pgEncode t + pgLiteralNull = pgLiteral +instance PGParameter t a => PGParameterNull t (Maybe a) where + pgEncodeNull t = maybe PGNullValue (PGTextValue . pgEncode t) + pgLiteralNull = maybe "NULL" . pgLiteral +instance PGBinaryParameter t a => PGBinaryParameterNull t a where + pgEncodeBinaryNull e t = PGBinaryValue . pgEncodeBinary e t +instance PGBinaryParameter t a => PGBinaryParameterNull t (Maybe a) where + pgEncodeBinaryNull e t = maybe PGNullValue (PGBinaryValue . pgEncodeBinary e t) + +instance PGColumn t a => PGColumnNotNull t a where + pgDecodeNotNull t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)" + pgDecodeNotNull t (PGTextValue v) = pgDecode t v + pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t +instance PGColumn t a => PGColumnNotNull t (Maybe a) where + pgDecodeNotNull _ PGNullValue = Nothing + pgDecodeNotNull t (PGTextValue v) = Just $ pgDecode t v + pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t + + +-- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. +pgEncodeParameter :: PGParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> PGValue +pgEncodeParameter _ = pgEncodeNull + +-- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query accepting binary-encoded data. +pgEncodeBinaryParameter :: PGBinaryParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> PGValue +pgEncodeBinaryParameter = pgEncodeBinaryNull + +-- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query. +pgEscapeParameter :: PGParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> String +pgEscapeParameter _ = pgLiteralNull + +-- |Final column decoding function used for a nullable result value. +pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a +pgDecodeColumn _ = pgDecodeNotNull + +-- |Final column decoding function used for a non-nullable result value. +pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGValue -> a +pgDecodeColumnNotNull _ = pgDecodeNotNull + +-- |Final column decoding function used for a nullable binary-encoded result value. +pgDecodeBinaryColumn :: PGBinaryColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a +pgDecodeBinaryColumn e t (PGBinaryValue v) = Just $ pgDecodeBinary e t v +pgDecodeBinaryColumn e t v = pgDecodeColumn e t v + +-- |Final column decoding function used for a non-nullable binary-encoded result value. +pgDecodeBinaryColumnNotNull :: (PGColumnNotNull t a, PGBinaryColumn t a) => PGTypeEnv -> PGTypeName t -> PGValue -> a +pgDecodeBinaryColumnNotNull e t (PGBinaryValue v) = pgDecodeBinary e t v +pgDecodeBinaryColumnNotNull _ t v = pgDecodeNotNull t v + + +pgQuoteUnsafe :: String -> String +pgQuoteUnsafe s = '\'' : s ++ "'" + +-- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes. +pgQuote :: String -> String +pgQuote = ('\'':) . es where + es "" = "'" + es (c@'\'':r) = c:c:es r + es (c:r) = c:es r + +buildBS :: BSB.Builder -> BS.ByteString +buildBS = BSL.toStrict . BSB.toLazyByteString + +-- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument. +-- Checking all these things may not be worth it. We could just double-quote everything. +dQuote :: String -> BS.ByteString -> BSB.Builder +dQuote unsafe s + | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" = + dq <> BSBP.primMapByteStringBounded ec s <> dq + | otherwise = BSB.byteString s 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) + +parseDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String +parseDQuote unsafe = (q P.<|> uq) where + q = P.between (P.char '"') (P.char '"') $ + P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" + uq = P.many1 (P.noneOf ('"':'\\':unsafe)) + + +class (Show a, Read a, KnownSymbol t) => PGLiteralType t a + +instance PGLiteralType t a => PGParameter t a where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGLiteralType t a => PGColumn t a where + pgDecode _ = read . BSC.unpack + +instance PGParameter "boolean" Bool where + pgEncode _ False = BSC.singleton 'f' + pgEncode _ True = BSC.singleton 't' + pgLiteral _ False = "false" + pgLiteral _ True = "true" +instance PGColumn "boolean" Bool where + pgDecode _ s = case BSC.head s of + 'f' -> False + 't' -> True + c -> error $ "pgDecode boolean: " ++ [c] + +type OID = Word32 +instance PGLiteralType "oid" OID +instance PGLiteralType "smallint" Int16 +instance PGLiteralType "integer" Int32 +instance PGLiteralType "bigint" Int64 +instance PGLiteralType "real" Float +instance PGLiteralType "double precision" Double + + +instance PGParameter "\"char\"" Char where + pgEncode _ = BSC.singleton +instance PGColumn "\"char\"" Char where + pgDecode _ = BSC.head + + +class KnownSymbol t => PGStringType t + +instance PGStringType t => PGParameter t String where + pgEncode _ = BSU.fromString +instance PGStringType t => PGColumn t String where + pgDecode _ = BSU.toString + +instance PGStringType t => PGParameter t BS.ByteString where + pgEncode _ = id +instance PGStringType t => PGColumn t BS.ByteString where + pgDecode _ = id + +instance PGStringType t => PGParameter t BSL.ByteString where + pgEncode _ = BSL.toStrict +instance PGStringType t => PGColumn t BSL.ByteString where + pgDecode _ = BSL.fromStrict + +#ifdef USE_TEXT +instance PGStringType t => PGParameter t T.Text where + pgEncode _ = TE.encodeUtf8 +instance PGStringType t => PGColumn t T.Text where + pgDecode _ = TE.decodeUtf8 + +instance PGStringType t => PGParameter t TL.Text where + pgEncode _ = BSL.toStrict . TLE.encodeUtf8 +instance PGStringType t => PGColumn t TL.Text where + pgDecode _ = TL.fromStrict . TE.decodeUtf8 +#endif + +instance PGStringType "text" +instance PGStringType "character varying" +instance PGStringType "name" -- limit 63 characters +instance PGStringType "bpchar" -- blank padded + + +encodeBytea :: BSB.Builder -> PGTextValue +encodeBytea h = buildBS $ 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 PGParameter "bytea" BSL.ByteString where + pgEncode _ = encodeBytea . BSB.lazyByteStringHex + pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t +instance PGColumn "bytea" BSL.ByteString where + pgDecode _ = BSL.pack . decodeBytea +instance PGParameter "bytea" BS.ByteString where + pgEncode _ = encodeBytea . BSB.byteStringHex + pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t +instance PGColumn "bytea" BS.ByteString where + pgDecode _ = BS.pack . decodeBytea + +instance PGParameter "date" Time.Day where + pgEncode _ = BSC.pack . Time.showGregorian + pgLiteral _ = pgQuoteUnsafe . Time.showGregorian +instance PGColumn "date" Time.Day where + pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack + +instance PGParameter "time without time zone" Time.TimeOfDay where + pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" + pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q" +instance PGColumn "time without time zone" Time.TimeOfDay where + pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack + +instance PGParameter "timestamp without time zone" Time.LocalTime where + pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" + pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%F %T%Q" +instance PGColumn "timestamp without time zone" Time.LocalTime where + pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack + +-- 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 PGParameter "timestamp with time zone" Time.UTCTime where + pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" + pgLiteral _ = pgQuote{-Unsafe-} . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" +instance PGColumn "timestamp with time zone" Time.UTCTime where + pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack + +instance PGParameter "interval" Time.DiffTime where + pgEncode _ = BSC.pack . show + pgLiteral _ = pgQuoteUnsafe . show +-- |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 _ = either (error . ("pgDecode interval: " ++) . show) id . P.parse ps "interval" where + ps = do + _ <- P.char 'P' + d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)] + (d +) <$> pt P.<|> d <$ P.eof + pt = do + _ <- P.char 'T' + t <- units [('H', 3600), ('M', 60), ('S', 1)] + _ <- P.eof + return t + units l = fmap sum $ P.many $ do + s <- negate <$ P.char '-' P.<|> id <$ P.char '+' P.<|> return id + x <- num + u <- P.choice $ map (\(c, u) -> s u <$ P.char c) l + return $ either (Time.secondsToDiffTime . (* u)) (realToFrac . (* fromInteger u)) x + day = 86400 + month = 2629746 + num = naturalOrFloat $ makeTokenParser $ LanguageDef + { commentStart = "" + , commentEnd = "" + , commentLine = "" + , nestedComments = False + , identStart = mzero + , identLetter = mzero + , opStart = mzero + , opLetter = mzero + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + } + +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 = "'NaN'" -- this can't happen + | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" +-- |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 + +-- 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 USE_SCIENTIFIC +instance PGLiteralType "numeric" Scientific +#endif + +-- |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 (KnownSymbol ta, KnownSymbol t) => PGArrayType ta t | ta -> t, t -> ta where + pgArrayElementType :: PGTypeName ta -> PGTypeName t + pgArrayElementType PGTypeProxy = PGTypeProxy + -- |The character used as a delimeter. The default @,@ is correct for all standard types (except @box@). + pgArrayDelim :: PGTypeName ta -> Char + pgArrayDelim _ = ',' + +instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where + pgEncode ta l = buildBS $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where + el Nothing = BSB.string7 "null" + el (Just e) = dQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e +instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where + pgDecode ta = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where + pa = do + l <- P.between (P.char '{') (P.char '}') $ + P.sepBy nel (P.char (pgArrayDelim ta)) + _ <- P.eof + return l + nel = P.between P.spaces P.spaces $ Nothing <$ nul P.<|> Just <$> el + nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll" + el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parseDQuote (pgArrayDelim ta : "{}") + +-- Just a dump of pg_type: +instance PGArrayType "boolean[]" "boolean" +instance PGArrayType "bytea[]" "bytea" +instance PGArrayType "\"char\"[]" "\"char\"" +instance PGArrayType "name[]" "name" +instance PGArrayType "bigint[]" "bigint" +instance PGArrayType "smallint[]" "smallint" +instance PGArrayType "int2vector[]" "int2vector" +instance PGArrayType "integer[]" "integer" +instance PGArrayType "regproc[]" "regproc" +instance PGArrayType "text[]" "text" +instance PGArrayType "oid[]" "oid" +instance PGArrayType "tid[]" "tid" +instance PGArrayType "xid[]" "xid" +instance PGArrayType "cid[]" "cid" +instance PGArrayType "oidvector[]" "oidvector" +instance PGArrayType "json[]" "json" +instance PGArrayType "xml[]" "xml" +instance PGArrayType "point[]" "point" +instance PGArrayType "lseg[]" "lseg" +instance PGArrayType "path[]" "path" +instance PGArrayType "box[]" "box" where + pgArrayDelim _ = ';' +instance PGArrayType "polygon[]" "polygon" +instance PGArrayType "line[]" "line" +instance PGArrayType "cidr[]" "cidr" +instance PGArrayType "real[]" "real" +instance PGArrayType "double precision[]" "double precision" +instance PGArrayType "abstime[]" "abstime" +instance PGArrayType "reltime[]" "reltime" +instance PGArrayType "tinterval[]" "tinterval" +instance PGArrayType "circle[]" "circle" +instance PGArrayType "money[]" "money" +instance PGArrayType "macaddr[]" "macaddr" +instance PGArrayType "inet[]" "inet" +instance PGArrayType "aclitem[]" "aclitem" +instance PGArrayType "bpchar[]" "bpchar" +instance PGArrayType "character varying[]" "character varying" +instance PGArrayType "date[]" "date" +instance PGArrayType "time without time zone[]" "time without time zone" +instance PGArrayType "timestamp without time zone[]" "timestamp without time zone" +instance PGArrayType "timestamp with time zone[]" "timestamp with time zone" +instance PGArrayType "interval[]" "interval" +instance PGArrayType "time with time zone[]" "time with time zone" +instance PGArrayType "bit[]" "bit" +instance PGArrayType "varbit[]" "varbit" +instance PGArrayType "numeric[]" "numeric" +instance PGArrayType "refcursor[]" "refcursor" +instance PGArrayType "regprocedure[]" "regprocedure" +instance PGArrayType "regoper[]" "regoper" +instance PGArrayType "regoperator[]" "regoperator" +instance PGArrayType "regclass[]" "regclass" +instance PGArrayType "regtype[]" "regtype" +instance PGArrayType "record[]" "record" +instance PGArrayType "cstring[]" "cstring" +instance PGArrayType "uuid[]" "uuid" +instance PGArrayType "txid_snapshot[]" "txid_snapshot" +instance PGArrayType "tsvector[]" "tsvector" +instance PGArrayType "tsquery[]" "tsquery" +instance PGArrayType "gtsvector[]" "gtsvector" +instance PGArrayType "regconfig[]" "regconfig" +instance PGArrayType "regdictionary[]" "regdictionary" +instance PGArrayType "int4range[]" "int4range" +instance PGArrayType "numrange[]" "numrange" +instance PGArrayType "tsrange[]" "tsrange" +instance PGArrayType "tstzrange[]" "tstzrange" +instance PGArrayType "daterange[]" "daterange" +instance PGArrayType "int8range[]" "int8range" + + +-- |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 (KnownSymbol tr, KnownSymbol t) => PGRangeType tr t | tr -> t where + pgRangeElementType :: PGTypeName tr -> PGTypeName t + pgRangeElementType PGTypeProxy = PGTypeProxy + +instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range.Range a) where + pgEncode _ Range.Empty = BSC.pack "empty" + pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = buildBS $ + pc '[' '(' l + <> pb (Range.bound l) + <> BSB.char7 ',' + <> pb (Range.bound u) + <> pc ']' ')' u + where + pb Nothing = mempty + pb (Just b) = dQuote "(),[]" $ pgEncode (pgRangeElementType tr) b + pc c o b = BSB.char7 $ if Range.boundClosed b then c else o +instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range.Range a) where + pgDecode tr = either (error . ("pgDecode range: " ++) . show) id . P.parse per "range" where + per = Range.Empty <$ pe P.<|> pr + pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy" + pp = pgDecode (pgRangeElementType tr) . BSC.pack <$> parseDQuote "(),[]" + pc c o = True <$ P.char c P.<|> False <$ P.char o + pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp + mb = maybe Range.Unbounded . Range.Bounded + pr = do + lc <- pc '[' '(' + lb <- pb + _ <- P.char ',' + ub <- pb + uc <- pc ']' ')' + return $ Range.Range (Range.Lower (mb lc lb)) (Range.Upper (mb uc ub)) + +instance PGRangeType "int4range" "integer" +instance PGRangeType "numrange" "numeric" +instance PGRangeType "tsrange" "timestamp without time zone" +instance PGRangeType "tstzrange" "timestamp with time zone" +instance PGRangeType "daterange" "date" +instance PGRangeType "int8range" "bigint" + +#ifdef USE_UUID +instance PGParameter "uuid" UUID.UUID where + pgEncode _ = UUID.toASCIIBytes + pgLiteral _ = pgQuoteUnsafe . UUID.toString +instance PGColumn "uuid" UUID.UUID where + pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u +#endif + +#ifdef USE_BINARY +binDec :: KnownSymbol t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . d + +instance PGBinaryType "oid" +instance PGBinaryParameter "oid" OID where + pgEncodeBinary _ _ = BinE.int4 . Right +instance PGBinaryColumn "oid" OID where + pgDecodeBinary _ = binDec BinD.int + +instance PGBinaryType "smallint" +instance PGBinaryParameter "smallint" Int16 where + pgEncodeBinary _ _ = BinE.int2 . Left +instance PGBinaryColumn "smallint" Int16 where + pgDecodeBinary _ = binDec BinD.int + +instance PGBinaryType "integer" +instance PGBinaryParameter "integer" Int32 where + pgEncodeBinary _ _ = BinE.int4 . Left +instance PGBinaryColumn "integer" Int32 where + pgDecodeBinary _ = binDec BinD.int + +instance PGBinaryType "bigint" +instance PGBinaryParameter "bigint" Int64 where + pgEncodeBinary _ _ = BinE.int8 . Left +instance PGBinaryColumn "bigint" Int64 where + pgDecodeBinary _ = binDec BinD.int + +instance PGBinaryType "real" +instance PGBinaryParameter "real" Float where + pgEncodeBinary _ _ = BinE.float4 +instance PGBinaryColumn "real" Float where + pgDecodeBinary _ = binDec BinD.float4 + +instance PGBinaryType "double precision" +instance PGBinaryParameter "double precision" Double where + pgEncodeBinary _ _ = BinE.float8 +instance PGBinaryColumn "double precision" Double where + pgDecodeBinary _ = binDec BinD.float8 + +instance PGBinaryType "numeric" +instance PGBinaryParameter "numeric" Scientific where + pgEncodeBinary _ _ = BinE.numeric +instance PGBinaryColumn "numeric" Scientific where + pgDecodeBinary _ = binDec BinD.numeric +instance PGBinaryParameter "numeric" Rational where + pgEncodeBinary _ _ = BinE.numeric . realToFrac +instance PGBinaryColumn "numeric" Rational where + pgDecodeBinary _ t = realToFrac . binDec BinD.numeric t + +instance PGBinaryType "\"char\"" +instance PGBinaryParameter "\"char\"" Char where + pgEncodeBinary _ _ = BinE.char +instance PGBinaryColumn "\"char\"" Char where + pgDecodeBinary _ = binDec BinD.char + +instance PGBinaryType "text" +instance PGBinaryType "character varying" +instance PGBinaryType "bpchar" +instance PGBinaryType "name" -- not strictly textsend, but essentially the same +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t T.Text where + pgEncodeBinary _ _ = BinE.text . Left +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t T.Text where + pgDecodeBinary _ = binDec BinD.text +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t TL.Text where + pgEncodeBinary _ _ = BinE.text . Right +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t TL.Text where + pgDecodeBinary _ t = TL.fromStrict . binDec BinD.text t +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t BS.ByteString where + pgEncodeBinary _ _ = BinE.text . Left . TE.decodeUtf8 +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BS.ByteString where + pgDecodeBinary _ t = TE.encodeUtf8 . binDec BinD.text t +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t BSL.ByteString where + pgEncodeBinary _ _ = BinE.text . Right . TLE.decodeUtf8 +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BSL.ByteString where + pgDecodeBinary _ t = BSL.fromStrict . TE.encodeUtf8 . binDec BinD.text t +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t String where + pgEncodeBinary _ _ = BinE.text . Left . T.pack +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t String where + pgDecodeBinary _ t = T.unpack . binDec BinD.text t + +instance PGBinaryType "bytea" +instance PGBinaryParameter "bytea" BS.ByteString where + pgEncodeBinary _ _ = BinE.bytea . Left +instance PGBinaryColumn "bytea" BS.ByteString where + pgDecodeBinary _ = binDec BinD.bytea +instance PGBinaryParameter "bytea" BSL.ByteString where + pgEncodeBinary _ _ = BinE.bytea . Right +instance PGBinaryColumn "bytea" BSL.ByteString where + pgDecodeBinary _ t = BSL.fromStrict . binDec BinD.bytea t + +instance PGBinaryType "date" +instance PGBinaryParameter "date" Time.Day where + pgEncodeBinary _ _ = BinE.date +instance PGBinaryColumn "date" Time.Day where + pgDecodeBinary _ = binDec BinD.date +instance PGBinaryType "time without time zone" +instance PGBinaryParameter "time without time zone" Time.TimeOfDay where + pgEncodeBinary e _ = BinE.time (pgIntegerDatetimes e) +instance PGBinaryColumn "time without time zone" Time.TimeOfDay where + pgDecodeBinary e = binDec $ BinD.time (pgIntegerDatetimes e) +instance PGBinaryType "timestamp without time zone" +instance PGBinaryParameter "timestamp without time zone" Time.LocalTime where + pgEncodeBinary e _ = BinE.timestamp (pgIntegerDatetimes e) +instance PGBinaryColumn "timestamp without time zone" Time.LocalTime where + pgDecodeBinary e = binDec $ BinD.timestamp (pgIntegerDatetimes e) +instance PGBinaryType "timestamp with time zone" +instance PGBinaryParameter "timestamp with time zone" Time.UTCTime where + pgEncodeBinary e _ = BinE.timestamptz (pgIntegerDatetimes e) +instance PGBinaryColumn "timestamp with time zone" Time.UTCTime where + pgDecodeBinary e = binDec $ BinD.timestamptz (pgIntegerDatetimes e) +instance PGBinaryType "interval" +instance PGBinaryParameter "interval" Time.DiffTime where + pgEncodeBinary e _ = BinE.interval (pgIntegerDatetimes e) +instance PGBinaryColumn "interval" Time.DiffTime where + pgDecodeBinary e = binDec $ BinD.interval (pgIntegerDatetimes e) + +instance PGBinaryType "boolean" +instance PGBinaryParameter "boolean" Bool where + pgEncodeBinary _ _ = BinE.bool +instance PGBinaryColumn "boolean" Bool where + pgDecodeBinary _ = binDec BinD.bool + +instance PGBinaryType "uuid" +instance PGBinaryParameter "uuid" UUID.UUID where + pgEncodeBinary _ _ = BinE.uuid +instance PGBinaryColumn "uuid" UUID.UUID where + pgDecodeBinary _ = binDec BinD.uuid + +-- TODO: arrays (a bit complicated, need OID?, but theoretically possible) +#endif + +{- +--, ( 114, 199, "json", ?) +--, ( 142, 143, "xml", ?) +--, ( 600, 1017, "point", ?) +--, ( 650, 651, "cidr", ?) +--, ( 790, 791, "money", Centi? Fixed?) +--, ( 829, 1040, "macaddr", ?) +--, ( 869, 1041, "inet", ?) +--, (1266, 1270, "timetz", ?) +--, (1560, 1561, "bit", Bool?) +--, (1562, 1563, "varbit", ?) +-} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal new file mode 100644 --- /dev/null +++ b/postgresql-typed.cabal @@ -0,0 +1,90 @@ +Name: postgresql-typed +Version: 0.3.0 +Cabal-Version: >= 1.8 +License: BSD3 +License-File: COPYING +Copyright: 2010-2013 Chris Forno, 2014-2015 Dylan Simon +Author: Dylan Simon +Maintainer: dylan@dylex.net +Stability: alpha +Bug-Reports: https://github.com/dylex/postgresql-typed/issues +Homepage: https://github.com/dylex/postgresql-typed +Category: Database +Synopsis: A PostgreSQL access library with compile-time SQL type inference +Description: Automatically type-check SQL statements at compile time. + Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statement 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. + Originally based on Chris Forno's templatepg library. +Tested-With: GHC == 7.8.4 +Build-Type: Simple + +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 + +Library + Build-Depends: + base >= 4.7 && < 5, + array, binary, containers, old-locale, time, + bytestring >= 0.10.2, + template-haskell, + haskell-src-meta, + network, + parsec, + 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.Range + Database.PostgreSQL.Typed.TemplatePG + GHC-Options: -Wall + if flag(md5) + Build-Depends: cryptohash >= 0.5 + CPP-options: -DUSE_MD5 + if flag(binary) + Build-Depends: postgresql-binary >= 0.5.0, text >= 1, uuid >= 1.3, scientific >= 0.3 + CPP-options: -DUSE_BINARY -DUSE_TEXT -DUSE_UUID -DUSE_SCIENTIFIC + else + if flag(text) + Build-Depends: text >= 1 + CPP-options: -DUSE_TEXT + if flag(uuid) + Build-Depends: uuid >= 1.3 + CPP-options: -DUSE_UUID + if flag(scientific) + Build-Depends: scientific >= 0.3 + CPP-options: -DUSE_SCIENTIFIC + +test-suite test + build-depends: base, network, time, postgresql-typed + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: True + hs-source-dirs: test + Extensions: TemplateHaskell, QuasiQuotes + GHC-Options: -Wall diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +-- {-# OPTIONS_GHC -ddump-splices #-} +module Main (main) where + +import Data.Int (Int32) +import qualified Data.Time as Time +import System.Exit (exitSuccess, exitFailure) + +import Database.PostgreSQL.Typed +import Database.PostgreSQL.Typed.Types (OID) +import qualified Database.PostgreSQL.Typed.Range as Range +import Database.PostgreSQL.Typed.Enum + +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')|] + +makePGEnum "myenum" "MyEnum" ("MyEnum_" ++) + +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|] + +main :: IO () +main = do + c <- pgConnect db + z <- Time.getZonedTime + let i = 1 :: Int32 + b = True + f = 3.14 :: Float + t = Time.zonedTimeToLocalTime z + d = Time.localDay t + p = -34881559 :: Time.DiffTime + s = "\"hel\\o'" + l = [Just "a\\\"b,c", Nothing] + r = Range.normal (Just (-2 :: Int32)) Nothing + e = MyEnum_XX_ye + [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e')] <- pgQuery c + [pgSQL|$SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${s}::varchar(10), ${Just d}::date, ${t}::timestamp, ${Time.zonedTimeToUTC z}::timestamptz, ${p}::interval, ${l}::text[], ${r}::int4range, ${e}::myenum|] + assert $ i == i' && b == b' && s == s' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' && e == e' + + ["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 + + pgDisconnect c + exitSuccess