From 1400493f737ba73691a1893edcc230bd325ebc24 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 15:18:33 -0500 Subject: [PATCH 001/306] Add Setup.hs to allow building without cabal-install --- Setup.hs | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 Setup.hs diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain From e261ed02881744378a8fe65607cd38525ec7ea0b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 16:57:51 -0500 Subject: [PATCH 002/306] Add simple test suite --- templatepg.cabal | 12 ++++++++++-- test/Main.hs | 17 +++++++++++++++++ 2 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 test/Main.hs diff --git a/templatepg.cabal b/templatepg.cabal index 9084323..f3f286d 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -1,6 +1,6 @@ Name: templatepg Version: 0.2.6 -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING Copyright: 2010, 2011, 2012, 2013 Chris Forno @@ -28,7 +28,7 @@ source-repository head Library Build-Depends: - base >= 4 && < 6, + base >= 4.6 && < 5, binary, bytestring, haskell-src-meta, @@ -50,3 +50,11 @@ Library ExistentialQuantification, TemplateHaskell GHC-Options: -Wall -fno-warn-type-defaults + +test-suite test + build-depends: base, network, templatepg + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: True + hs-source-dirs: test + Extensions: TemplateHaskell diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..5c6ec39 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Database.TemplatePG +import Database.TemplatePG.SQL (thConnection) +import Network (PortID(UnixSocket)) +import System.Environment (setEnv) +import System.Exit (exitSuccess, exitFailure) + +assert :: Bool -> IO () +assert False = exitFailure +assert True = return () + +main :: IO () +main = do + h <- thConnection -- just to use the same connection parameters, not best practice + Just (Just 1) <- $(queryTuple "SELECT 1") h + exitSuccess From 8f6f08ae3debe9c47f1ad957f856420a41e0f0f7 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 16:58:32 -0500 Subject: [PATCH 003/306] Add support for unix socket connections via TPG_SOCK Also switch catch . getEnv to base-4.6 lookupEnv --- Database/TemplatePG/Protocol.hs | 10 ++++------ Database/TemplatePG/SQL.hs | 20 +++++++++----------- 2 files changed, 13 insertions(+), 17 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index b76d5b3..0ccabab 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -14,6 +14,7 @@ module Database.TemplatePG.Protocol ( PGException(..) import Database.TemplatePG.Types +import Control.Applicative ((<$>)) import Control.Exception import Control.Monad (liftM, replicateM) import Data.Binary @@ -24,12 +25,12 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as B8 import Data.ByteString.Lazy as L hiding (take, repeat, map, any, zipWith) import Data.ByteString.Lazy.UTF8 hiding (length, decode, take) +import Data.Maybe (isJust) import Data.Monoid import Data.Typeable import Network import System.Environment import System.IO hiding (putStr, putStrLn) -import System.IO.Error (isDoesNotExistError) import Prelude hiding (putStr, putStrLn) @@ -90,11 +91,8 @@ protocolVersion = 0x30000 -- |Determine whether or not to print debug output based on the value of the -- TPG_DEBUG environment variable. -debug :: IO (Bool) -debug = catchJust (\e -> if isDoesNotExistError e - then Just () - else Nothing) - (getEnv "TPG_DEBUG" >> return True) (\ _ -> return False) +debug :: IO Bool +debug = isJust <$> lookupEnv "TPG_DEBUG" -- |Connect to a PostgreSQL server. pgConnect :: HostName -- ^ the host to connect to diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 7316e9c..370496b 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -21,6 +21,7 @@ module Database.TemplatePG.SQL ( queryTuples import Database.TemplatePG.Protocol import Database.TemplatePG.Types +import Control.Applicative ((<$>)) import Control.Exception import Control.Monad import Data.ByteString.Lazy.UTF8 hiding (length, decode, take, foldr) @@ -31,7 +32,6 @@ import Language.Haskell.TH.Syntax (returnQ) import Network import System.Environment import System.IO -import System.IO.Error (isDoesNotExistError) import Text.ParserCombinators.Parsec import Prelude hiding (exp) @@ -42,15 +42,13 @@ import Prelude hiding (exp) thConnection :: IO Handle thConnection = do database <- getEnv "TPG_DB" - hostName <- catchUndef (getEnv "TPG_HOST") (\ _ -> return "localhost") - portNum <- catchUndef (getEnv "TPG_PORT") (\ _ -> return "5432") - username <- catchUndef (getEnv "TPG_USER") (\ _ -> return "postgres") - password <- catchUndef (getEnv "TPG_PASS") (\ _ -> return "") - let portNum' = PortNumber $ fromIntegral $ ((read portNum)::Integer) - pgConnect hostName portNum' database username password - where catchUndef = catchJust (\e -> if isDoesNotExistError e - then Just () - else Nothing) + hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" + socket <- lookupEnv "TPG_SOCK" + portNum <- maybe (5432 :: PortNumber) (fromIntegral . read) <$> lookupEnv "TPG_PORT" + username <- fromMaybe "postgres" <$> lookupEnv "TPG_USER" + password <- fromMaybe "" <$> lookupEnv "TPG_PASS" + let portId = maybe (PortNumber $ fromIntegral portNum) UnixSocket socket + pgConnect hostName portId database username password -- |This is where most of the magic happens. -- This doesn't result in a PostgreSQL prepared statement, it just creates one @@ -212,4 +210,4 @@ sqlText = many1 (noneOf "{") -- |Parameters are enclosed in @{}@ and can be any Haskell expression supported -- by haskell-src-meta. sqlParameter :: Parser String -sqlParameter = between (char '{') (char '}') $ many1 (noneOf "}") \ No newline at end of file +sqlParameter = between (char '{') (char '}') $ many1 (noneOf "}") From 844cfe75de2695bcb74bd94c14267a7e8cd9651a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 18:14:27 -0500 Subject: [PATCH 004/306] Make debug more efficient Don't check every time (at the cost of not being able to change online) --- Database/TemplatePG/Protocol.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 0ccabab..34bef48 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -16,7 +16,7 @@ import Database.TemplatePG.Types import Control.Applicative ((<$>)) import Control.Exception -import Control.Monad (liftM, replicateM) +import Control.Monad (liftM, replicateM, when) import Data.Binary import qualified Data.Binary.Builder as B import qualified Data.Binary.Get as G @@ -31,6 +31,7 @@ import Data.Typeable import Network import System.Environment import System.IO hiding (putStr, putStrLn) +import System.IO.Unsafe (unsafeDupablePerformIO) import Prelude hiding (putStr, putStrLn) @@ -91,8 +92,8 @@ protocolVersion = 0x30000 -- |Determine whether or not to print debug output based on the value of the -- TPG_DEBUG environment variable. -debug :: IO Bool -debug = isJust <$> lookupEnv "TPG_DEBUG" +debug :: Bool +debug = unsafeDupablePerformIO $ isJust <$> lookupEnv "TPG_DEBUG" -- |Connect to a PostgreSQL server. pgConnect :: HostName -- ^ the host to connect to @@ -246,23 +247,20 @@ getMessageBody typ = -- |Send a message to PostgreSQL (low-level). pgSend :: Handle -> PGMessage -> IO () pgSend h msg = do - d <- debug - if d then B8.putStrLn (encode msg) else return () + when debug $ B8.putStrLn (encode msg) hPut h (encode msg) >> hFlush h -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. pgReceive :: Handle -> IO PGMessage pgReceive h = do - d <- debug (typ, len) <- G.runGet getMessageHeader `liftM` hGet h 5 body <- hGet h (len - 4) - if d - then do putStr (P.runPut (do P.putWord8 typ + when debug $ do + putStr (P.runPut (do P.putWord8 typ P.putWord32be (fromIntegral len))) B8.putStrLn body hFlush stdout - else return () let msg = decode $ cons typ (append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) case msg of (ErrorResponse _ c m) -> throwIO (PGException c m) From e6ca6cee39da43312f697058e8d76faf5770d873 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 18:19:40 -0500 Subject: [PATCH 005/306] Make pgString far more efficient Still has encoding problems, but that's next --- Database/TemplatePG/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 34bef48..10cfd3b 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -131,7 +131,7 @@ pgDisconnect = hClose -- I haven't yet found a function for doing this without requiring manual -- memory management. pgString :: String -> B.Builder -pgString = B.fromLazyByteString . flip snoc 0 . fromString +pgString s = B.fromLazyByteString (fromString s) <> B.singleton 0 pgMessageID :: PGMessage -> Word8 pgMessageID m = c2w $ case m of From 8fb559ec86b28cdbc4235efa20301975f078faae Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 18:36:31 -0500 Subject: [PATCH 006/306] Add PGConnection abstraction To keep track of connection state. Also fail on unhandled connection (authentication) messages. --- Database/TemplatePG.hs | 2 +- Database/TemplatePG/Protocol.hs | 105 ++++++++++++++++++-------------- Database/TemplatePG/SQL.hs | 12 ++-- templatepg.cabal | 1 + 4 files changed, 66 insertions(+), 54 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 8aeef1b..4c4f034 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -72,7 +72,7 @@ import Database.TemplatePG.SQL -- functions). -- -- It's a Template Haskell function, so you need to splice it into your program --- with @$()@. It requires a 'Handle' to a PostgreSQL server, but can't be +-- 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 ... diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 10cfd3b..3566380 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -4,7 +4,8 @@ -- PostgreSQL server over TCP/IP. You probably don't want to use this module -- directly. -module Database.TemplatePG.Protocol ( PGException(..) +module Database.TemplatePG.Protocol ( PGConnection + , PGException(..) , pgConnect , pgDisconnect , describeStatement @@ -16,30 +17,38 @@ import Database.TemplatePG.Types import Control.Applicative ((<$>)) import Control.Exception -import Control.Monad (liftM, replicateM, when) +import Control.Monad (liftM, liftM2, replicateM, when) import Data.Binary import qualified Data.Binary.Builder as B import qualified Data.Binary.Get as G import qualified Data.Binary.Put as P import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.ByteString.Lazy as L hiding (take, repeat, map, any, zipWith) -import Data.ByteString.Lazy.UTF8 hiding (length, decode, take) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Data.Map.Strict as Map import Data.Maybe (isJust) import Data.Monoid import Data.Typeable import Network -import System.Environment +import System.Environment (lookupEnv) import System.IO hiding (putStr, putStrLn) -import System.IO.Unsafe (unsafeDupablePerformIO) import Prelude hiding (putStr, putStrLn) +data PGConnection = PGConnection + { pgHandle :: Handle + , pgDebug :: !Bool + , pgPid :: !Word32 + , pgKey :: !Word32 + , pgParameters :: Map.Map L.ByteString L.ByteString + } + -- |PGMessage represents a PostgreSQL protocol message that we'll either send -- or receive. See -- . data PGMessage = Authentication - | BackendKeyData + | BackendKeyData Word32 Word32 -- |CommandComplete is bare for now, although it could be made -- to contain the number of rows affected by statements in a -- later version. @@ -48,7 +57,7 @@ data PGMessage = Authentication -- (or just Nothing for null values, to distinguish them from -- emtpy strings). The ByteStrings can then be converted to -- the appropriate type by 'pgStringToType'. - | DataRow [Maybe ByteString] + | DataRow [Maybe L.ByteString] -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). | Describe String @@ -66,7 +75,7 @@ data PGMessage = Authentication -- PostgreSQL does not give us nullability information for the -- parameter. | ParameterDescription [PGType] - | ParameterStatus + | ParameterStatus L.ByteString L.ByteString -- |Parse SQL Destination (prepared statement) | Parse String String | ParseComplete @@ -79,6 +88,7 @@ data PGMessage = Authentication -- etc.) aren't allowed. | SimpleQuery String | UnknownMessage + deriving (Show) -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of -- ERROR, FATAL, or PANIC. It holds the SQLSTATE and message of the error. @@ -90,24 +100,19 @@ instance Exception PGException protocolVersion :: Word32 protocolVersion = 0x30000 --- |Determine whether or not to print debug output based on the value of the --- TPG_DEBUG environment variable. -debug :: Bool -debug = unsafeDupablePerformIO $ isJust <$> lookupEnv "TPG_DEBUG" - -- |Connect to a PostgreSQL server. pgConnect :: HostName -- ^ the host to connect to -> PortID -- ^ the port to connect on -> String -- ^ the database to connect to -> String -- ^ the username to connect as -> String -- ^ the password to connect with - -> IO Handle -- ^ a handle to communicate with the PostgreSQL server on -pgConnect host port db user _ = do + -> IO PGConnection -- ^ a handle to communicate with the PostgreSQL server on +pgConnect host port db user pass = do + debug <- isJust <$> lookupEnv "TPG_DEBUG" h <- connectTo host port - hPut h $ B.toLazyByteString $ pgMessage handshake + L.hPut h $ B.toLazyByteString $ pgMessage handshake hFlush h - _ <- pgWaitFor h [pgMessageID ReadyForQuery] - return h + conn (PGConnection h debug 0 0 Map.empty) -- These are here since the handshake message differs a bit from other -- messages (it's missing the inital identifying character). I could probably -- get rid of it with some refactoring. @@ -119,24 +124,31 @@ pgConnect host port db user _ = do pgMessage :: B.Builder -> B.Builder pgMessage msg = B.append len msg where len = B.putWord32be $ fromIntegral $ (L.length $ B.toLazyByteString msg) + 4 + conn c = do + m <- pgReceive c + case m of + ReadyForQuery -> return c + BackendKeyData p k -> conn c{ pgPid = p, pgKey = k } + ParameterStatus k v -> conn c{ pgParameters = Map.insert k v $ pgParameters c } + _ -> throwIO $ PGException "connect" $ "unhandled message: " ++ show m -- |Disconnect from a PostgreSQL server. Note that this currently doesn't send -- a close message. -pgDisconnect :: Handle -- ^ a handle from 'pgConnect' +pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () -pgDisconnect = hClose +pgDisconnect PGConnection{ pgHandle = h } = hClose h -- |Convert a string to a NULL-terminated UTF-8 string. The PostgreSQL -- protocol transmits most strings in this format. -- I haven't yet found a function for doing this without requiring manual -- memory management. pgString :: String -> B.Builder -pgString s = B.fromLazyByteString (fromString s) <> B.singleton 0 +pgString s = B.fromLazyByteString (U.fromString s) <> B.singleton 0 pgMessageID :: PGMessage -> Word8 pgMessageID m = c2w $ case m of Authentication -> 'R' - BackendKeyData -> 'K' + (BackendKeyData _ _) -> 'K' CommandComplete -> 'C' (DataRow _) -> 'D' (Describe _) -> 'D' @@ -147,7 +159,7 @@ pgMessageID m = c2w $ case m of NoData -> 'n' NoticeResponse -> 'N' (ParameterDescription _) -> 't' - ParameterStatus -> 'S' + (ParameterStatus _ _) -> 'S' (Parse _ _) -> 'P' ParseComplete -> '1' ReadyForQuery -> 'Z' @@ -205,7 +217,7 @@ getMessageBody typ = 'T' -> do numFields <- fromIntegral `liftM` G.getWord16be ds <- replicateM numFields readField return $ RowDescription ds - where readField = do name <- toString `liftM` G.getLazyByteStringNul + where readField = do name <- U.toString `liftM` G.getLazyByteStringNul oid <- fromIntegral `liftM` G.getWord32be -- table OID col <- fromIntegral `liftM` G.getWord16be -- column number typ' <- fromIntegral `liftM` G.getWord32be -- type @@ -216,7 +228,7 @@ getMessageBody typ = 'Z' -> G.getWord8 >> return ReadyForQuery '1' -> return ParseComplete 'C' -> return CommandComplete - 'S' -> return ParameterStatus + 'S' -> liftM2 ParameterStatus G.getLazyByteStringNul G.getLazyByteStringNul 'D' -> do numFields <- fromIntegral `liftM` G.getWord16be ds <- replicateM numFields readField return $ DataRow ds @@ -225,7 +237,7 @@ getMessageBody typ = 0xFFFFFFFF -> return Nothing _ -> Just `liftM` G.getLazyByteString len return s - 'K' -> return BackendKeyData + 'K' -> liftM2 BackendKeyData G.getWord32be G.getWord32be 'E' -> do fs <- readFields case (lookup (c2w 'S') fs, lookup (c2w 'C') fs, @@ -238,43 +250,42 @@ getMessageBody typ = 0 -> return [] _ -> do s <- G.getLazyByteStringNul f' <- readFields - return ((f,toString s):f') + return ((f,U.toString s):f') 'I' -> return EmptyQueryResponse 'n' -> return NoData 'N' -> return NoticeResponse -- Ignore the notice body for now. _ -> return UnknownMessage -- |Send a message to PostgreSQL (low-level). -pgSend :: Handle -> PGMessage -> IO () -pgSend h msg = do - when debug $ B8.putStrLn (encode msg) - hPut h (encode msg) >> hFlush h +pgSend :: PGConnection -> PGMessage -> IO () +pgSend PGConnection{ pgHandle = h, pgDebug = d } msg = do + when d $ B8.putStrLn (encode msg) + L.hPut h (encode msg) >> hFlush h -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. -pgReceive :: Handle -> IO PGMessage -pgReceive h = do - (typ, len) <- G.runGet getMessageHeader `liftM` hGet h 5 - body <- hGet h (len - 4) - when debug $ do - putStr (P.runPut (do P.putWord8 typ - P.putWord32be (fromIntegral len))) +pgReceive :: PGConnection -> IO PGMessage +pgReceive PGConnection{ pgHandle = h, pgDebug = d } = do + (typ, len) <- G.runGet getMessageHeader `liftM` L.hGet h 5 + body <- L.hGet h (len - 4) + when d $ do + L.putStr (P.runPut (P.putWord8 typ >> P.putWord32be (fromIntegral len))) B8.putStrLn body hFlush stdout - let msg = decode $ cons typ (append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) + let msg = decode $ L.cons typ (L.append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) case msg of (ErrorResponse _ c m) -> throwIO (PGException c m) _ -> return msg -- |Wait for a message of a given type. -pgWaitFor :: Handle +pgWaitFor :: PGConnection -> [Word8] -- ^ A list of message identifiers, the first of which -- found while reading messages from PostgreSQL will be -- returned. -> IO PGMessage pgWaitFor h ids = do response <- pgReceive h - if any (pgMessageID response ==) ids + if pgMessageID response `elem` ids then return response else pgWaitFor h ids @@ -282,7 +293,7 @@ pgWaitFor h ids = do -- more parameter descriptions (a PostgreSQL type) and zero or more result -- field descriptions (for queries) (consist of the name of the field, the -- type of the field, and a nullability indicator). -describeStatement :: Handle +describeStatement :: PGConnection -> String -- ^ SQL string -> IO ([PGType], [(String, PGType, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. describeStatement h sql = do @@ -310,7 +321,7 @@ describeStatement h sql = do -- table, we can check there. else do r <- executeSimpleQuery ("SELECT attnotnull FROM pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) h case r of - [[Just s]] -> return $ case toString s of + [[Just s]] -> return $ case U.toString s of "t" -> False "f" -> True _ -> error "Unexpected result from PostgreSQL" @@ -321,8 +332,8 @@ describeStatement h sql = do -- cannot bind parameters. Note that queries can return 0 results (an empty -- list). executeSimpleQuery :: String -- ^ SQL string - -> Handle - -> IO ([[Maybe ByteString]]) -- ^ A list of result rows, + -> PGConnection + -> IO ([[Maybe L.ByteString]]) -- ^ A list of result rows, -- which themselves are a list -- of fields. executeSimpleQuery sql h = do @@ -343,7 +354,7 @@ executeSimpleQuery sql h = do -- |While not strictly necessary, this can make code a little bit clearer. It -- executes a 'SimpleQuery' but doesn't look for results. executeSimpleStatement :: String -- ^ SQL string - -> Handle + -> PGConnection -> IO () executeSimpleStatement sql h = do pgSend h $ SimpleQuery sql diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 370496b..4448305 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -39,7 +39,7 @@ import Prelude hiding (exp) -- |Grab a PostgreSQL connection for compile time. We do so through the -- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and -- @TPG_PASS@. Only TPG_DB is required. -thConnection :: IO Handle +thConnection :: IO PGConnection thConnection = do database <- getEnv "TPG_DB" hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" @@ -85,7 +85,7 @@ weaveString (x:[]) (y:[]) = [| x ++ $(returnQ y) |] weaveString (x:xs) (y:ys) = [| x ++ $(returnQ y) ++ $(weaveString xs ys) |] weaveString _ _ = error "Weave mismatch (possible parse problem)" --- |@queryTuples :: String -> (Handle -> IO [(column1, column2, ...)])@ +-- |@queryTuples :: String -> (PGConnection -> IO [(column1, column2, ...)])@ -- -- Query a PostgreSQL server and return the results as a list of tuples. -- @@ -100,7 +100,7 @@ queryTuples sql = do (sql', types) <- prepareSQL sql [| liftM (map $(convertRow types)) . executeSimpleQuery $(returnQ sql') |] --- |@queryTuple :: String -> (Handle -> IO (Maybe (column1, column2, ...)))@ +-- |@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'. @@ -120,7 +120,7 @@ maybeHead :: [a] -> Maybe a maybeHead [] = Nothing maybeHead (x:_) = Just x --- |@execute :: String -> (Handle -> IO ())@ +-- |@execute :: String -> (PGConnection -> IO ())@ -- -- Convenience function to execute a statement on the PostgreSQL server. -- @@ -141,7 +141,7 @@ execute sql = do -- transaction. Unfortunately you're restricted to using this in the 'IO' -- Monad for now due to the use of 'onException'. I'm debating adding a -- 'MonadPeelIO' version. -withTransaction :: Handle -> IO a -> IO a +withTransaction :: PGConnection -> IO a -> IO a withTransaction h a = onException (do executeSimpleStatement "BEGIN" h c <- a @@ -150,7 +150,7 @@ withTransaction h a = (executeSimpleStatement "ROLLBACK" h) -- |Roll back a transaction. -rollback :: Handle -> IO () +rollback :: PGConnection -> IO () rollback = executeSimpleStatement "ROLLBACK" -- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. diff --git a/templatepg.cabal b/templatepg.cabal index f3f286d..ff22bfa 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -31,6 +31,7 @@ Library base >= 4.6 && < 5, binary, bytestring, + containers, haskell-src-meta, mtl, network, From fae8601559501b006e27b56fb3f40107490e4730 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 18:41:18 -0500 Subject: [PATCH 007/306] Keep track at least of unknown message types --- Database/TemplatePG/Protocol.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 3566380..979e8b8 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -30,7 +30,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (isJust) import Data.Monoid import Data.Typeable -import Network +import Network (HostName, PortID, connectTo) import System.Environment (lookupEnv) import System.IO hiding (putStr, putStrLn) @@ -87,7 +87,7 @@ data PGMessage = Authentication -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, -- etc.) aren't allowed. | SimpleQuery String - | UnknownMessage + | UnknownMessage Word8 deriving (Show) -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of @@ -146,6 +146,7 @@ pgString :: String -> B.Builder pgString s = B.fromLazyByteString (U.fromString s) <> B.singleton 0 pgMessageID :: PGMessage -> Word8 +pgMessageID (UnknownMessage t) = t pgMessageID m = c2w $ case m of Authentication -> 'R' (BackendKeyData _ _) -> 'K' @@ -165,7 +166,7 @@ pgMessageID m = c2w $ case m of ReadyForQuery -> 'Z' (RowDescription _) -> 'T' (SimpleQuery _) -> 'Q' - UnknownMessage -> error "Unknown message type" + (UnknownMessage _) -> error "Unknown message type" -- |All PostgreSQL messages have a common header: an identifying character and -- a 32-bit size field. @@ -254,7 +255,7 @@ getMessageBody typ = 'I' -> return EmptyQueryResponse 'n' -> return NoData 'N' -> return NoticeResponse -- Ignore the notice body for now. - _ -> return UnknownMessage + _ -> return $ UnknownMessage typ -- |Send a message to PostgreSQL (low-level). pgSend :: PGConnection -> PGMessage -> IO () From 064c5fe6700b134c44e23bc6d7ecb095890e9a51 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 20:36:52 -0500 Subject: [PATCH 008/306] Add support for MD5 and cleartext password auth --- Database/TemplatePG/Protocol.hs | 51 +++++++++++++++++++++++++++------ templatepg.cabal | 7 +++++ 2 files changed, 49 insertions(+), 9 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 979e8b8..34be025 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- |The Protocol module allows for direct, low-level communication with a @@ -18,13 +19,16 @@ import Database.TemplatePG.Types import Control.Applicative ((<$>)) import Control.Exception import Control.Monad (liftM, liftM2, replicateM, when) +#ifdef USE_MD5 +import qualified Crypto.Hash as Hash +#endif import Data.Binary import qualified Data.Binary.Builder as B import qualified Data.Binary.Get as G import qualified Data.Binary.Put as P import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy.Char8 as B8 import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import qualified Data.Map.Strict as Map import Data.Maybe (isJust) @@ -47,7 +51,9 @@ data PGConnection = PGConnection -- |PGMessage represents a PostgreSQL protocol message that we'll either send -- or receive. See -- . -data PGMessage = Authentication +data PGMessage = AuthenticationOk + | AuthenticationCleartextPassword + | AuthenticationMD5Password L.ByteString | BackendKeyData Word32 Word32 -- |CommandComplete is bare for now, although it could be made -- to contain the number of rows affected by statements in a @@ -79,6 +85,7 @@ data PGMessage = Authentication -- |Parse SQL Destination (prepared statement) | Parse String String | ParseComplete + | PasswordMessage L.ByteString | ReadyForQuery -- |A RowDescription contains the name, type, table OID, and -- column number of the resulting columns(s) of a query. The @@ -100,6 +107,11 @@ instance Exception PGException protocolVersion :: Word32 protocolVersion = 0x30000 +#ifdef USE_MD5 +md5 :: L.ByteString -> L.ByteString +md5 = L.fromStrict . Hash.digestToHexByteString . (Hash.hashlazy :: L.ByteString -> Hash.Digest Hash.MD5) +#endif + -- |Connect to a PostgreSQL server. pgConnect :: HostName -- ^ the host to connect to -> PortID -- ^ the port to connect on @@ -130,6 +142,17 @@ pgConnect host port db user pass = do ReadyForQuery -> return c BackendKeyData p k -> conn c{ pgPid = p, pgKey = k } ParameterStatus k v -> conn c{ pgParameters = Map.insert k v $ pgParameters c } + AuthenticationOk -> conn c + AuthenticationCleartextPassword -> do + pgSend c $ PasswordMessage $ U.fromString pass + conn c + AuthenticationMD5Password salt -> do +#ifdef USE_MD5 + pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pass ++ user)) `L.append` salt) + conn c +#else + throwIO $ PGException "connect" "MD5 authentication requested but templatepg was built without MD5 support" +#endif _ -> throwIO $ PGException "connect" $ "unhandled message: " ++ show m -- |Disconnect from a PostgreSQL server. Note that this currently doesn't send @@ -148,7 +171,9 @@ pgString s = B.fromLazyByteString (U.fromString s) <> B.singleton 0 pgMessageID :: PGMessage -> Word8 pgMessageID (UnknownMessage t) = t pgMessageID m = c2w $ case m of - Authentication -> 'R' + AuthenticationOk -> 'R' + AuthenticationCleartextPassword -> 'R' + (AuthenticationMD5Password _) -> 'R' (BackendKeyData _ _) -> 'K' CommandComplete -> 'C' (DataRow _) -> 'D' @@ -163,6 +188,7 @@ pgMessageID m = c2w $ case m of (ParameterStatus _ _) -> 'S' (Parse _ _) -> 'P' ParseComplete -> '1' + (PasswordMessage _) -> 'p' ReadyForQuery -> 'Z' (RowDescription _) -> 'T' (SimpleQuery _) -> 'Q' @@ -190,11 +216,12 @@ instance Binary PGMessage where -- |Given a message, build the over-the-wire representation of it. Note that we -- send fewer messages than we receive. putMessageBody :: PGMessage -> B.Builder -putMessageBody (Describe n) = mconcat [B.singleton $ c2w 'S', pgString n] -putMessageBody Execute = mconcat [pgString "", B.putWord32be 0] +putMessageBody (Describe n) = B.singleton (c2w 'S') <> pgString n +putMessageBody Execute = pgString "" <> B.putWord32be 0 putMessageBody Flush = B.empty putMessageBody (Parse s n) = mconcat [pgString n, pgString s, B.putWord16be 0] putMessageBody (SimpleQuery s) = pgString s +putMessageBody (PasswordMessage s) = B.fromLazyByteString s <> B.singleton 0 putMessageBody _ = undefined -- |Get the type and size of an incoming message. @@ -209,7 +236,13 @@ getMessageBody :: Word8 -- ^ the type of the message to parse -> Get PGMessage getMessageBody typ = case w2c typ of - 'R' -> do return Authentication + 'R' -> do + op <- G.getWord32be + case op of + 0 -> return AuthenticationOk + 3 -> return AuthenticationCleartextPassword + 5 -> AuthenticationMD5Password <$> G.getLazyByteString 4 + _ -> fail $ "Unsupported authentication message: " ++ show op 't' -> do numParams <- fromIntegral `liftM` G.getWord16be ps <- replicateM numParams readParam return $ ParameterDescription ps @@ -244,7 +277,7 @@ getMessageBody typ = lookup (c2w 'C') fs, lookup (c2w 'M') fs) of (Just s, Just c, Just m) -> return $ ErrorResponse s c m - _ -> error "Unreadable error response" + _ -> fail "Unreadable error response" where readFields :: Get [(Word8, String)] readFields = do f <- G.getWord8 case f of @@ -260,7 +293,7 @@ getMessageBody typ = -- |Send a message to PostgreSQL (low-level). pgSend :: PGConnection -> PGMessage -> IO () pgSend PGConnection{ pgHandle = h, pgDebug = d } msg = do - when d $ B8.putStrLn (encode msg) + when d $ print msg L.hPut h (encode msg) >> hFlush h -- |Receive the next message from PostgreSQL (low-level). Note that this will @@ -271,7 +304,7 @@ pgReceive PGConnection{ pgHandle = h, pgDebug = d } = do body <- L.hGet h (len - 4) when d $ do L.putStr (P.runPut (P.putWord8 typ >> P.putWord32be (fromIntegral len))) - B8.putStrLn body + LC.putStrLn body hFlush stdout let msg = decode $ L.cons typ (L.append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) case msg of diff --git a/templatepg.cabal b/templatepg.cabal index ff22bfa..d07e176 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -26,6 +26,10 @@ source-repository head type: git location: git://github.com/jekor/templatepg.git +Flag md5 + Description: Enable md5 password authentication method + Default: True + Library Build-Depends: base >= 4.6 && < 5, @@ -51,6 +55,9 @@ Library ExistentialQuantification, TemplateHaskell GHC-Options: -Wall -fno-warn-type-defaults + if flag(md5) + Build-Depends: cryptohash >= 0.5 + CPP-options: -DUSE_MD5 test-suite test build-depends: base, network, templatepg From 53445d46779d6af808e8b70255fbc8fe06ce0788 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 20:39:55 -0500 Subject: [PATCH 009/306] Cleanup unused extensions --- Database/TemplatePG/Protocol.hs | 4 ++-- templatepg.cabal | 4 +--- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 34be025..d0d2d2a 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- |The Protocol module allows for direct, low-level communication with a @@ -33,7 +33,7 @@ import qualified Data.ByteString.Lazy.UTF8 as U import qualified Data.Map.Strict as Map import Data.Maybe (isJust) import Data.Monoid -import Data.Typeable +import Data.Typeable (Typeable) import Network (HostName, PortID, connectTo) import System.Environment (lookupEnv) import System.IO hiding (putStr, putStrLn) diff --git a/templatepg.cabal b/templatepg.cabal index d07e176..8c469f7 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -51,9 +51,7 @@ Library Database.TemplatePG.Protocol Database.TemplatePG.SQL Database.TemplatePG.Types - Extensions: DeriveDataTypeable, - ExistentialQuantification, - TemplateHaskell + Extensions: TemplateHaskell GHC-Options: -Wall -fno-warn-type-defaults if flag(md5) Build-Depends: cryptohash >= 0.5 From 64625fd4a115abc23d0ffa5e59da4132cb69fd2d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 21:18:01 -0500 Subject: [PATCH 010/306] Improve error message handling and reporting Perhaps should not just be printing to stderr, but better than nothing? --- Database/TemplatePG/Protocol.hs | 69 +++++++++++++++++++-------------- Database/TemplatePG/SQL.hs | 4 +- 2 files changed, 41 insertions(+), 32 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index d0d2d2a..96e2814 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -7,6 +7,7 @@ module Database.TemplatePG.Protocol ( PGConnection , PGException(..) + , messageCode , pgConnect , pgDisconnect , describeStatement @@ -17,7 +18,7 @@ module Database.TemplatePG.Protocol ( PGConnection import Database.TemplatePG.Types import Control.Applicative ((<$>)) -import Control.Exception +import Control.Exception (Exception, throwIO) import Control.Monad (liftM, liftM2, replicateM, when) #ifdef USE_MD5 import qualified Crypto.Hash as Hash @@ -30,7 +31,7 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U -import qualified Data.Map.Strict as Map +import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Monoid import Data.Typeable (Typeable) @@ -71,11 +72,11 @@ data PGMessage = AuthenticationOk -- |An ErrorResponse contains the severity, "SQLSTATE", and -- message of an error. See -- . - | ErrorResponse String String String + | ErrorResponse MessageFields | Execute | Flush | NoData - | NoticeResponse + | NoticeResponse 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 @@ -97,10 +98,25 @@ data PGMessage = AuthenticationOk | UnknownMessage Word8 deriving (Show) +type MessageFields = Map.Map Word8 L.ByteString + +errorMessage :: String -> MessageFields +errorMessage = Map.singleton (c2w 'M') . U.fromString + +displayMessage :: MessageFields -> String +displayMessage m = "PG" ++ f 'S' ++ " [" ++ f 'C' ++ "]: " ++ f 'M' ++ '\n' : f 'D' + where f c = maybe "" U.toString $ Map.lookup (c2w c) m + +messageCode :: MessageFields -> String +messageCode = maybe "" LC.unpack . Map.lookup (c2w 'C') + -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of -- ERROR, FATAL, or PANIC. It holds the SQLSTATE and message of the error. -data PGException = PGException String String - deriving (Show, Typeable) +data PGException = PGException MessageFields + deriving (Typeable) + +instance Show PGException where + show (PGException m) = displayMessage m instance Exception PGException @@ -146,14 +162,12 @@ pgConnect host port db user pass = do AuthenticationCleartextPassword -> do pgSend c $ PasswordMessage $ U.fromString pass conn c - AuthenticationMD5Password salt -> do #ifdef USE_MD5 + AuthenticationMD5Password salt -> do pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pass ++ user)) `L.append` salt) conn c -#else - throwIO $ PGException "connect" "MD5 authentication requested but templatepg was built without MD5 support" #endif - _ -> throwIO $ PGException "connect" $ "unhandled message: " ++ show m + _ -> throwIO $ PGException $ errorMessage $ "unexpected: " ++ show m -- |Disconnect from a PostgreSQL server. Note that this currently doesn't send -- a close message. @@ -179,11 +193,11 @@ pgMessageID m = c2w $ case m of (DataRow _) -> 'D' (Describe _) -> 'D' EmptyQueryResponse -> 'I' - (ErrorResponse _ _ _) -> 'E' + (ErrorResponse _) -> 'E' Execute -> 'E' Flush -> 'H' NoData -> 'n' - NoticeResponse -> 'N' + (NoticeResponse _) -> 'N' (ParameterDescription _) -> 't' (ParameterStatus _ _) -> 'S' (Parse _ _) -> 'P' @@ -231,6 +245,12 @@ getMessageHeader = do len <- G.getWord32be return (typ, fromIntegral len) +getMessageFields :: Get MessageFields +getMessageFields = g =<< G.getWord8 where + g :: Word8 -> Get MessageFields + g 0 = return Map.empty + g f = liftM2 (Map.insert f) G.getLazyByteStringNul getMessageFields + -- |Parse an incoming message. getMessageBody :: Word8 -- ^ the type of the message to parse -> Get PGMessage @@ -241,7 +261,7 @@ getMessageBody typ = case op of 0 -> return AuthenticationOk 3 -> return AuthenticationCleartextPassword - 5 -> AuthenticationMD5Password <$> G.getLazyByteString 4 + 5 -> AuthenticationMD5Password `liftM` G.getLazyByteString 4 _ -> fail $ "Unsupported authentication message: " ++ show op 't' -> do numParams <- fromIntegral `liftM` G.getWord16be ps <- replicateM numParams readParam @@ -272,22 +292,10 @@ getMessageBody typ = _ -> Just `liftM` G.getLazyByteString len return s 'K' -> liftM2 BackendKeyData G.getWord32be G.getWord32be - 'E' -> do fs <- readFields - case (lookup (c2w 'S') fs, - lookup (c2w 'C') fs, - lookup (c2w 'M') fs) of - (Just s, Just c, Just m) -> return $ ErrorResponse s c m - _ -> fail "Unreadable error response" - where readFields :: Get [(Word8, String)] - readFields = do f <- G.getWord8 - case f of - 0 -> return [] - _ -> do s <- G.getLazyByteStringNul - f' <- readFields - return ((f,U.toString s):f') + 'E' -> ErrorResponse `liftM` getMessageFields 'I' -> return EmptyQueryResponse 'n' -> return NoData - 'N' -> return NoticeResponse -- Ignore the notice body for now. + 'N' -> NoticeResponse `liftM` getMessageFields _ -> return $ UnknownMessage typ -- |Send a message to PostgreSQL (low-level). @@ -299,7 +307,7 @@ pgSend PGConnection{ pgHandle = h, pgDebug = d } msg = do -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. pgReceive :: PGConnection -> IO PGMessage -pgReceive PGConnection{ pgHandle = h, pgDebug = d } = do +pgReceive c@PGConnection{ pgHandle = h, pgDebug = d } = do (typ, len) <- G.runGet getMessageHeader `liftM` L.hGet h 5 body <- L.hGet h (len - 4) when d $ do @@ -308,8 +316,9 @@ pgReceive PGConnection{ pgHandle = h, pgDebug = d } = do hFlush stdout let msg = decode $ L.cons typ (L.append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) case msg of - (ErrorResponse _ c m) -> throwIO (PGException c m) - _ -> return msg + (ErrorResponse m) -> throwIO (PGException m) + (NoticeResponse m) -> hPutStrLn stderr (displayMessage m) >> pgReceive c + _ -> return msg -- |Wait for a message of a given type. pgWaitFor :: PGConnection diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 4448305..a2d6ad3 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -157,8 +157,8 @@ rollback = executeSimpleStatement "ROLLBACK" insertIgnore :: IO () -> IO () insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where uniquenessError e = case e of - (PGException c _) -> case c of - "23505" -> Just e + PGException m -> case messageCode m of + "23505" -> Just () _ -> Nothing -- |Given a result description, create a function to convert a result to a From 5d2a10e2036e0d7d7ba316033bf8b7bf73e656f3 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 21:21:25 -0500 Subject: [PATCH 011/306] Update documentation for error messages --- Database/TemplatePG/Protocol.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 96e2814..87ef430 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -107,11 +107,13 @@ displayMessage :: MessageFields -> String displayMessage m = "PG" ++ f 'S' ++ " [" ++ f 'C' ++ "]: " ++ f 'M' ++ '\n' : f 'D' where f c = maybe "" U.toString $ Map.lookup (c2w c) m +-- |Message SQLState code. +-- See . messageCode :: MessageFields -> String messageCode = maybe "" LC.unpack . Map.lookup (c2w 'C') -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of --- ERROR, FATAL, or PANIC. It holds the SQLSTATE and message of the error. +-- ERROR, FATAL, or PANIC. It holds the message of the error. data PGException = PGException MessageFields deriving (Typeable) From d539e37401804016e050fd13d22bc00592c22dbd Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 23:32:09 -0500 Subject: [PATCH 012/306] Use persistent PGConnection using MVar --- Database/TemplatePG/SQL.hs | 50 +++++++++++++++++++------------------- test/Main.hs | 7 +++--- 2 files changed, 28 insertions(+), 29 deletions(-) diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index a2d6ad3..f4ea1d1 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -15,32 +15,31 @@ module Database.TemplatePG.SQL ( queryTuples , insertIgnore , withTransaction , rollback - , thConnection + , withTHConnection ) where import Database.TemplatePG.Protocol import Database.TemplatePG.Types import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) +import Control.Exception (onException, catchJust) +import Control.Monad (zipWithM, liftM) import Data.ByteString.Lazy.UTF8 hiding (length, decode, take, foldr) -import Data.Maybe -import Language.Haskell.Meta.Parse +import Data.Maybe (fromMaybe, fromJust) +import Language.Haskell.Meta.Parse (parseExp) import Language.Haskell.TH import Language.Haskell.TH.Syntax (returnQ) -import Network -import System.Environment -import System.IO -import Text.ParserCombinators.Parsec - -import Prelude hiding (exp) +import Network (PortID(UnixSocket, PortNumber), PortNumber) +import System.Environment (getEnv, lookupEnv) +import System.IO.Unsafe (unsafePerformIO) +import qualified Text.ParserCombinators.Parsec as P -- |Grab a PostgreSQL connection for compile time. We do so through the -- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and -- @TPG_PASS@. Only TPG_DB is required. -thConnection :: IO PGConnection -thConnection = do +thConnection :: MVar (IO PGConnection) +thConnection = unsafePerformIO $ newMVar $ do database <- getEnv "TPG_DB" hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" socket <- lookupEnv "TPG_SOCK" @@ -50,6 +49,9 @@ thConnection = do let portId = maybe (PortNumber $ fromIntegral portNum) UnixSocket socket pgConnect hostName portId database username password +withTHConnection :: (PGConnection -> IO a) -> IO a +withTHConnection f = modifyMVar thConnection $ (=<<) $ \c -> (,) (return c) <$> f c + -- |This is where most of the magic happens. -- This doesn't result in a PostgreSQL prepared statement, it just creates one -- to do type inference. @@ -57,17 +59,15 @@ thConnection = do prepareSQL :: String -- ^ a SQL string, with -> Q (Exp, [(String, PGType, Bool)]) -- ^ a prepared SQL string and result descriptions prepareSQL sql = do - -- TODO: It's a bit silly to establish a connection for every query to be - -- analyzed. - h <- runIO thConnection - let (sqlStrings, expStrings) = parseSql sql - (pTypes, fTypes) <- runIO $ describeStatement h $ holdPlaces sqlStrings expStrings + (pTypes, fTypes) <- runIO $ withTHConnection $ \c -> + describeStatement c (holdPlaces sqlStrings expStrings) s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings return (s, fTypes) where holdPlaces ss es = concat $ weave ss (take (length es) placeholders) placeholders = map (('$' :) . show) ([1..]::[Integer]) stringify typ s = [| $(pgTypeToString typ) $(returnQ $ parseExp' s) |] parseExp' e = (either (\ _ -> error ("Failed to parse expression: " ++ e)) id) $ parseExp e + (sqlStrings, expStrings) = parseSql sql -- |"weave" 2 lists of equal length into a single list. weave :: [a] -> [a] -> [a] @@ -194,20 +194,20 @@ pgStringToType' t True = [| liftM (($(pgStringToType t)) . toString) |] -- becomes: @(["SELECT * FROM table WHERE id = ", " AND age > "], -- ["someID", "baseAge * 1.5"])@ parseSql :: String -> ([String], [String]) -parseSql sql = case (parse sqlStatement "" sql) of +parseSql sql = case (P.parse sqlStatement "" sql) of Left err -> error (show err) Right ss -> every2nd ss every2nd :: [a] -> ([a], [a]) every2nd = foldr (\a ~(x,y) -> (a:y,x)) ([],[]) -sqlStatement :: Parser [String] -sqlStatement = many1 $ choice [sqlText, sqlParameter] +sqlStatement :: P.Parser [String] +sqlStatement = P.many1 $ P.choice [sqlText, sqlParameter] -sqlText :: Parser String -sqlText = many1 (noneOf "{") +sqlText :: P.Parser String +sqlText = P.many1 (P.noneOf "{") -- |Parameters are enclosed in @{}@ and can be any Haskell expression supported -- by haskell-src-meta. -sqlParameter :: Parser String -sqlParameter = between (char '{') (char '}') $ many1 (noneOf "}") +sqlParameter :: P.Parser String +sqlParameter = P.between (P.char '{') (P.char '}') $ P.many1 (P.noneOf "}") diff --git a/test/Main.hs b/test/Main.hs index 5c6ec39..8983d8a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,7 @@ module Main (main) where import Database.TemplatePG -import Database.TemplatePG.SQL (thConnection) +import Database.TemplatePG.SQL (withTHConnection) import Network (PortID(UnixSocket)) import System.Environment (setEnv) import System.Exit (exitSuccess, exitFailure) @@ -11,7 +11,6 @@ assert False = exitFailure assert True = return () main :: IO () -main = do - h <- thConnection -- just to use the same connection parameters, not best practice - Just (Just 1) <- $(queryTuple "SELECT 1") h +main = withTHConnection $ \c -> do -- just to use the same connection parameters, not best practice + Just (Just 1) <- $(queryTuple "SELECT 1") c exitSuccess From 9a0635746ae0461f5314df47a7bfcc33b3beae1d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 25 Dec 2014 23:54:31 -0500 Subject: [PATCH 013/306] useTHConnection to specify connection parameters Eliminates the need to set environment variables --- Database/TemplatePG.hs | 1 + Database/TemplatePG/SQL.hs | 19 +++++++++++++------ test/Connect.hs | 6 ++++++ test/Main.hs | 9 ++++++--- 4 files changed, 26 insertions(+), 9 deletions(-) create mode 100644 test/Connect.hs diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 4c4f034..488a372 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -24,6 +24,7 @@ module Database.TemplatePG (-- *Introduction PGException(..) , pgConnect , pgDisconnect + , useTHConnection , queryTuples , queryTuple , execute diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index f4ea1d1..5852627 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -16,15 +16,16 @@ module Database.TemplatePG.SQL ( queryTuples , withTransaction , rollback , withTHConnection + , useTHConnection ) where import Database.TemplatePG.Protocol import Database.TemplatePG.Types -import Control.Applicative ((<$>)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) +import Control.Applicative ((<$>), (<$)) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) import Control.Exception (onException, catchJust) -import Control.Monad (zipWithM, liftM) +import Control.Monad (zipWithM, liftM, (>=>)) import Data.ByteString.Lazy.UTF8 hiding (length, decode, take, foldr) import Data.Maybe (fromMaybe, fromJust) import Language.Haskell.Meta.Parse (parseExp) @@ -38,8 +39,8 @@ import qualified Text.ParserCombinators.Parsec as P -- |Grab a PostgreSQL connection for compile time. We do so through the -- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and -- @TPG_PASS@. Only TPG_DB is required. -thConnection :: MVar (IO PGConnection) -thConnection = unsafePerformIO $ newMVar $ do +thConnection :: MVar (Either (IO PGConnection) PGConnection) +thConnection = unsafePerformIO $ newMVar $ Left $ do database <- getEnv "TPG_DB" hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" socket <- lookupEnv "TPG_SOCK" @@ -50,7 +51,13 @@ thConnection = unsafePerformIO $ newMVar $ do pgConnect hostName portId database username password withTHConnection :: (PGConnection -> IO a) -> IO a -withTHConnection f = modifyMVar thConnection $ (=<<) $ \c -> (,) (return c) <$> f c +withTHConnection f = modifyMVar thConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) + +setTHConnection :: Either (IO PGConnection) PGConnection -> IO () +setTHConnection c = modifyMVar_ thConnection $ either (const $ return c) ((c <$) . pgDisconnect) + +useTHConnection :: IO PGConnection -> Q [Dec] +useTHConnection c = [] <$ runIO (setTHConnection (Left c)) -- |This is where most of the magic happens. -- This doesn't result in a PostgreSQL prepared statement, it just creates one diff --git a/test/Connect.hs b/test/Connect.hs new file mode 100644 index 0000000..314cc83 --- /dev/null +++ b/test/Connect.hs @@ -0,0 +1,6 @@ +module Connect where + +import Database.TemplatePG (pgConnect) +import Network (PortID(UnixSocket)) + +connect = pgConnect "localhost" (UnixSocket "/tmp/.s.PGSQL.5432") "templatepg" "templatepg" "" diff --git a/test/Main.hs b/test/Main.hs index 8983d8a..8194821 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,16 +1,19 @@ module Main (main) where import Database.TemplatePG -import Database.TemplatePG.SQL (withTHConnection) -import Network (PortID(UnixSocket)) import System.Environment (setEnv) import System.Exit (exitSuccess, exitFailure) +import Connect + assert :: Bool -> IO () assert False = exitFailure assert True = return () +useTHConnection connect + main :: IO () -main = withTHConnection $ \c -> do -- just to use the same connection parameters, not best practice +main = do + c <- connect Just (Just 1) <- $(queryTuple "SELECT 1") c exitSuccess From 3e53fc71d113b2a8d821d0644a1c4f92b81fffcf Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 26 Dec 2014 01:28:55 -0500 Subject: [PATCH 014/306] Switch PGType handlers to be extensible In progress: date types and custom handlers are not implemented yet --- Database/TemplatePG/Protocol.hs | 63 +++++++++----- Database/TemplatePG/SQL.hs | 9 +- Database/TemplatePG/Types.hs | 147 +++++++++++++++----------------- 3 files changed, 118 insertions(+), 101 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 87ef430..032ffaa 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -47,8 +47,16 @@ data PGConnection = PGConnection , pgPid :: !Word32 , pgKey :: !Word32 , pgParameters :: Map.Map L.ByteString L.ByteString + , pgTypes :: PGTypeMap } +data ColDescription = ColDescription + { colName :: String + , colTable :: !OID + , colNumber :: !Int + , colType :: !OID + } deriving (Show) + -- |PGMessage represents a PostgreSQL protocol message that we'll either send -- or receive. See -- . @@ -81,7 +89,7 @@ data PGMessage = AuthenticationOk -- query/statement parameter ($1, $2, etc.). Unfortunately, -- PostgreSQL does not give us nullability information for the -- parameter. - | ParameterDescription [PGType] + | ParameterDescription [OID] | ParameterStatus L.ByteString L.ByteString -- |Parse SQL Destination (prepared statement) | Parse String String @@ -91,7 +99,7 @@ data PGMessage = AuthenticationOk -- |A RowDescription contains the name, type, table OID, and -- column number of the resulting columns(s) of a query. The -- column number is useful for inferring nullability. - | RowDescription [(String, PGType, Integer, Int)] + | RowDescription [ColDescription] -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, -- etc.) aren't allowed. | SimpleQuery String @@ -142,7 +150,7 @@ pgConnect host port db user pass = do h <- connectTo host port L.hPut h $ B.toLazyByteString $ pgMessage handshake hFlush h - conn (PGConnection h debug 0 0 Map.empty) + conn (PGConnection h debug 0 0 Map.empty defaultTypeMap) -- These are here since the handshake message differs a bit from other -- messages (it's missing the inital identifying character). I could probably -- get rid of it with some refactoring. @@ -268,19 +276,23 @@ getMessageBody typ = 't' -> do numParams <- fromIntegral `liftM` G.getWord16be ps <- replicateM numParams readParam return $ ParameterDescription ps - where readParam = do typ' <- fromIntegral `liftM` G.getWord32be - return $ pgTypeFromOID typ' + where readParam = G.getWord32be 'T' -> do numFields <- fromIntegral `liftM` G.getWord16be ds <- replicateM numFields readField return $ RowDescription ds - where readField = do name <- U.toString `liftM` G.getLazyByteStringNul - oid <- fromIntegral `liftM` G.getWord32be -- table OID - col <- fromIntegral `liftM` G.getWord16be -- column number - typ' <- fromIntegral `liftM` G.getWord32be -- type + where readField = do name <- G.getLazyByteStringNul + oid <- G.getWord32be -- table OID + col <- G.getWord16be -- column number + typ' <- G.getWord32be -- type _ <- G.getWord16be -- type size _ <- G.getWord32be -- type modifier _ <- G.getWord16be -- format code - return (name, pgTypeFromOID typ', oid, col) + return $ ColDescription + { colName = U.toString name + , colTable = oid + , colNumber = fromIntegral col + , colType = typ' + } 'Z' -> G.getWord8 >> return ReadyForQuery '1' -> return ParseComplete 'C' -> return CommandComplete @@ -334,6 +346,15 @@ pgWaitFor h ids = do then return response else pgWaitFor h ids +getPGType :: PGConnection -> OID -> IO PGType +getPGType c@PGConnection{ pgTypes = types } oid = + maybe notype return $ Map.lookup oid types where + notype = do + r <- executeSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ show oid) c + case r of + [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ U.toString s + _ -> fail $ "Unknown PostgreSQL type: " ++ show oid + -- |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 @@ -346,16 +367,18 @@ describeStatement h sql = do pgSend h $ Describe "" pgSend h $ Flush _ <- pgWaitFor h [pgMessageID ParseComplete] - (ParameterDescription ps) <- pgReceive h - m <- pgWaitFor h $ map c2w ['n', 'T'] - case m of - NoData -> return (ps, []) - (RowDescription r) -> do - r' <- zipWith (\ (name, typ, _, _) n -> (name, typ, n)) r `liftM` mapM nullable r - return (ps, r') - _ -> error "" + ParameterDescription ps <- pgReceive h + m <- pgReceive h + liftM2 (,) (mapM (getPGType h) ps) $ case m of + NoData -> return [] + RowDescription r -> mapM desc r + _ -> fail $ "unexpected describe response: " ++ show m where - nullable (_, _, oid, col) = + desc (ColDescription name tab col typ) = do + t <- getPGType h typ + n <- nullable tab col + return (name, t, n) + nullable oid col = -- We don't get nullability indication from PostgreSQL, at least not -- directly. if oid == 0 @@ -364,7 +387,7 @@ describeStatement h sql = do then return True -- In cases where the resulting field is tracable to the column of a -- table, we can check there. - else do r <- executeSimpleQuery ("SELECT attnotnull FROM pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) h + else do r <- executeSimpleQuery ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) h case r of [[Just s]] -> return $ case U.toString s of "t" -> False diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 5852627..d2619e3 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -26,7 +26,6 @@ import Control.Applicative ((<$>), (<$)) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) import Control.Exception (onException, catchJust) import Control.Monad (zipWithM, liftM, (>=>)) -import Data.ByteString.Lazy.UTF8 hiding (length, decode, take, foldr) import Data.Maybe (fromMaybe, fromJust) import Language.Haskell.Meta.Parse (parseExp) import Language.Haskell.TH @@ -72,7 +71,7 @@ prepareSQL sql = do return (s, fTypes) where holdPlaces ss es = concat $ weave ss (take (length es) placeholders) placeholders = map (('$' :) . show) ([1..]::[Integer]) - stringify typ s = [| $(pgTypeToString typ) $(returnQ $ parseExp' s) |] + stringify PGType{ pgTypeShow = shw } s = [| $(unType <$> shw) $(returnQ $ parseExp' s) |] parseExp' e = (either (\ _ -> error ("Failed to parse expression: " ++ e)) id) $ parseExp e (sqlStrings, expStrings) = parseSql sql @@ -86,9 +85,9 @@ weave (x:xs) (y:ys) = x:y:(weave xs ys) weaveString :: [String] -- ^ SQL fragments -> [Exp] -- ^ Haskell expressions -> Q Exp +weaveString [] [] = [| "" |] weaveString [x] [] = [| x |] weaveString [] [y] = returnQ y -weaveString (x:[]) (y:[]) = [| x ++ $(returnQ y) |] weaveString (x:xs) (y:ys) = [| x ++ $(returnQ y) ++ $(weaveString xs ys) |] weaveString _ _ = error "Weave mismatch (possible parse problem)" @@ -191,8 +190,8 @@ convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) pgStringToType' :: PGType -> Bool -- ^ nullability indicator -> Q Exp -pgStringToType' t False = [| ($(pgStringToType t)) . toString . fromJust |] -pgStringToType' t True = [| liftM (($(pgStringToType t)) . toString) |] +pgStringToType' PGType{ pgTypeDecode = rd } False = [| ($(unType <$> rd)) . fromJust |] +pgStringToType' PGType{ pgTypeDecode = rd } True = [| liftM ($(unType <$> rd)) |] -- SQL Parser -- diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 6a47edb..29e8c4a 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -1,56 +1,80 @@ +{-# LANGUAGE ExistentialQuantification #-} -- Copyright 2010, 2011, 2013 Chris Forno +-- Copyright 2014 Dylan Simon --- |All type conversion to and from the PostgreSQL server is handled here. +module Database.TemplatePG.Types + ( OID + , PGType(..) + , PGTypeMap + , defaultTypeMap + ) where -module Database.TemplatePG.Types ( PGType(..) - , pgTypeFromOID - , pgStringToType - , pgTypeToString - ) where - -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Format +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Lazy.UTF8 as U +import Data.Int +import qualified Data.Map as Map +import Data.Word (Word32) import Language.Haskell.TH -import System.Locale -import Text.Regex --- |TemplatePG currenly only supports a handful of types. It also doesn't --- distinguish between numeric types with different ranges. More types are the --- most likely feature of future TemplatePG releases. -data PGType = PGBoolean -- ^ bool - | PGInteger -- ^ integer - | PGReal -- ^ float - | PGText -- ^ text/varchar - | PGTimestampTZ -- ^ timestamptz (timestamp with time zone) - | PGDate -- ^ date (day without time) - | PGInterval -- ^ interval (a time interval), send-only - deriving (Eq, Show) +type OID = Word32 + +data PGType = forall a . PGType + { pgTypeName :: String + , pgTypeType :: Type + , pgTypeDecode :: Q (TExp (L.ByteString -> a)) + , pgTypeShow :: Q (TExp (a -> String)) + } + +mkPGType :: String -> Type -> Q (TExp (L.ByteString -> a)) -> Q (TExp (a -> String)) -> a -> PGType +mkPGType name typ rd shw _ = PGType name typ rd shw + +mkPGLit :: (Read a, Show a) => String -> Type -> a -> PGType +mkPGLit name typ = mkPGType name typ [|| read . LC.unpack ||] [|| show ||] --- |Convert a type OID from PostgreSQL's catalog to a TemplatePG --- representation. To get a list of types: @SELECT typname, oid FROM pg_type@ --- Note that I have assumed, but not tested, that type OIDs for these basic --- types are consistent across installations. If not, I'm going to have to --- switch to using the text descriptions -pgTypeFromOID :: Int -- ^ PostgreSQL type OID - -> PGType -pgTypeFromOID 16 = PGBoolean -- bool --- treating all ints alike for now -pgTypeFromOID 20 = PGInteger -- int8 -pgTypeFromOID 21 = PGInteger -- int2 -pgTypeFromOID 23 = PGInteger -- int4 -pgTypeFromOID 25 = PGText -- text --- as with ints, sacrificing precision/safety for floats -pgTypeFromOID 700 = PGReal -- float4 -pgTypeFromOID 701 = PGReal -- float8 --- I don't currently treat varchars differently from text. It would make sense --- to do so if I could enforce length limits at compile time. -pgTypeFromOID 1043 = PGText -- varchar -pgTypeFromOID 1082 = PGDate -- date -pgTypeFromOID 1184 = PGTimestampTZ -- timestamptz -pgTypeFromOID 1186 = PGInterval -- interval -pgTypeFromOID n = error $ "Unknown PostgreSQL type: " ++ show n +type PGTypeMap = Map.Map OID PGType +defaultTypeMap :: PGTypeMap +defaultTypeMap = Map.fromAscList + [ (16, PGType "bool" (ConT ''Bool) + [|| readBool . LC.unpack ||] + [|| \b -> if b then "t" else "f" ||]) + -- , (17, PGType "bytea") + , (18, PGType "char" (ConT ''Char) + [|| LC.head ||] + [|| escapeChar ||]) + -- , (19, PGType "name") + , (20, mkPGLit "int8" (ConT ''Int64) (0 :: Int64)) + , (21, mkPGLit "int2" (ConT ''Int16) (0 :: Int16)) + -- , (22, PGType "int2vector") + , (23, mkPGLit "int4" (ConT ''Int32) (0 :: Int32)) + , (25, PGType "text" (ConT ''String) + [|| U.toString ||] + [|| escapeString ||]) + , (26, mkPGLit "oid" (ConT ''OID) (0 :: OID)) + , (700, mkPGLit "float4" (ConT ''Float) (0 :: Float)) + , (701, mkPGLit "float8" (ConT ''Float) (0 :: Double)) + , (1043, PGType "varchar" (ConT ''String) + [|| U.toString ||] + [|| escapeString ||]) + -- , (1082, PGType "date") + -- , (1184, PGType "timestamptz") + -- , (1186, PGType "interval") + ] + +readBool :: String -> Bool +readBool "f" = False +readBool "t" = True +readBool b = error $ "readBool: " ++ b + +escapeChar :: Char -> String +escapeChar '\'' = "''" +escapeChar c = return c + +escapeString :: String -> String +escapeString s = '\'' : concatMap escapeChar s ++ "'" + +{- -- |This is PostgreSQL's canonical timestamp format. -- Time conversions are complicated a bit because PostgreSQL doesn't support -- timezones with minute parts, and Haskell only supports timezones with @@ -59,27 +83,11 @@ pgTypeFromOID n = error $ "Unknown PostgreSQL type: " ++ show n pgTimestampTZFormat :: String pgTimestampTZFormat = "%F %T%z" -readIntegral :: (Read a, Integral a) => String -> a -readIntegral = read - -readReal :: (Read a, Real a) => String -> a -readReal = read - -showIntegral :: (Show a, Integral a) => a -> String -showIntegral = show - -showReal :: (Show a, Real a) => a -> String -showReal = show - -- |Convert a Haskell value to a string of the given PostgreSQL type. Or, more -- accurately, given a PostgreSQL type, create a function for converting -- compatible Haskell values into a string of that type. -- @pgTypeToString :: PGType -> (? -> String)@ pgTypeToString :: PGType -> Q Exp -pgTypeToString PGInteger = [| showIntegral |] -pgTypeToString PGReal = [| showReal |] -pgTypeToString PGText = [| escapeString |] -pgTypeToString PGBoolean = [| (\ b -> if b then "'t'" else "'f'") |] pgTypeToString PGTimestampTZ = [| \t -> let ts = formatTime defaultTimeLocale pgTimestampTZFormat t in "TIMESTAMP WITH TIME ZONE '" ++ (take (length ts - 2) ts) ++ "'" |] @@ -93,20 +101,7 @@ pgTypeToString PGInterval = [| \s -> "'" ++ show (s::DiffTime) ++ "'" |] -- @pgStringToType :: PGType -> (String -> ?)@ pgStringToType :: PGType -> Q Exp -- TODO: Is reading to any integral type too unsafe to justify the convenience? -pgStringToType PGInteger = [| readIntegral |] -pgStringToType PGReal = [| readReal |] -pgStringToType PGText = [| id |] -pgStringToType PGBoolean = [| \s -> case s of - "t" -> True - "f" -> False - _ -> error "unrecognized boolean type from PostgreSQL" |] pgStringToType PGTimestampTZ = [| \t -> readTime defaultTimeLocale pgTimestampTZFormat (t ++ "00") |] pgStringToType PGDate = [| readTime defaultTimeLocale "%F" |] pgStringToType PGInterval = error "Reading PostgreSQL intervals isn't supported (yet)." - --- |Make a string safe for interpolation (escape single-quotes). This relies on --- standard_conforming_strings = on in postgresql.conf. I'm not 100% sure that --- this makes all strings safe for execution. I don't know if it's possible to --- inject SQL with strange (possibly Unicode) characters. -escapeString :: String -> String -escapeString s = "'" ++ (subRegex (mkRegex "'") s "''") ++ "'" +-} From 90dc99eb5d1bff9f3d05a4b8fca2807b43a284d9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 26 Dec 2014 01:38:03 -0500 Subject: [PATCH 015/306] Set some connection parameters for safety --- Database/TemplatePG/Protocol.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 032ffaa..08126f0 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -158,6 +158,11 @@ pgConnect host port db user pass = do [ B.putWord32be protocolVersion , pgString "user", pgString user , pgString "database", pgString db + , pgString "client_encoding", pgString "UTF8" + , pgString "standard_conforming_strings", pgString "on" + , pgString "bytea_output", pgString "hex" + , pgString "DateStyle", pgString "ISO, YMD" + , pgString "IntervalStyle", pgString "postgres" , B.singleton 0 ] pgMessage :: B.Builder -> B.Builder pgMessage msg = B.append len msg From 10066b1328cb28a396dfa93f5818da41bcb12215 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 26 Dec 2014 13:21:10 -0500 Subject: [PATCH 016/306] Add some more type safety to type marshaling --- Database/TemplatePG/SQL.hs | 8 ++++---- Database/TemplatePG/Types.hs | 13 ++++++++++++- test/Main.hs | 2 +- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index d2619e3..ffb7b03 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -71,8 +71,8 @@ prepareSQL sql = do return (s, fTypes) where holdPlaces ss es = concat $ weave ss (take (length es) placeholders) placeholders = map (('$' :) . show) ([1..]::[Integer]) - stringify PGType{ pgTypeShow = shw } s = [| $(unType <$> shw) $(returnQ $ parseExp' s) |] - parseExp' e = (either (\ _ -> error ("Failed to parse expression: " ++ e)) id) $ parseExp e + stringify t s = [| $(pgTypeEscaper t) $(parseExp' s) |] + parseExp' e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) returnQ $ parseExp e (sqlStrings, expStrings) = parseSql sql -- |"weave" 2 lists of equal length into a single list. @@ -190,8 +190,8 @@ convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) pgStringToType' :: PGType -> Bool -- ^ nullability indicator -> Q Exp -pgStringToType' PGType{ pgTypeDecode = rd } False = [| ($(unType <$> rd)) . fromJust |] -pgStringToType' PGType{ pgTypeDecode = rd } True = [| liftM ($(unType <$> rd)) |] +pgStringToType' t False = [| $(pgTypeDecoder t) . fromJust |] +pgStringToType' t True = [| liftM $(pgTypeDecoder t) |] -- SQL Parser -- diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 29e8c4a..4be5fae 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -5,10 +5,13 @@ module Database.TemplatePG.Types ( OID , PGType(..) + , pgTypeDecoder + , pgTypeEscaper , PGTypeMap , defaultTypeMap ) where +import Control.Applicative ((<$>)) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U @@ -23,9 +26,17 @@ data PGType = forall a . PGType { pgTypeName :: String , pgTypeType :: Type , pgTypeDecode :: Q (TExp (L.ByteString -> a)) - , pgTypeShow :: Q (TExp (a -> String)) + , pgTypeEscape :: Q (TExp (a -> String)) } +pgTypeDecoder :: PGType -> Q Exp +pgTypeDecoder PGType{ pgTypeType = t, pgTypeDecode = f } = + sigE (unType <$> f) $ return $ ArrowT `AppT` ConT ''L.ByteString `AppT` t + +pgTypeEscaper :: PGType -> Q Exp +pgTypeEscaper PGType{ pgTypeType = t, pgTypeEscape = f } = + sigE (unType <$> f) $ return $ ArrowT `AppT` t `AppT` ConT ''String + mkPGType :: String -> Type -> Q (TExp (L.ByteString -> a)) -> Q (TExp (a -> String)) -> a -> PGType mkPGType name typ rd shw _ = PGType name typ rd shw diff --git a/test/Main.hs b/test/Main.hs index 8194821..984df3c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -15,5 +15,5 @@ useTHConnection connect main :: IO () main = do c <- connect - Just (Just 1) <- $(queryTuple "SELECT 1") c + Just (Just 1) <- $(queryTuple "SELECT {1}::int") c exitSuccess From 26e97709d03a22954771f5a465fb721137fc25cb Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 26 Dec 2014 18:01:02 -0500 Subject: [PATCH 017/306] Restore date parsing; add interval parsing --- Database/TemplatePG/Protocol.hs | 2 +- Database/TemplatePG/Types.hs | 122 +++++++++++++++++++------------- templatepg.cabal | 2 +- test/Main.hs | 10 ++- 4 files changed, 81 insertions(+), 55 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 08126f0..58ca438 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -162,7 +162,7 @@ pgConnect host port db user pass = do , pgString "standard_conforming_strings", pgString "on" , pgString "bytea_output", pgString "hex" , pgString "DateStyle", pgString "ISO, YMD" - , pgString "IntervalStyle", pgString "postgres" + , pgString "IntervalStyle", pgString "iso_8601" , B.singleton 0 ] pgMessage :: B.Builder -> B.Builder pgMessage msg = B.append len msg diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 4be5fae..d4703d3 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -2,23 +2,22 @@ -- Copyright 2010, 2011, 2013 Chris Forno -- Copyright 2014 Dylan Simon -module Database.TemplatePG.Types - ( OID - , PGType(..) - , pgTypeDecoder - , pgTypeEscaper - , PGTypeMap - , defaultTypeMap - ) where +module Database.TemplatePG.Types where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<$)) +import Control.Monad (mzero) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U +import Data.Char (isDigit) import Data.Int import qualified Data.Map as Map +import qualified Data.Time as Time import Data.Word (Word32) import Language.Haskell.TH +import System.Locale (defaultTimeLocale) +import qualified Text.Parsec as P +import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) type OID = Word32 @@ -48,8 +47,8 @@ type PGTypeMap = Map.Map OID PGType defaultTypeMap :: PGTypeMap defaultTypeMap = Map.fromAscList [ (16, PGType "bool" (ConT ''Bool) - [|| readBool . LC.unpack ||] - [|| \b -> if b then "t" else "f" ||]) + [|| parseBool . LC.unpack ||] + [|| \b -> if b then "true" else "false" ||]) -- , (17, PGType "bytea") , (18, PGType "char" (ConT ''Char) [|| LC.head ||] @@ -68,51 +67,72 @@ defaultTypeMap = Map.fromAscList , (1043, PGType "varchar" (ConT ''String) [|| U.toString ||] [|| escapeString ||]) - -- , (1082, PGType "date") - -- , (1184, PGType "timestamptz") - -- , (1186, PGType "interval") + , (1082, PGType "date" (ConT ''Time.Day) + [|| Time.readTime defaultTimeLocale "%F" . LC.unpack ||] + [|| escapeString . Time.showGregorian ||]) + , (1184, mkPGType "timestamptz" (ConT ''Time.ZonedTime) + [|| Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . LC.unpack ||] + [|| escapeString . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" ||] + (undefined :: Time.ZonedTime)) + , (1186, PGType "interval" (ConT ''Time.DiffTime) + [|| parseInterval ||] + [|| escapeString . show ||]) ] -readBool :: String -> Bool -readBool "f" = False -readBool "t" = True -readBool b = error $ "readBool: " ++ b +parseBool :: String -> Bool +parseBool "f" = False +parseBool "t" = True +parseBool b = error $ "parseBool: " ++ b escapeChar :: Char -> String escapeChar '\'' = "''" escapeChar c = return c escapeString :: String -> String -escapeString s = '\'' : concatMap escapeChar s ++ "'" - -{- --- |This is PostgreSQL's canonical timestamp format. --- Time conversions are complicated a bit because PostgreSQL doesn't support --- timezones with minute parts, and Haskell only supports timezones with --- minutes parts. We'll need to truncate and pad timestamp strings accordingly. --- This means with minute parts will not work. -pgTimestampTZFormat :: String -pgTimestampTZFormat = "%F %T%z" - --- |Convert a Haskell value to a string of the given PostgreSQL type. Or, more --- accurately, given a PostgreSQL type, create a function for converting --- compatible Haskell values into a string of that type. --- @pgTypeToString :: PGType -> (? -> String)@ -pgTypeToString :: PGType -> Q Exp -pgTypeToString PGTimestampTZ = [| \t -> let ts = formatTime defaultTimeLocale pgTimestampTZFormat t in - "TIMESTAMP WITH TIME ZONE '" ++ - (take (length ts - 2) ts) ++ "'" |] -pgTypeToString PGDate = [| \d -> "'" ++ showGregorian d ++ "'" |] -pgTypeToString PGInterval = [| \s -> "'" ++ show (s::DiffTime) ++ "'" |] - --- |Convert a string from PostgreSQL of the given type into an appropriate --- Haskell value. Or, more accurately, given a PostgreSQL type, create a --- function for converting a string of that type into a compatible Haskell --- value. --- @pgStringToType :: PGType -> (String -> ?)@ -pgStringToType :: PGType -> Q Exp --- TODO: Is reading to any integral type too unsafe to justify the convenience? -pgStringToType PGTimestampTZ = [| \t -> readTime defaultTimeLocale pgTimestampTZFormat (t ++ "00") |] -pgStringToType PGDate = [| readTime defaultTimeLocale "%F" |] -pgStringToType PGInterval = error "Reading PostgreSQL intervals isn't supported (yet)." --} +escapeString = ('\'' :) . es where -- concatMap escapeChar + es "" = "'" + es (c@'\'':s) = c:c:es s + es (c:s) = c:es s + +-- 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 + +-- PostgreSQL stores months and days separately, but here we must collapse them into seconds +parseInterval :: L.ByteString -> Time.DiffTime +parseInterval = either (error . 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 + } diff --git a/templatepg.cabal b/templatepg.cabal index 8c469f7..d6eb8ed 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -58,7 +58,7 @@ Library CPP-options: -DUSE_MD5 test-suite test - build-depends: base, network, templatepg + build-depends: base, network, time, templatepg type: exitcode-stdio-1.0 main-is: Main.hs buildable: True diff --git a/test/Main.hs b/test/Main.hs index 984df3c..972ff80 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,9 +1,10 @@ module Main (main) where -import Database.TemplatePG +import qualified Data.Time as Time import System.Environment (setEnv) import System.Exit (exitSuccess, exitFailure) +import Database.TemplatePG import Connect assert :: Bool -> IO () @@ -15,5 +16,10 @@ useTHConnection connect main :: IO () main = do c <- connect - Just (Just 1) <- $(queryTuple "SELECT {1}::int") c + t <- Time.getZonedTime + let d = Time.localDay $ Time.zonedTimeToLocalTime t + p = -34881559 + Just (Just 1, Just True, Just 3.14, Just d', Just t', Just p') <- + $(queryTuple "SELECT {1}::int, {True}::bool, {3.14}::float4, {d}::date, {t}::timestamptz, {p}::interval") c + assert $ d == d' && Time.zonedTimeToUTC t == Time.zonedTimeToUTC t' && p == p' exitSuccess From 6eb7eaeb1b13f19b02bd64a9aa1e60005f9276f2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 26 Dec 2014 18:14:55 -0500 Subject: [PATCH 018/306] Add support for timestamp (without timezone) --- Database/TemplatePG/Types.hs | 4 ++++ test/Main.hs | 11 ++++++----- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index d4703d3..8b90b11 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -70,6 +70,10 @@ defaultTypeMap = Map.fromAscList , (1082, PGType "date" (ConT ''Time.Day) [|| Time.readTime defaultTimeLocale "%F" . LC.unpack ||] [|| escapeString . Time.showGregorian ||]) + , (1114, mkPGType "timestamp" (ConT ''Time.LocalTime) + [|| Time.readTime defaultTimeLocale "%F %T%Q" . LC.unpack ||] + [|| escapeString . Time.formatTime defaultTimeLocale "%F %T%Q" ||] + (undefined :: Time.LocalTime)) , (1184, mkPGType "timestamptz" (ConT ''Time.ZonedTime) [|| Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . LC.unpack ||] [|| escapeString . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" ||] diff --git a/test/Main.hs b/test/Main.hs index 972ff80..9f65235 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -16,10 +16,11 @@ useTHConnection connect main :: IO () main = do c <- connect - t <- Time.getZonedTime - let d = Time.localDay $ Time.zonedTimeToLocalTime t + z <- Time.getZonedTime + let t = Time.zonedTimeToLocalTime z + d = Time.localDay t p = -34881559 - Just (Just 1, Just True, Just 3.14, Just d', Just t', Just p') <- - $(queryTuple "SELECT {1}::int, {True}::bool, {3.14}::float4, {d}::date, {t}::timestamptz, {p}::interval") c - assert $ d == d' && Time.zonedTimeToUTC t == Time.zonedTimeToUTC t' && p == p' + Just (Just 1, Just True, Just 3.14, Just d', Just t', Just z', Just p') <- + $(queryTuple "SELECT {1}::int, {True}::bool, {3.14}::float4, {d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval") c + assert $ d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' exitSuccess From 688ec7a97dd48fcc4ef2c5eb6eebcf8a949e7148 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 26 Dec 2014 18:40:45 -0500 Subject: [PATCH 019/306] Add support for time <-> TimeOfDay --- Database/TemplatePG/Types.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 8b90b11..c9216f9 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -64,12 +64,18 @@ defaultTypeMap = Map.fromAscList , (26, mkPGLit "oid" (ConT ''OID) (0 :: OID)) , (700, mkPGLit "float4" (ConT ''Float) (0 :: Float)) , (701, mkPGLit "float8" (ConT ''Float) (0 :: Double)) + -- , (1042, PGType "bpchar" , (1043, PGType "varchar" (ConT ''String) [|| U.toString ||] [|| escapeString ||]) - , (1082, PGType "date" (ConT ''Time.Day) + , (1082, mkPGType "date" (ConT ''Time.Day) [|| Time.readTime defaultTimeLocale "%F" . LC.unpack ||] - [|| escapeString . Time.showGregorian ||]) + [|| escapeString . Time.showGregorian ||] + (undefined :: Time.Day)) + , (1083, mkPGType "time" (ConT ''Time.TimeOfDay) + [|| Time.readTime defaultTimeLocale "%T%Q" . LC.unpack ||] + [|| escapeString . Time.formatTime defaultTimeLocale "%T%Q" ||] + (undefined :: Time.TimeOfDay)) , (1114, mkPGType "timestamp" (ConT ''Time.LocalTime) [|| Time.readTime defaultTimeLocale "%F %T%Q" . LC.unpack ||] [|| escapeString . Time.formatTime defaultTimeLocale "%F %T%Q" ||] @@ -81,6 +87,9 @@ defaultTypeMap = Map.fromAscList , (1186, PGType "interval" (ConT ''Time.DiffTime) [|| parseInterval ||] [|| escapeString . show ||]) + -- , (1560, PGType "bit" + -- , (1562, PGType "varbit" + -- , (1700, PGType "numeric" ] parseBool :: String -> Bool From e31b02f1ae9fe30ec7947a37aaeddec268ad68ca Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 27 Dec 2014 00:58:33 -0500 Subject: [PATCH 020/306] Add support for bytea <-> ByteString and numeric <-> Rational --- Database/TemplatePG/Types.hs | 61 +++++++++++++++++++++++++++++------- 1 file changed, 50 insertions(+), 11 deletions(-) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index c9216f9..44ca6ea 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -6,15 +6,19 @@ module Database.TemplatePG.Types where import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero) +import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (isDigit) import Data.Int import qualified Data.Map as Map +import Data.Ratio (numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) import Language.Haskell.TH +import Numeric (readFloat) import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) @@ -47,16 +51,17 @@ type PGTypeMap = Map.Map OID PGType defaultTypeMap :: PGTypeMap defaultTypeMap = Map.fromAscList [ (16, PGType "bool" (ConT ''Bool) - [|| parseBool . LC.unpack ||] + [|| parseBool ||] [|| \b -> if b then "true" else "false" ||]) - -- , (17, PGType "bytea") + , (17, PGType "bytea" (ConT ''L.ByteString) + [|| parseBytea ||] + [|| escapeBytea ||]) , (18, PGType "char" (ConT ''Char) [|| LC.head ||] [|| escapeChar ||]) -- , (19, PGType "name") , (20, mkPGLit "int8" (ConT ''Int64) (0 :: Int64)) , (21, mkPGLit "int2" (ConT ''Int16) (0 :: Int16)) - -- , (22, PGType "int2vector") , (23, mkPGLit "int4" (ConT ''Int32) (0 :: Int32)) , (25, PGType "text" (ConT ''String) [|| U.toString ||] @@ -64,7 +69,7 @@ defaultTypeMap = Map.fromAscList , (26, mkPGLit "oid" (ConT ''OID) (0 :: OID)) , (700, mkPGLit "float4" (ConT ''Float) (0 :: Float)) , (701, mkPGLit "float8" (ConT ''Float) (0 :: Double)) - -- , (1042, PGType "bpchar" + -- , (1042, PGType "bpchar") , (1043, PGType "varchar" (ConT ''String) [|| U.toString ||] [|| escapeString ||]) @@ -87,15 +92,24 @@ defaultTypeMap = Map.fromAscList , (1186, PGType "interval" (ConT ''Time.DiffTime) [|| parseInterval ||] [|| escapeString . show ||]) - -- , (1560, PGType "bit" - -- , (1562, PGType "varbit" - -- , (1700, PGType "numeric" + -- , (1560, PGType "bit") + -- , (1562, PGType "varbit") + , (1700, mkPGType "numeric" (ConT ''Rational) + [|| unReads readFloat . LC.unpack ||] + [|| escapeRational ||] + (0 :: Rational)) ] -parseBool :: String -> Bool -parseBool "f" = False -parseBool "t" = True -parseBool b = error $ "parseBool: " ++ b +unReads :: ReadS a -> String -> a +unReads r = ur . r where + ur [(x,"")] = x + ur _ = error "unReads: no parse" + +parseBool :: L.ByteString -> Bool +parseBool = pb . LC.unpack where + pb "f" = False + pb "t" = True + pb b = error $ "parseBool: " ++ b escapeChar :: Char -> String escapeChar '\'' = "''" @@ -107,6 +121,31 @@ escapeString = ('\'' :) . es where -- concatMap escapeChar es (c@'\'':s) = c:c:es s es (c:s) = c:es s +parseBytea :: L.ByteString -> L.ByteString +parseBytea s + | LC.unpack m /= "\\x" = error $ "parseBytea: " ++ LC.unpack m + | otherwise = L.pack $ pd $ L.unpack d where + (m, d) = L.splitAt 2 s + pd [] = [] + pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r + pd [x] = error $ "parseBytea: " ++ show x + unhex c + | c >= 48 && c <= 57 = c - 48 + | c >= 65 && c <= 70 = c - 55 + | c >= 97 && c <= 102 = c - 87 + | otherwise = error $ "parseBytea: " ++ show c + +escapeBytea :: L.ByteString -> String +escapeBytea = (++) "'\\x" . ed . L.unpack where + ed [] = "\'" + ed (x:d) = hex (shiftR x 4) : hex (x .&. 15) : ed d + hex c + | c < 10 = w2c $ 48 + c + | otherwise = w2c $ 87 + c + +escapeRational :: Rational -> String +escapeRational r = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" + -- 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 From 61d94ddc3296dcb54d9c14d06aa1bca71ecd68dc Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 27 Dec 2014 16:22:46 -0500 Subject: [PATCH 021/306] Switch type encoders to PGType class Having both BS and String versions may be overkill, but we'll see. I gave up on using ShowS for the literals at least. --- Database/TemplatePG/Protocol.hs | 18 +- Database/TemplatePG/SQL.hs | 21 +- Database/TemplatePG/Types.hs | 401 ++++++++++++++++++++------------ 3 files changed, 284 insertions(+), 156 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 58ca438..fd76a83 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -13,6 +13,8 @@ module Database.TemplatePG.Protocol ( PGConnection , describeStatement , executeSimpleQuery , executeSimpleStatement + , pgAddType + , getTypeOID ) where import Database.TemplatePG.Types @@ -32,7 +34,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import qualified Data.Map as Map -import Data.Maybe (isJust) +import Data.Maybe (isJust, listToMaybe, fromJust) import Data.Monoid import Data.Typeable (Typeable) import Network (HostName, PortID, connectTo) @@ -190,6 +192,9 @@ pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () pgDisconnect PGConnection{ pgHandle = h } = hClose h +pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection +pgAddType oid th p = p{ pgTypes = Map.insert oid th $ pgTypes p } + -- |Convert a string to a NULL-terminated UTF-8 string. The PostgreSQL -- protocol transmits most strings in this format. -- I haven't yet found a function for doing this without requiring manual @@ -351,11 +356,16 @@ pgWaitFor h ids = do then return response else pgWaitFor h ids -getPGType :: PGConnection -> OID -> IO PGType +getTypeOID :: PGConnection -> String -> IO (Maybe OID) +getTypeOID c t = + (fmap (read . LC.unpack . fromJust . head) . listToMaybe) <$> + executeSimpleQuery ("SELECT oid FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c + +getPGType :: PGConnection -> OID -> IO PGTypeHandler getPGType c@PGConnection{ pgTypes = types } oid = maybe notype return $ Map.lookup oid types where notype = do - r <- executeSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ show oid) c + r <- executeSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) c case r of [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ U.toString s _ -> fail $ "Unknown PostgreSQL type: " ++ show oid @@ -366,7 +376,7 @@ getPGType c@PGConnection{ pgTypes = types } oid = -- type of the field, and a nullability indicator). describeStatement :: PGConnection -> String -- ^ SQL string - -> IO ([PGType], [(String, PGType, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. + -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. describeStatement h sql = do pgSend h $ Parse sql "" pgSend h $ Describe "" diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index ffb7b03..48b47fa 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -17,6 +17,7 @@ module Database.TemplatePG.SQL ( queryTuples , rollback , withTHConnection , useTHConnection + , handlePGType ) where import Database.TemplatePG.Protocol @@ -58,12 +59,15 @@ setTHConnection c = modifyMVar_ thConnection $ either (const $ return c) ((c <$) useTHConnection :: IO PGConnection -> Q [Dec] useTHConnection c = [] <$ runIO (setTHConnection (Left c)) +modifyTHConnection :: (PGConnection -> PGConnection) -> IO () +modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . liftM f) (Right . f) + -- |This is where most of the magic happens. -- This doesn't result in a PostgreSQL prepared statement, it just creates one -- to do type inference. -- This returns a prepared SQL string with all values (as an expression) prepareSQL :: String -- ^ a SQL string, with - -> Q (Exp, [(String, PGType, Bool)]) -- ^ a prepared SQL string and result descriptions + -> Q (Exp, [(String, PGTypeHandler, Bool)]) -- ^ a prepared SQL string and result descriptions prepareSQL sql = do (pTypes, fTypes) <- runIO $ withTHConnection $ \c -> describeStatement c (holdPlaces sqlStrings expStrings) @@ -87,8 +91,8 @@ weaveString :: [String] -- ^ SQL fragments -> Q Exp weaveString [] [] = [| "" |] weaveString [x] [] = [| x |] -weaveString [] [y] = returnQ y -weaveString (x:xs) (y:ys) = [| x ++ $(returnQ y) ++ $(weaveString xs ys) |] +weaveString [] [y] = return y +weaveString (x:xs) (y:ys) = [| x ++ $(return y) ++ $(weaveString xs ys) |] weaveString _ _ = error "Weave mismatch (possible parse problem)" -- |@queryTuples :: String -> (PGConnection -> IO [(column1, column2, ...)])@ @@ -169,7 +173,7 @@ insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) -- |Given a result description, create a function to convert a result to a -- tuple. -convertRow :: [(String, PGType, Bool)] -- ^ result description +convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description -> Q Exp -- ^ A function for converting a row of the given result description convertRow types = do n <- newName "result" @@ -178,7 +182,7 @@ convertRow types = do -- |Given a raw PostgreSQL result and a result field type, convert the -- appropriate field to a Haskell value. convertColumn :: Name -- ^ the name of the variable containing the result list (of 'Maybe' 'ByteString') - -> ((String, PGType, Bool), Int) -- ^ the result field type and index + -> ((String, PGTypeHandler, Bool), Int) -- ^ the result field type and index -> Q Exp convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) ($(varE name) !! i) |] @@ -187,7 +191,7 @@ convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) -- and we can use 'fromJust' to keep the code simple. If it's 'True', then we -- don't know if the value is nullable and must return a 'Maybe' value in case -- it is. -pgStringToType' :: PGType +pgStringToType' :: PGTypeHandler -> Bool -- ^ nullability indicator -> Q Exp pgStringToType' t False = [| $(pgTypeDecoder t) . fromJust |] @@ -217,3 +221,8 @@ sqlText = P.many1 (P.noneOf "{") -- by haskell-src-meta. sqlParameter :: P.Parser String sqlParameter = P.between (P.char '{') (P.char '}') $ P.many1 (P.noneOf "}") + +handlePGType :: String -> Type -> Q [Dec] +handlePGType name typ = [] <$ runIO (do + oid <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) + modifyTHConnection (pgAddType oid (PGType name typ))) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 44ca6ea..ca2a416 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -1,8 +1,17 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances #-} -- Copyright 2010, 2011, 2013 Chris Forno -- Copyright 2014 Dylan Simon -module Database.TemplatePG.Types where +module Database.TemplatePG.Types + ( pgQuote + , PGType(..) + , OID + , PGTypeHandler(..) + , pgTypeDecoder + , pgTypeEscaper + , PGTypeMap + , defaultTypeMap + ) where import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero) @@ -11,10 +20,11 @@ import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U -import Data.Char (isDigit) +import Data.Char (isDigit, digitToInt, intToDigit) import Data.Int import qualified Data.Map as Map -import Data.Ratio (numerator, denominator) +import Data.Maybe (fromMaybe) +import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) import Language.Haskell.TH @@ -22,129 +32,154 @@ import Numeric (readFloat) import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) +import Text.Read (readMaybe) + +pgQuoteUnsafe :: String -> String +pgQuoteUnsafe s = '\'' : s ++ "'" + +pgQuote :: String -> String +pgQuote = ('\'':) . es where + es "" = "'" + es (c@'\'':r) = c:c:es r + es (c:r) = c:es r + +-- |Any type which can be marshalled to and from PostgreSQL. +-- Minimal definition: 'pgDecodeBS' (or 'pgDecode') and 'pgEncode' (or 'pgEncodeBS') +-- The default implementations do UTF-8 conversion. +class PGType a where + -- |Decode a postgres raw text representation into a value. + pgDecodeBS :: L.ByteString -> Maybe a + pgDecodeBS = pgDecode . U.toString + -- |Decode a postgres unicode string representation into a value. + pgDecode :: String -> Maybe a + pgDecode = pgDecodeBS . U.fromString + -- |Encode a value to a postgres raw text representation. + pgEncodeBS :: a -> L.ByteString + pgEncodeBS = U.fromString . pgEncode + -- |Encode a value to a postgres unicode representation. + pgEncode :: a -> String + pgEncode = U.toString . pgEncodeBS + -- |Encode a value to a quoted literal value for use in statements. + pgLiteral :: a -> String + pgLiteral = pgQuote . pgEncode + +instance PGType Bool where + pgDecode "f" = return False + pgDecode "t" = return True + pgDecode _ = fail "bool" + pgEncode False = "f" + pgEncode True = "t" + pgLiteral False = "false" + pgLiteral True = "true" type OID = Word32 +instance PGType OID where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -data PGType = forall a . PGType - { pgTypeName :: String - , pgTypeType :: Type - , pgTypeDecode :: Q (TExp (L.ByteString -> a)) - , pgTypeEscape :: Q (TExp (a -> String)) - } +instance PGType Int where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -pgTypeDecoder :: PGType -> Q Exp -pgTypeDecoder PGType{ pgTypeType = t, pgTypeDecode = f } = - sigE (unType <$> f) $ return $ ArrowT `AppT` ConT ''L.ByteString `AppT` t +instance PGType Int16 where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -pgTypeEscaper :: PGType -> Q Exp -pgTypeEscaper PGType{ pgTypeType = t, pgTypeEscape = f } = - sigE (unType <$> f) $ return $ ArrowT `AppT` t `AppT` ConT ''String +instance PGType Int32 where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -mkPGType :: String -> Type -> Q (TExp (L.ByteString -> a)) -> Q (TExp (a -> String)) -> a -> PGType -mkPGType name typ rd shw _ = PGType name typ rd shw +instance PGType Int64 where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -mkPGLit :: (Read a, Show a) => String -> Type -> a -> PGType -mkPGLit name typ = mkPGType name typ [|| read . LC.unpack ||] [|| show ||] +instance PGType Char where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode [c] = return c + pgDecode _ = fail "char" + pgEncode c + | fromEnum c < 256 = [c] + | otherwise = error "pgEncode: Char out of range" -type PGTypeMap = Map.Map OID PGType +instance PGType Float where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -defaultTypeMap :: PGTypeMap -defaultTypeMap = Map.fromAscList - [ (16, PGType "bool" (ConT ''Bool) - [|| parseBool ||] - [|| \b -> if b then "true" else "false" ||]) - , (17, PGType "bytea" (ConT ''L.ByteString) - [|| parseBytea ||] - [|| escapeBytea ||]) - , (18, PGType "char" (ConT ''Char) - [|| LC.head ||] - [|| escapeChar ||]) - -- , (19, PGType "name") - , (20, mkPGLit "int8" (ConT ''Int64) (0 :: Int64)) - , (21, mkPGLit "int2" (ConT ''Int16) (0 :: Int16)) - , (23, mkPGLit "int4" (ConT ''Int32) (0 :: Int32)) - , (25, PGType "text" (ConT ''String) - [|| U.toString ||] - [|| escapeString ||]) - , (26, mkPGLit "oid" (ConT ''OID) (0 :: OID)) - , (700, mkPGLit "float4" (ConT ''Float) (0 :: Float)) - , (701, mkPGLit "float8" (ConT ''Float) (0 :: Double)) - -- , (1042, PGType "bpchar") - , (1043, PGType "varchar" (ConT ''String) - [|| U.toString ||] - [|| escapeString ||]) - , (1082, mkPGType "date" (ConT ''Time.Day) - [|| Time.readTime defaultTimeLocale "%F" . LC.unpack ||] - [|| escapeString . Time.showGregorian ||] - (undefined :: Time.Day)) - , (1083, mkPGType "time" (ConT ''Time.TimeOfDay) - [|| Time.readTime defaultTimeLocale "%T%Q" . LC.unpack ||] - [|| escapeString . Time.formatTime defaultTimeLocale "%T%Q" ||] - (undefined :: Time.TimeOfDay)) - , (1114, mkPGType "timestamp" (ConT ''Time.LocalTime) - [|| Time.readTime defaultTimeLocale "%F %T%Q" . LC.unpack ||] - [|| escapeString . Time.formatTime defaultTimeLocale "%F %T%Q" ||] - (undefined :: Time.LocalTime)) - , (1184, mkPGType "timestamptz" (ConT ''Time.ZonedTime) - [|| Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . LC.unpack ||] - [|| escapeString . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" ||] - (undefined :: Time.ZonedTime)) - , (1186, PGType "interval" (ConT ''Time.DiffTime) - [|| parseInterval ||] - [|| escapeString . show ||]) - -- , (1560, PGType "bit") - -- , (1562, PGType "varbit") - , (1700, mkPGType "numeric" (ConT ''Rational) - [|| unReads readFloat . LC.unpack ||] - [|| escapeRational ||] - (0 :: Rational)) - ] +instance PGType Double where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = readMaybe + pgEncode = show + pgLiteral = show -unReads :: ReadS a -> String -> a -unReads r = ur . r where - ur [(x,"")] = x - ur _ = error "unReads: no parse" +instance PGType String where + pgDecode = return + pgEncode = id -parseBool :: L.ByteString -> Bool -parseBool = pb . LC.unpack where - pb "f" = False - pb "t" = True - pb b = error $ "parseBool: " ++ b +type Bytea = L.ByteString +instance PGType Bytea where + pgDecode = pgDecodeBS . LC.pack + pgEncodeBS = LC.pack . pgEncode + pgDecodeBS s + | LC.unpack m /= "\\x" = fail "bytea" + | otherwise = return $ L.pack $ pd $ L.unpack d where + (m, d) = L.splitAt 2 s + pd [] = [] + pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r + pd [x] = error $ "parseBytea: " ++ show x + unhex = fromIntegral . digitToInt . w2c + pgEncode = (++) "'\\x" . ed . L.unpack where + ed [] = "\'" + ed (x:d) = hex (shiftR x 4) : hex (x .&. 0xF) : ed d + hex = intToDigit . fromIntegral + pgLiteral = pgQuoteUnsafe . pgEncode -escapeChar :: Char -> String -escapeChar '\'' = "''" -escapeChar c = return c +instance PGType Time.Day where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = Time.parseTime defaultTimeLocale "%F" + pgEncode = Time.showGregorian + pgLiteral = pgQuoteUnsafe . pgEncode -escapeString :: String -> String -escapeString = ('\'' :) . es where -- concatMap escapeChar - es "" = "'" - es (c@'\'':s) = c:c:es s - es (c:s) = c:es s - -parseBytea :: L.ByteString -> L.ByteString -parseBytea s - | LC.unpack m /= "\\x" = error $ "parseBytea: " ++ LC.unpack m - | otherwise = L.pack $ pd $ L.unpack d where - (m, d) = L.splitAt 2 s - pd [] = [] - pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r - pd [x] = error $ "parseBytea: " ++ show x - unhex c - | c >= 48 && c <= 57 = c - 48 - | c >= 65 && c <= 70 = c - 55 - | c >= 97 && c <= 102 = c - 87 - | otherwise = error $ "parseBytea: " ++ show c - -escapeBytea :: L.ByteString -> String -escapeBytea = (++) "'\\x" . ed . L.unpack where - ed [] = "\'" - ed (x:d) = hex (shiftR x 4) : hex (x .&. 15) : ed d - hex c - | c < 10 = w2c $ 48 + c - | otherwise = w2c $ 87 + c - -escapeRational :: Rational -> String -escapeRational r = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" +instance PGType Time.TimeOfDay where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = Time.parseTime defaultTimeLocale "%T%Q" + pgEncode = Time.formatTime defaultTimeLocale "%T%Q" + pgLiteral = pgQuoteUnsafe . pgEncode + +instance PGType Time.LocalTime where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = Time.parseTime defaultTimeLocale "%F %T%Q" + pgEncode = Time.formatTime defaultTimeLocale "%F %T%Q" + pgLiteral = pgQuoteUnsafe . pgEncode + +instance PGType Time.ZonedTime where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode = Time.parseTime defaultTimeLocale "%F %T%Q%z" . fixTZ + pgEncode = fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" + pgLiteral = pgQuoteUnsafe . pgEncode -- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. -- readTime can successfully parse both formats, but PostgreSQL needs the colon. @@ -156,35 +191,109 @@ fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2] fixTZ (c:s) = c:fixTZ s --- PostgreSQL stores months and days separately, but here we must collapse them into seconds -parseInterval :: L.ByteString -> Time.DiffTime -parseInterval = either (error . 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 - } +-- |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 PGType Time.DiffTime where + pgDecode = pgDecodeBS . LC.pack + pgEncodeBS = LC.pack . pgEncode + pgDecodeBS = either (fail . show) return . 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 + } + pgEncode = show + pgLiteral = pgQuoteUnsafe . pgEncode -- could be more efficient + +-- |High-precision representation of Rational as numeric. +-- Unfortunately, numeric has an NaN, while Rational does not. +-- NaN numeric values will thus produce exceptions. +instance PGType Rational where + pgDecodeBS = pgDecode . LC.unpack + pgEncodeBS = LC.pack . pgEncode + pgDecode "NaN" = Just (0 % 0) -- this won't work + pgDecode s = unReads $ readFloat s + pgEncode r + | denominator r == 0 = "NaN" -- this can't happen + | otherwise = take 30 (showRational (r / (10 ^^ e))) ++ 'e' : show e where + e = floor $ logBase 10 $ fromRational $ abs r -- not great, and arbitrarily truncate somewhere + pgLiteral r + | denominator r == 0 = "'NaN'" -- this can't happen + | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" + +-- This may produce infinite strings +showRational :: Rational -> String +showRational r = show (ri :: Integer) ++ '.' : frac rf where + (ri, rf) = properFraction r + frac 0 = "" + frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) + +unReads :: [(a,String)] -> Maybe a +unReads [(x,"")] = return x +unReads _ = fail "unReads: no parse" + + +data PGTypeHandler = PGType + { pgTypeName :: String + , pgTypeType :: Type + } + +pgTypeDecoder :: PGTypeHandler -> Q Exp +pgTypeDecoder PGType{ pgTypeType = t } = + [| fromMaybe (error "pgDecode: no parse") . pgDecodeBS :: L.ByteString -> $(return t) |] + +pgTypeEscaper :: PGTypeHandler -> Q Exp +pgTypeEscaper PGType{ pgTypeType = t } = + [| pgLiteral :: $(return t) -> String |] + +type PGTypeMap = Map.Map OID PGTypeHandler + +defaultTypeMap :: PGTypeMap +defaultTypeMap = Map.fromAscList + [ (16, PGType "bool" (ConT ''Bool)) + , (17, PGType "bytea" (ConT ''L.ByteString)) + , (18, PGType "char" (ConT ''Char)) + -- , (19, PGType "name") + , (20, PGType "int8" (ConT ''Int64)) + , (21, PGType "int2" (ConT ''Int16)) + , (23, PGType "int4" (ConT ''Int32)) + , (25, PGType "text" (ConT ''String)) + , (26, PGType "oid" (ConT ''OID)) + , (700, PGType "float4" (ConT ''Float)) + , (701, PGType "float8" (ConT ''Double)) + , (1042, PGType "bpchar" (ConT ''String)) + , (1043, PGType "varchar" (ConT ''String)) + , (1082, PGType "date" (ConT ''Time.Day)) + , (1083, PGType "time" (ConT ''Time.TimeOfDay)) + , (1114, PGType "timestamp" (ConT ''Time.LocalTime)) + , (1184, PGType "timestamptz" (ConT ''Time.ZonedTime)) + , (1186, PGType "interval" (ConT ''Time.DiffTime)) + -- , (1560, PGType "bit") + -- , (1562, PGType "varbit") + , (1700, PGType "numeric" (ConT ''Rational)) + ] From 84e7f01069e5bb019a9dde85fdbab0b14ba44995 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 27 Dec 2014 20:15:27 -0500 Subject: [PATCH 022/306] Add support for arrays as [Maybe a] --- Database/TemplatePG.hs | 1 + Database/TemplatePG/Protocol.hs | 16 +++--- Database/TemplatePG/SQL.hs | 8 +-- Database/TemplatePG/Types.hs | 91 ++++++++++++++++++++++++--------- test/Main.hs | 7 +-- 5 files changed, 86 insertions(+), 37 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 488a372..893d3da 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -25,6 +25,7 @@ module Database.TemplatePG (-- *Introduction , pgConnect , pgDisconnect , useTHConnection + , handlePGType , queryTuples , queryTuple , execute diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index fd76a83..a88a808 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- |The Protocol module allows for direct, low-level communication with a @@ -34,7 +34,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import qualified Data.Map as Map -import Data.Maybe (isJust, listToMaybe, fromJust) +import Data.Maybe (isJust) import Data.Monoid import Data.Typeable (Typeable) import Network (HostName, PortID, connectTo) @@ -356,10 +356,14 @@ pgWaitFor h ids = do then return response else pgWaitFor h ids -getTypeOID :: PGConnection -> String -> IO (Maybe OID) -getTypeOID c t = - (fmap (read . LC.unpack . fromJust . head) . listToMaybe) <$> - executeSimpleQuery ("SELECT oid FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c +getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) +getTypeOID c t = do + r <- executeSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c + case r of + [] -> return Nothing + [[Just o, Just lo]] | Just to <- pgDecodeBS o, Just lto <- pgDecodeBS lo -> + return (Just (to, lto)) + _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r getPGType :: PGConnection -> OID -> IO PGTypeHandler getPGType c@PGConnection{ pgTypes = types } oid = diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 48b47fa..38a75ab 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -26,7 +26,7 @@ import Database.TemplatePG.Types import Control.Applicative ((<$>), (<$)) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) import Control.Exception (onException, catchJust) -import Control.Monad (zipWithM, liftM, (>=>)) +import Control.Monad (zipWithM, liftM, (>=>), when) import Data.Maybe (fromMaybe, fromJust) import Language.Haskell.Meta.Parse (parseExp) import Language.Haskell.TH @@ -224,5 +224,7 @@ sqlParameter = P.between (P.char '{') (P.char '}') $ P.many1 (P.noneOf "}") handlePGType :: String -> Type -> Q [Dec] handlePGType name typ = [] <$ runIO (do - oid <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) - modifyTHConnection (pgAddType oid (PGType name typ))) + (oid, loid) <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) + modifyTHConnection (pgAddType oid (PGType name typ)) + when (loid /= 0) $ + modifyTHConnection (pgAddType loid (pgArrayType name typ))) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index ca2a416..302cf7a 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, OverlappingInstances, ScopedTypeVariables #-} -- Copyright 2010, 2011, 2013 Chris Forno -- Copyright 2014 Dylan Simon @@ -11,6 +11,7 @@ module Database.TemplatePG.Types , pgTypeEscaper , PGTypeMap , defaultTypeMap + , pgArrayType ) where import Control.Applicative ((<$>), (<$)) @@ -22,6 +23,7 @@ import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (isDigit, digitToInt, intToDigit) import Data.Int +import Data.List (intercalate) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Ratio ((%), numerator, denominator) @@ -248,7 +250,7 @@ instance PGType Rational where -- This may produce infinite strings showRational :: Rational -> String -showRational r = show (ri :: Integer) ++ '.' : frac rf where +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) @@ -257,6 +259,26 @@ unReads :: [(a,String)] -> Maybe a unReads [(x,"")] = return x unReads _ = fail "unReads: no parse" +instance PGType a => PGType [Maybe a] where + pgDecodeBS = either (fail . show) return . P.parse pa "array" where + pa = do + l <- P.between (P.char '{') (P.char '}') $ + P.sepBy nel (P.char ',') + _ <- P.eof + return l + nel = Nothing <$ nul P.<|> Just <$> el + nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll" + el = maybe (fail "array element") return . pgDecodeBS . LC.pack =<< qel P.<|> uqel + qel = P.between (P.char '"') (P.char '"') $ + P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" + uqel = P.many1 (P.noneOf "\",{}") + pgEncode l = '{' : intercalate "," (map el l) ++ "}" where + el Nothing = "null" + el (Just e) = '"' : es (pgEncode e) -- quoting may not be necessary but is always safe + es "" = "\"" + es (c@'"':r) = '\\':c:es r + es (c@'\\':r) = '\\':c:es r + es (c:r) = c:es r data PGTypeHandler = PGType { pgTypeName :: String @@ -273,27 +295,46 @@ pgTypeEscaper PGType{ pgTypeType = t } = type PGTypeMap = Map.Map OID PGTypeHandler -defaultTypeMap :: PGTypeMap -defaultTypeMap = Map.fromAscList - [ (16, PGType "bool" (ConT ''Bool)) - , (17, PGType "bytea" (ConT ''L.ByteString)) - , (18, PGType "char" (ConT ''Char)) - -- , (19, PGType "name") - , (20, PGType "int8" (ConT ''Int64)) - , (21, PGType "int2" (ConT ''Int16)) - , (23, PGType "int4" (ConT ''Int32)) - , (25, PGType "text" (ConT ''String)) - , (26, PGType "oid" (ConT ''OID)) - , (700, PGType "float4" (ConT ''Float)) - , (701, PGType "float8" (ConT ''Double)) - , (1042, PGType "bpchar" (ConT ''String)) - , (1043, PGType "varchar" (ConT ''String)) - , (1082, PGType "date" (ConT ''Time.Day)) - , (1083, PGType "time" (ConT ''Time.TimeOfDay)) - , (1114, PGType "timestamp" (ConT ''Time.LocalTime)) - , (1184, PGType "timestamptz" (ConT ''Time.ZonedTime)) - , (1186, PGType "interval" (ConT ''Time.DiffTime)) - -- , (1560, PGType "bit") - -- , (1562, PGType "varbit") - , (1700, PGType "numeric" (ConT ''Rational)) +arrayType :: Type -> Type +arrayType = AppT ListT . AppT (ConT ''Maybe) + +pgArrayType :: String -> Type -> PGTypeHandler +pgArrayType n t = PGType ('_':n) (arrayType t) + +pgTypes :: [(OID, OID, String, Name)] +pgTypes = + [ ( 16, 1000, "bool", ''Bool) + , ( 17, 1001, "bytea", ''L.ByteString) + , ( 18, 1002, "char", ''Char) + , ( 19, 1003, "name", ''String) -- limit 63 characters + , ( 20, 1016, "int8", ''Int64) + , ( 21, 1005, "int2", ''Int16) + , ( 23, 1007, "int4", ''Int32) + , ( 25, 1009, "text", ''String) + , ( 26, 1028, "oid", ''OID) +--, ( 114, 199, "json", ?) +--, ( 142, 143, "xml", ?) +--, ( 600, 1017, "point", ?) +--, ( 650, 651, "cidr", ?) + , ( 700, 1021, "float4", ''Float) + , ( 701, 1022, "float8", ''Double) +--, ( 790, 791, "money", Centi? Fixed?) +--, ( 829, 1040, "macaddr", ?) +--, ( 869, 1041, "inet", ?) + , (1042, 1014, "bpchar", ''String) + , (1043, 1015, "varchar", ''String) + , (1082, 1182, "date", ''Time.Day) + , (1083, 1183, "time", ''Time.TimeOfDay) + , (1114, 1115, "timestamp", ''Time.LocalTime) + , (1184, 1185, "timestamptz", ''Time.ZonedTime) + , (1186, 1187, "interval", ''Time.DiffTime) +--, (1266, 1270, "timetz", ?) +--, (1560, 1561, "bit", Bool?) +--, (1562, 1563, "varbit", ?) + , (1700, 1231, "numeric", ''Rational) +--, (2950, 2951, "uuid", ?) ] + +defaultTypeMap :: PGTypeMap +defaultTypeMap = Map.fromAscList [(o, PGType n (ConT t)) | (o, _, n, t) <- pgTypes] + `Map.union` Map.fromList [(o, pgArrayType n (ConT t)) | (_, o, n, t) <- pgTypes] diff --git a/test/Main.hs b/test/Main.hs index 9f65235..d1076c1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -20,7 +20,8 @@ main = do let t = Time.zonedTimeToLocalTime z d = Time.localDay t p = -34881559 - Just (Just 1, Just True, Just 3.14, Just d', Just t', Just z', Just p') <- - $(queryTuple "SELECT {1}::int, {True}::bool, {3.14}::float4, {d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval") c - assert $ d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' + l = [Just "a\\\"b,c", Nothing] + Just (Just 1, Just True, Just 3.14, Just d', Just t', Just z', Just p', Just l') <- + $(queryTuple "SELECT {1}::int, {True}::bool, {3.14}::float4, {d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval, {l}::text[]") c + assert $ d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' && l == l' exitSuccess From 817905f5835df75df379c2ba6527cc1226936b44 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 27 Dec 2014 22:35:49 -0500 Subject: [PATCH 023/306] Some cleanups and sanity for protocol; Bind message --- Database/TemplatePG/Protocol.hs | 97 ++++++++++++++++----------------- Database/TemplatePG/SQL.hs | 8 +-- test/Main.hs | 1 + 3 files changed, 51 insertions(+), 55 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index a88a808..15c6cb4 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -33,6 +33,7 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U +import Data.Foldable (foldMap) import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Monoid @@ -66,10 +67,11 @@ data PGMessage = AuthenticationOk | AuthenticationCleartextPassword | AuthenticationMD5Password L.ByteString | BackendKeyData Word32 Word32 + | Bind String [Maybe L.ByteString] -- |CommandComplete is bare for now, although it could be made -- to contain the number of rows affected by statements in a -- later version. - | CommandComplete + | CommandComplete L.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 @@ -94,7 +96,7 @@ data PGMessage = AuthenticationOk | ParameterDescription [OID] | ParameterStatus L.ByteString L.ByteString -- |Parse SQL Destination (prepared statement) - | Parse String String + | Parse { parseName :: String, parseSQL :: String, parseTypes :: [OID] } | ParseComplete | PasswordMessage L.ByteString | ReadyForQuery @@ -209,7 +211,8 @@ pgMessageID m = c2w $ case m of AuthenticationCleartextPassword -> 'R' (AuthenticationMD5Password _) -> 'R' (BackendKeyData _ _) -> 'K' - CommandComplete -> 'C' + (Bind _ _) -> 'B' + (CommandComplete _) -> 'C' (DataRow _) -> 'D' (Describe _) -> 'D' EmptyQueryResponse -> 'I' @@ -220,7 +223,7 @@ pgMessageID m = c2w $ case m of (NoticeResponse _) -> 'N' (ParameterDescription _) -> 't' (ParameterStatus _ _) -> 'S' - (Parse _ _) -> 'P' + (Parse _ _ _) -> 'P' ParseComplete -> '1' (PasswordMessage _) -> 'p' ReadyForQuery -> 'Z' @@ -251,9 +254,16 @@ instance Binary PGMessage where -- send fewer messages than we receive. putMessageBody :: PGMessage -> B.Builder putMessageBody (Describe n) = B.singleton (c2w 'S') <> pgString n -putMessageBody Execute = pgString "" <> B.putWord32be 0 +putMessageBody Execute = B.singleton 0 <> B.putWord32be 0 putMessageBody Flush = B.empty -putMessageBody (Parse s n) = mconcat [pgString n, pgString s, B.putWord16be 0] +putMessageBody Parse{ parseName = n, parseSQL = s, parseTypes = t } = + pgString n <> pgString s <> + B.putWord16be (fromIntegral $ length t) <> foldMap B.putWord32be t +putMessageBody (Bind s p) = + B.singleton 0 <> pgString s <> B.putWord16be 0 <> + B.putWord16be (fromIntegral $ length p) <> foldMap (maybe (B.putWord32be 0xFFFFFFFF) val) p <> + B.putWord16be 0 + where val v = B.putWord32be (fromIntegral $ L.length v) <> B.fromLazyByteString v putMessageBody (SimpleQuery s) = pgString s putMessageBody (PasswordMessage s) = B.fromLazyByteString s <> B.singleton 0 putMessageBody _ = undefined @@ -296,7 +306,7 @@ getMessageBody typ = typ' <- G.getWord32be -- type _ <- G.getWord16be -- type size _ <- G.getWord32be -- type modifier - _ <- G.getWord16be -- format code + 0 <- G.getWord16be -- format code return $ ColDescription { colName = U.toString name , colTable = oid @@ -305,16 +315,14 @@ getMessageBody typ = } 'Z' -> G.getWord8 >> return ReadyForQuery '1' -> return ParseComplete - 'C' -> return CommandComplete + 'C' -> liftM CommandComplete G.getLazyByteStringNul 'S' -> liftM2 ParameterStatus G.getLazyByteStringNul G.getLazyByteStringNul - 'D' -> do numFields <- fromIntegral `liftM` G.getWord16be - ds <- replicateM numFields readField - return $ DataRow ds - where readField = do len <- fromIntegral `liftM` G.getWord32be - s <- case len of + 'D' -> do numFields <- G.getWord16be + DataRow <$> replicateM (fromIntegral numFields) readField + where readField = do len <- G.getWord32be + case len of 0xFFFFFFFF -> return Nothing - _ -> Just `liftM` G.getLazyByteString len - return s + _ -> Just `liftM` G.getLazyByteString (fromIntegral len) 'K' -> liftM2 BackendKeyData G.getWord32be G.getWord32be 'E' -> ErrorResponse `liftM` getMessageFields 'I' -> return EmptyQueryResponse @@ -344,18 +352,6 @@ pgReceive c@PGConnection{ pgHandle = h, pgDebug = d } = do (NoticeResponse m) -> hPutStrLn stderr (displayMessage m) >> pgReceive c _ -> return msg --- |Wait for a message of a given type. -pgWaitFor :: PGConnection - -> [Word8] -- ^ A list of message identifiers, the first of which - -- found while reading messages from PostgreSQL will be - -- returned. - -> IO PGMessage -pgWaitFor h ids = do - response <- pgReceive h - if pgMessageID response `elem` ids - then return response - else pgWaitFor h ids - getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c t = do r <- executeSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c @@ -382,16 +378,16 @@ describeStatement :: PGConnection -> String -- ^ SQL string -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. describeStatement h sql = do - pgSend h $ Parse sql "" + pgSend h $ Parse{ parseSQL = sql, parseName = "", parseTypes = [] } pgSend h $ Describe "" pgSend h $ Flush - _ <- pgWaitFor h [pgMessageID ParseComplete] + ParseComplete <- pgReceive h ParameterDescription ps <- pgReceive h m <- pgReceive h liftM2 (,) (mapM (getPGType h) ps) $ case m of NoData -> return [] RowDescription r -> mapM desc r - _ -> fail $ "unexpected describe response: " ++ show m + _ -> fail $ "describeStatement: unexpected response: " ++ show m where desc (ColDescription name tab col typ) = do t <- getPGType h typ @@ -412,7 +408,8 @@ describeStatement h sql = do "t" -> False "f" -> True _ -> error "Unexpected result from PostgreSQL" - _ -> error $ "Can't determine nullability of column #" ++ show col + [] -> return True + _ -> error $ "Can't determine nullability of column #" ++ show col -- |A simple query is one which requires sending only a single 'SimpleQuery' -- message to the PostgreSQL server. The query is sent as a single string; you @@ -420,23 +417,22 @@ describeStatement h sql = do -- list). executeSimpleQuery :: String -- ^ SQL string -> PGConnection - -> IO ([[Maybe L.ByteString]]) -- ^ A list of result rows, + -> IO [[Maybe L.ByteString]] -- ^ A list of result rows, -- which themselves are a list -- of fields. executeSimpleQuery sql h = do pgSend h $ SimpleQuery sql - m <- pgWaitFor h $ map c2w ['C', 'I', 'T'] - case m of - EmptyQueryResponse -> return [[]] - (RowDescription _) -> readDataRows - _ -> error "executeSimpleQuery: Unexpected Message" - where readDataRows = do - m <- pgWaitFor h $ map c2w ['C', 'D'] - case m of - CommandComplete -> return [] - (DataRow fs) -> do rs <- readDataRows - return (fs:rs) - _ -> error "" + go start where + go = (>>=) $ pgReceive h + start (CommandComplete _) = go end + start (RowDescription _) = go row + start m = fail $ "executeSimpleQuery: unexpected response: " ++ show m + row (CommandComplete _) = go end + row (DataRow fs) = (fs:) <$> go row + row m = fail $ "executeSimpleQuery: unexpected row: " ++ show m + end ReadyForQuery = return [] + end EmptyQueryResponse = go end + end m = fail $ "executeSimpleQuery: unexpected response: " ++ show m -- |While not strictly necessary, this can make code a little bit clearer. It -- executes a 'SimpleQuery' but doesn't look for results. @@ -445,8 +441,11 @@ executeSimpleStatement :: String -- ^ SQL string -> IO () executeSimpleStatement sql h = do pgSend h $ SimpleQuery sql - m <- pgWaitFor h $ map c2w ['C', 'I'] - case m of - CommandComplete -> return () - EmptyQueryResponse -> return () - _ -> error "executeSimpleStatement: Unexpected Message" + loop where + loop = msg =<< pgReceive h + msg ReadyForQuery = return () + msg (CommandComplete _) = loop + msg EmptyQueryResponse = loop + msg (RowDescription _) = loop + msg (DataRow _) = loop + msg m = fail $ "executeSimpleStatement: unexpected response: " ++ show m diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 38a75ab..00206f1 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -27,7 +27,7 @@ import Control.Applicative ((<$>), (<$)) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) import Control.Exception (onException, catchJust) import Control.Monad (zipWithM, liftM, (>=>), when) -import Data.Maybe (fromMaybe, fromJust) +import Data.Maybe (fromMaybe, fromJust, listToMaybe) import Language.Haskell.Meta.Parse (parseExp) import Language.Haskell.TH import Language.Haskell.TH.Syntax (returnQ) @@ -124,11 +124,7 @@ queryTuples sql = do -- => IO (Maybe (Maybe String, Maybe Integer)) -- @ queryTuple :: String -> Q Exp -queryTuple sql = [| liftM maybeHead . $(queryTuples sql) |] - -maybeHead :: [a] -> Maybe a -maybeHead [] = Nothing -maybeHead (x:_) = Just x +queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- |@execute :: String -> (PGConnection -> IO ())@ -- diff --git a/test/Main.hs b/test/Main.hs index d1076c1..38ba0aa 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -16,6 +16,7 @@ useTHConnection connect main :: IO () main = do c <- connect + _ <- $(queryTuples "SELECT oid, typname from pg_type") c z <- Time.getZonedTime let t = Time.zonedTimeToLocalTime z d = Time.localDay t From e5b39919ceb7c3da9df2b14dce7cfe7e7a6f38ca Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 11:31:55 -0500 Subject: [PATCH 024/306] Some reorganization, leaving SQL as a compatibility layer --- Database/TemplatePG.hs | 1 + Database/TemplatePG/Connection.hs | 57 +++++++++++ Database/TemplatePG/Protocol.hs | 161 ++++++++++++++++-------------- Database/TemplatePG/Query.hs | 120 ++++++++++++++++++++++ Database/TemplatePG/SQL.hs | 157 +++-------------------------- templatepg.cabal | 2 + 6 files changed, 276 insertions(+), 222 deletions(-) create mode 100644 Database/TemplatePG/Connection.hs create mode 100644 Database/TemplatePG/Query.hs diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 893d3da..cc5f3d4 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -34,6 +34,7 @@ module Database.TemplatePG (-- *Introduction , insertIgnore ) where import Database.TemplatePG.Protocol +import Database.TemplatePG.Connection import Database.TemplatePG.SQL -- $intro diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs new file mode 100644 index 0000000..3fd1224 --- /dev/null +++ b/Database/TemplatePG/Connection.hs @@ -0,0 +1,57 @@ +module Database.TemplatePG.Connection + ( withTHConnection + , useTHConnection + , handlePGType + ) where + +import Control.Applicative ((<$>), (<$)) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) +import Control.Monad (liftM, (>=>), when) +import Data.Maybe (fromMaybe) +import qualified Language.Haskell.TH as TH +import Network (PortID(UnixSocket, PortNumber), PortNumber) +import System.Environment (getEnv, lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +import Database.TemplatePG.Types +import Database.TemplatePG.Protocol + +-- |Grab a PostgreSQL connection for compile time. We do so through the +-- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and +-- @TPG_PASS@. Only TPG_DB is required. +thConnection :: MVar (Either (IO PGConnection) PGConnection) +thConnection = unsafePerformIO $ newMVar $ Left $ do + database <- getEnv "TPG_DB" + hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" + socket <- lookupEnv "TPG_SOCK" + portNum <- maybe (5432 :: PortNumber) (fromIntegral . read) <$> lookupEnv "TPG_PORT" + username <- fromMaybe "postgres" <$> lookupEnv "TPG_USER" + password <- fromMaybe "" <$> lookupEnv "TPG_PASS" + let portId = maybe (PortNumber $ fromIntegral portNum) UnixSocket socket + pgConnect hostName portId database username password + +-- |Run an action using the TemplatePG connection. +-- This is meant to be used from other TH code (though it will work during normal runtime if just want a simple PGConnection based on TPG environment variables). +withTHConnection :: (PGConnection -> IO a) -> IO a +withTHConnection f = modifyMVar thConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) + +setTHConnection :: Either (IO PGConnection) PGConnection -> IO () +setTHConnection c = modifyMVar_ thConnection $ either (const $ return c) ((c <$) . pgDisconnect) + +-- |Specify an alternative connection method to use during TemplatePG 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. +useTHConnection :: IO PGConnection -> TH.Q [TH.Dec] +useTHConnection c = [] <$ TH.runIO (setTHConnection (Left c)) + +modifyTHConnection :: (PGConnection -> PGConnection) -> IO () +modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . liftM f) (Right . f) + +-- |Register a new handler for PostgreSQL type and a Haskell type, which should be an instance of 'PGType'. +-- This should be called as a top-level declaration and produces no code. +handlePGType :: String -> TH.Type -> TH.Q [TH.Dec] +handlePGType name typ = [] <$ TH.runIO (do + (oid, loid) <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) + modifyTHConnection (pgAddType oid (PGType name typ)) + when (loid /= 0) $ + modifyTHConnection (pgAddType loid (pgArrayType name typ))) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 15c6cb4..ed2cd25 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -6,13 +6,13 @@ -- directly. module Database.TemplatePG.Protocol ( PGConnection + , PGData , PGException(..) , messageCode , pgConnect , pgDisconnect , describeStatement - , executeSimpleQuery - , executeSimpleStatement + , pgSimpleQuery , pgAddType , getTypeOID ) where @@ -20,8 +20,9 @@ module Database.TemplatePG.Protocol ( PGConnection import Database.TemplatePG.Types import Control.Applicative ((<$>)) +import Control.Arrow (second) import Control.Exception (Exception, throwIO) -import Control.Monad (liftM, liftM2, replicateM, when) +import Control.Monad (liftM, liftM2, replicateM, when, unless) #ifdef USE_MD5 import qualified Crypto.Hash as Hash #endif @@ -35,14 +36,13 @@ import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (foldMap) import qualified Data.Map as Map -import Data.Maybe (isJust) -import Data.Monoid +import Data.Maybe (isJust, fromMaybe) +import Data.Monoid ((<>), mconcat) import Data.Typeable (Typeable) import Network (HostName, PortID, connectTo) import System.Environment (lookupEnv) -import System.IO hiding (putStr, putStrLn) - -import Prelude hiding (putStr, putStrLn) +import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) +import Text.Read (readMaybe) data PGConnection = PGConnection { pgHandle :: Handle @@ -60,6 +60,9 @@ data ColDescription = ColDescription , colType :: !OID } deriving (Show) +-- |A list of (nullable) data values, e.g. a single row or query parameters. +type PGData = [Maybe L.ByteString] + -- |PGMessage represents a PostgreSQL protocol message that we'll either send -- or receive. See -- . @@ -67,7 +70,8 @@ data PGMessage = AuthenticationOk | AuthenticationCleartextPassword | AuthenticationMD5Password L.ByteString | BackendKeyData Word32 Word32 - | Bind String [Maybe L.ByteString] + | Bind { statementName :: String, bindParameters :: PGData } + | Close { statementName :: String } -- |CommandComplete is bare for now, although it could be made -- to contain the number of rows affected by statements in a -- later version. @@ -76,19 +80,19 @@ data PGMessage = AuthenticationOk -- (or just Nothing for null values, to distinguish them from -- emtpy strings). The ByteStrings can then be converted to -- the appropriate type by 'pgStringToType'. - | DataRow [Maybe L.ByteString] + | DataRow PGData -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). - | Describe String + | Describe { statementName :: String } | EmptyQueryResponse -- |An ErrorResponse contains the severity, "SQLSTATE", and -- message of an error. See -- . - | ErrorResponse MessageFields - | Execute + | ErrorResponse { messageFields :: MessageFields } + | Execute Word32 | Flush | NoData - | NoticeResponse MessageFields + | 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 @@ -96,9 +100,10 @@ data PGMessage = AuthenticationOk | ParameterDescription [OID] | ParameterStatus L.ByteString L.ByteString -- |Parse SQL Destination (prepared statement) - | Parse { parseName :: String, parseSQL :: String, parseTypes :: [OID] } + | Parse { statementName :: String, queryString :: String, parseTypes :: [OID] } | ParseComplete | PasswordMessage L.ByteString + | PortalSuspended | ReadyForQuery -- |A RowDescription contains the name, type, table OID, and -- column number of the resulting columns(s) of a query. The @@ -106,7 +111,9 @@ data PGMessage = AuthenticationOk | RowDescription [ColDescription] -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, -- etc.) aren't allowed. - | SimpleQuery String + | SimpleQuery { queryString :: String } + | Sync + | Terminate | UnknownMessage Word8 deriving (Show) @@ -192,7 +199,9 @@ pgConnect host port db user pass = do -- a close message. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () -pgDisconnect PGConnection{ pgHandle = h } = hClose h +pgDisconnect c@PGConnection{ pgHandle = h } = do + pgSend c Terminate + hClose h pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection pgAddType oid th p = p{ pgTypes = Map.insert oid th $ pgTypes p } @@ -212,12 +221,13 @@ pgMessageID m = c2w $ case m of (AuthenticationMD5Password _) -> 'R' (BackendKeyData _ _) -> 'K' (Bind _ _) -> 'B' + (Close _) -> 'C' (CommandComplete _) -> 'C' (DataRow _) -> 'D' (Describe _) -> 'D' EmptyQueryResponse -> 'I' (ErrorResponse _) -> 'E' - Execute -> 'E' + (Execute _) -> 'E' Flush -> 'H' NoData -> 'n' (NoticeResponse _) -> 'N' @@ -226,9 +236,12 @@ pgMessageID m = c2w $ case m of (Parse _ _ _) -> 'P' ParseComplete -> '1' (PasswordMessage _) -> 'p' + PortalSuspended -> 's' ReadyForQuery -> 'Z' (RowDescription _) -> 'T' (SimpleQuery _) -> 'Q' + Sync -> 'S' + Terminate -> 'X' (UnknownMessage _) -> error "Unknown message type" -- |All PostgreSQL messages have a common header: an identifying character and @@ -239,34 +252,31 @@ instance Binary PGMessage where put m = do let body = B.toLazyByteString $ putMessageBody m P.putWord8 $ pgMessageID m - P.putWord32be $ fromIntegral $ (L.length body) + 4 + P.putWord32be $ fromIntegral $ L.length body + 4 P.putLazyByteString body - -- |Getting a message takes care of reading the message type and message size - -- and ensures that just the necessary amount is read and given to - -- 'getMessageBody' (so that if a 'getMessageBody' parser doesn't read the - -- entire message it doesn't leave data to interfere with later messages). - get = do - (typ, len) <- getMessageHeader - body <- G.getLazyByteString ((fromIntegral len) - 4) - return $ G.runGet (getMessageBody typ) body + get = getMessageBody . fst =<< getMessageHeader -- |Given a message, build the over-the-wire representation of it. Note that we -- send fewer messages than we receive. putMessageBody :: PGMessage -> B.Builder -putMessageBody (Describe n) = B.singleton (c2w 'S') <> pgString n -putMessageBody Execute = B.singleton 0 <> B.putWord32be 0 -putMessageBody Flush = B.empty -putMessageBody Parse{ parseName = n, parseSQL = s, parseTypes = t } = +putMessageBody Describe{ statementName = n } = + B.singleton (c2w 'S') <> pgString n +putMessageBody Close{ statementName = n } = + B.singleton (c2w 'S') <> pgString n +putMessageBody (Execute r) = B.singleton 0 <> B.putWord32be r +putMessageBody Parse{ statementName = n, queryString = s, parseTypes = t } = pgString n <> pgString s <> B.putWord16be (fromIntegral $ length t) <> foldMap B.putWord32be t -putMessageBody (Bind s p) = - B.singleton 0 <> pgString s <> B.putWord16be 0 <> +putMessageBody Bind{ statementName = n, bindParameters = p } = + B.singleton 0 <> pgString n <> B.putWord16be 0 <> B.putWord16be (fromIntegral $ length p) <> foldMap (maybe (B.putWord32be 0xFFFFFFFF) val) p <> B.putWord16be 0 where val v = B.putWord32be (fromIntegral $ L.length v) <> B.fromLazyByteString v -putMessageBody (SimpleQuery s) = pgString s -putMessageBody (PasswordMessage s) = B.fromLazyByteString s <> B.singleton 0 -putMessageBody _ = undefined +putMessageBody SimpleQuery{ queryString = s } = + pgString s +putMessageBody (PasswordMessage s) = + B.fromLazyByteString s <> B.singleton 0 +putMessageBody _ = B.empty -- |Get the type and size of an incoming message. getMessageHeader :: Get (Word8, Int) @@ -327,34 +337,46 @@ getMessageBody typ = 'E' -> ErrorResponse `liftM` getMessageFields 'I' -> return EmptyQueryResponse 'n' -> return NoData + 's' -> return PortalSuspended 'N' -> NoticeResponse `liftM` getMessageFields _ -> return $ UnknownMessage typ -- |Send a message to PostgreSQL (low-level). pgSend :: PGConnection -> PGMessage -> IO () pgSend PGConnection{ pgHandle = h, pgDebug = d } msg = do - when d $ print msg + when d $ putStrLn $ "> " ++ show msg L.hPut h (encode msg) >> hFlush h +runGet :: Monad m => G.Get a -> L.ByteString -> m a +runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOrFail g s + -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. pgReceive :: PGConnection -> IO PGMessage pgReceive c@PGConnection{ pgHandle = h, pgDebug = d } = do - (typ, len) <- G.runGet getMessageHeader `liftM` L.hGet h 5 - body <- L.hGet h (len - 4) - when d $ do - L.putStr (P.runPut (P.putWord8 typ >> P.putWord32be (fromIntegral len))) - LC.putStrLn body - hFlush stdout - let msg = decode $ L.cons typ (L.append (B.toLazyByteString $ B.putWord32be $ fromIntegral len) body) + (typ, body) <- recv + msg <- runGet (getMessageBody typ) body + when d $ putStrLn $ "< " ++ show msg case msg of - (ErrorResponse m) -> throwIO (PGException m) - (NoticeResponse m) -> hPutStrLn stderr (displayMessage m) >> pgReceive c - _ -> return msg + ErrorResponse{ messageFields = m } -> do + pgSend c Sync >> wait + throwIO (PGException m) + where + wait = do + (t, _) <- recv + unless (t == pgMessageID ReadyForQuery) wait + NoticeResponse{ messageFields = m } -> + hPutStrLn stderr (displayMessage m) >> pgReceive c + _ -> return msg + where + recv = do + (typ, len) <- runGet getMessageHeader =<< L.hGet h 5 + body <- L.hGet h (len - 4) + return (typ, body) getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c t = do - r <- executeSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c + (_, r) <- pgSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c case r of [] -> return Nothing [[Just o, Just lo]] | Just to <- pgDecodeBS o, Just lto <- pgDecodeBS lo -> @@ -365,7 +387,7 @@ getPGType :: PGConnection -> OID -> IO PGTypeHandler getPGType c@PGConnection{ pgTypes = types } oid = maybe notype return $ Map.lookup oid types where notype = do - r <- executeSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) c + (_, r) <- pgSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) c case r of [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ U.toString s _ -> fail $ "Unknown PostgreSQL type: " ++ show oid @@ -378,7 +400,7 @@ describeStatement :: PGConnection -> String -- ^ SQL string -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. describeStatement h sql = do - pgSend h $ Parse{ parseSQL = sql, parseName = "", parseTypes = [] } + pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = [] } pgSend h $ Describe "" pgSend h $ Flush ParseComplete <- pgReceive h @@ -402,50 +424,35 @@ describeStatement h sql = do then return True -- In cases where the resulting field is tracable to the column of a -- table, we can check there. - else do r <- executeSimpleQuery ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) h + else do (_, r) <- pgSimpleQuery ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) h case r of [[Just s]] -> return $ case U.toString s of "t" -> False "f" -> True _ -> error "Unexpected result from PostgreSQL" [] -> return True - _ -> error $ "Can't determine nullability of column #" ++ show col + _ -> fail $ "Can't determine nullability of column #" ++ show col -- |A simple query is one which requires sending only a single 'SimpleQuery' -- message to the PostgreSQL server. The query is sent as a single string; you -- cannot bind parameters. Note that queries can return 0 results (an empty -- list). -executeSimpleQuery :: String -- ^ SQL string +pgSimpleQuery :: String -- ^ SQL string -> PGConnection - -> IO [[Maybe L.ByteString]] -- ^ A list of result rows, - -- which themselves are a list - -- of fields. -executeSimpleQuery sql h = do + -> IO (Int, [PGData]) -- ^ The number of rows affected and a list of result rows +pgSimpleQuery sql h = do pgSend h $ SimpleQuery sql go start where go = (>>=) $ pgReceive h - start (CommandComplete _) = go end + start (CommandComplete c) = got c start (RowDescription _) = go row start m = fail $ "executeSimpleQuery: unexpected response: " ++ show m - row (CommandComplete _) = go end - row (DataRow fs) = (fs:) <$> go row + row (CommandComplete c) = got c + row (DataRow fs) = second (fs:) <$> go row row m = fail $ "executeSimpleQuery: unexpected row: " ++ show m + got c = (,) (rowsAffected $ LC.words c) <$> go end + rowsAffected [] = -1 + rowsAffected l = fromMaybe (-1) $ readMaybe $ LC.unpack $ last l end ReadyForQuery = return [] end EmptyQueryResponse = go end - end m = fail $ "executeSimpleQuery: unexpected response: " ++ show m - --- |While not strictly necessary, this can make code a little bit clearer. It --- executes a 'SimpleQuery' but doesn't look for results. -executeSimpleStatement :: String -- ^ SQL string - -> PGConnection - -> IO () -executeSimpleStatement sql h = do - pgSend h $ SimpleQuery sql - loop where - loop = msg =<< pgReceive h - msg ReadyForQuery = return () - msg (CommandComplete _) = loop - msg EmptyQueryResponse = loop - msg (RowDescription _) = loop - msg (DataRow _) = loop - msg m = fail $ "executeSimpleStatement: unexpected response: " ++ show m + end m = fail $ "executeSimpleQuery: unexpected message: " ++ show m diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs new file mode 100644 index 0000000..3703d13 --- /dev/null +++ b/Database/TemplatePG/Query.hs @@ -0,0 +1,120 @@ +module Database.TemplatePG.Query + ( PGQuery + , pgExecute + , pgQuery + , makePGQuery + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (zipWithM, liftM) +import Data.Maybe (fromJust) +import Language.Haskell.Meta.Parse (parseExp) +import qualified Language.Haskell.TH as TH +import qualified Text.ParserCombinators.Parsec as P + +import Database.TemplatePG.Types +import Database.TemplatePG.Protocol +import Database.TemplatePG.Connection + +-- |A query returning rows of the given type. +data PGQuery a = PGSimpleQuery + { pgQueryString :: String + , pgQueryParser :: PGData -> a + } + +instance Functor PGQuery where + fmap f q = q{ pgQueryParser = f . pgQueryParser q } + +-- |Run a query and return a list of row results. +pgQuery :: PGConnection -> PGQuery a -> IO [a] +pgQuery c PGSimpleQuery{ pgQueryString = s, pgQueryParser = p } = + map p . snd <$> pgSimpleQuery s c + +-- |Execute a query that does not return result. +-- Return the number of rows affected (or -1 if not known). +pgExecute :: PGConnection -> PGQuery () -> IO Int +pgExecute c PGSimpleQuery{ pgQueryString = s } = + fst <$> pgSimpleQuery s c + +-- |Produce a new PGQuery from a SQL query string. +-- This should be used as @$(makePGQuery \"SELECT ...\")@ +makePGQuery :: String -- ^ a SQL query string + -> TH.Q TH.Exp -- ^ a PGQuery +makePGQuery sql = do + (pTypes, fTypes) <- TH.runIO $ withTHConnection $ \c -> + describeStatement c (holdPlaces sqlStrings expStrings) + s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings + [| PGSimpleQuery $(return s) $(convertRow fTypes) |] + where + holdPlaces ss es = concat $ weave ss (take (length es) placeholders) + placeholders = map (('$' :) . show) ([1..]::[Int]) + stringify t s = [| $(pgTypeEscaper t) $(parseExp' s) |] + parseExp' e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e + (sqlStrings, expStrings) = parseSql sql + +-- |"weave" 2 lists of equal length into a single list. +weave :: [a] -> [a] -> [a] +weave x [] = x +weave [] y = y +weave (x:xs) (y:ys) = x:y:(weave xs ys) + +-- |"weave" a list of SQL fragements an Haskell expressions into a single SQL string. +weaveString :: [String] -- ^ SQL fragments + -> [TH.Exp] -- ^ Haskell expressions + -> TH.Q TH.Exp +weaveString [] [] = [| "" |] +weaveString [x] [] = [| x |] +weaveString [] [y] = return y +weaveString (x:xs) (y:ys) = [| x ++ $(return y) ++ $(weaveString xs ys) |] +weaveString _ _ = error "Weave mismatch (possible parse problem)" + +-- |Given a result description, create a function to convert a result to a +-- tuple. +convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description + -> TH.Q TH.Exp -- ^ A function for converting a row of the given result description +convertRow types = do + n <- TH.newName "result" + TH.lamE [TH.varP n] $ TH.tupE $ map (convertColumn n) $ zip types [0..] + +-- |Given a raw PostgreSQL result and a result field type, convert the +-- appropriate field to a Haskell value. +convertColumn :: TH.Name -- ^ the name of the variable containing the result list (of 'Maybe' 'ByteString') + -> ((String, PGTypeHandler, Bool), Int) -- ^ the result field type and index + -> TH.Q TH.Exp +convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) ($(TH.varE name) !! i) |] + +-- SQL Parser -- + +every2nd :: [a] -> ([a], [a]) +every2nd = foldr (\a ~(x,y) -> (a:y,x)) ([],[]) + +-- |Given a SQL string return a list of SQL parts and expression parts. +-- For example: @\"SELECT * FROM table WHERE id = {someID} AND age > {baseAge * 1.5}\"@ +-- becomes: @(["SELECT * FROM table WHERE id = ", " AND age > "], +-- ["someID", "baseAge * 1.5"])@ +parseSql :: String -> ([String], [String]) +parseSql sql = case (P.parse sqlStatement "" sql) of + Left err -> error (show err) + Right ss -> every2nd ss + +-- |Like 'pgStringToType', but deal with possible @NULL@s. If the boolean +-- argument is 'False', that means that we know that the value is not nullable +-- and we can use 'fromJust' to keep the code simple. If it's 'True', then we +-- don't know if the value is nullable and must return a 'Maybe' value in case +-- it is. +pgStringToType' :: PGTypeHandler + -> Bool -- ^ nullability indicator + -> TH.Q TH.Exp +pgStringToType' t False = [| $(pgTypeDecoder t) . fromJust |] +pgStringToType' t True = [| liftM $(pgTypeDecoder t) |] + +sqlStatement :: P.Parser [String] +sqlStatement = P.many1 $ P.choice [sqlText, sqlParameter] + +sqlText :: P.Parser String +sqlText = P.many1 (P.noneOf "{") + +-- |Parameters are enclosed in @{}@ and can be any Haskell expression supported +-- by haskell-src-meta. +sqlParameter :: P.Parser String +sqlParameter = P.between (P.char '{') (P.char '}') $ P.many1 (P.noneOf "}") diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 00206f1..949e1f8 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -9,91 +9,22 @@ -- Note that transactions are messy and untested. Attempt to use them at your -- own risk. -module Database.TemplatePG.SQL ( queryTuples +module Database.TemplatePG.SQL ( makePGQuery + , queryTuples , queryTuple , execute , insertIgnore , withTransaction , rollback - , withTHConnection - , useTHConnection - , handlePGType ) where -import Database.TemplatePG.Protocol -import Database.TemplatePG.Types - -import Control.Applicative ((<$>), (<$)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) import Control.Exception (onException, catchJust) -import Control.Monad (zipWithM, liftM, (>=>), when) -import Data.Maybe (fromMaybe, fromJust, listToMaybe) -import Language.Haskell.Meta.Parse (parseExp) +import Control.Monad (liftM, void) +import Data.Maybe (listToMaybe) import Language.Haskell.TH -import Language.Haskell.TH.Syntax (returnQ) -import Network (PortID(UnixSocket, PortNumber), PortNumber) -import System.Environment (getEnv, lookupEnv) -import System.IO.Unsafe (unsafePerformIO) -import qualified Text.ParserCombinators.Parsec as P - --- |Grab a PostgreSQL connection for compile time. We do so through the --- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and --- @TPG_PASS@. Only TPG_DB is required. -thConnection :: MVar (Either (IO PGConnection) PGConnection) -thConnection = unsafePerformIO $ newMVar $ Left $ do - database <- getEnv "TPG_DB" - hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" - socket <- lookupEnv "TPG_SOCK" - portNum <- maybe (5432 :: PortNumber) (fromIntegral . read) <$> lookupEnv "TPG_PORT" - username <- fromMaybe "postgres" <$> lookupEnv "TPG_USER" - password <- fromMaybe "" <$> lookupEnv "TPG_PASS" - let portId = maybe (PortNumber $ fromIntegral portNum) UnixSocket socket - pgConnect hostName portId database username password - -withTHConnection :: (PGConnection -> IO a) -> IO a -withTHConnection f = modifyMVar thConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) - -setTHConnection :: Either (IO PGConnection) PGConnection -> IO () -setTHConnection c = modifyMVar_ thConnection $ either (const $ return c) ((c <$) . pgDisconnect) -useTHConnection :: IO PGConnection -> Q [Dec] -useTHConnection c = [] <$ runIO (setTHConnection (Left c)) - -modifyTHConnection :: (PGConnection -> PGConnection) -> IO () -modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . liftM f) (Right . f) - --- |This is where most of the magic happens. --- This doesn't result in a PostgreSQL prepared statement, it just creates one --- to do type inference. --- This returns a prepared SQL string with all values (as an expression) -prepareSQL :: String -- ^ a SQL string, with - -> Q (Exp, [(String, PGTypeHandler, Bool)]) -- ^ a prepared SQL string and result descriptions -prepareSQL sql = do - (pTypes, fTypes) <- runIO $ withTHConnection $ \c -> - describeStatement c (holdPlaces sqlStrings expStrings) - s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings - return (s, fTypes) - where holdPlaces ss es = concat $ weave ss (take (length es) placeholders) - placeholders = map (('$' :) . show) ([1..]::[Integer]) - stringify t s = [| $(pgTypeEscaper t) $(parseExp' s) |] - parseExp' e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) returnQ $ parseExp e - (sqlStrings, expStrings) = parseSql sql - --- |"weave" 2 lists of equal length into a single list. -weave :: [a] -> [a] -> [a] -weave x [] = x -weave [] y = y -weave (x:xs) (y:ys) = x:y:(weave xs ys) - --- |"weave" a list of SQL fragements an Haskell expressions into a single SQL string. -weaveString :: [String] -- ^ SQL fragments - -> [Exp] -- ^ Haskell expressions - -> Q Exp -weaveString [] [] = [| "" |] -weaveString [x] [] = [| x |] -weaveString [] [y] = return y -weaveString (x:xs) (y:ys) = [| x ++ $(return y) ++ $(weaveString xs ys) |] -weaveString _ _ = error "Weave mismatch (possible parse problem)" +import Database.TemplatePG.Protocol +import Database.TemplatePG.Query -- |@queryTuples :: String -> (PGConnection -> IO [(column1, column2, ...)])@ -- @@ -106,9 +37,7 @@ weaveString _ _ = error "Weave mismatch (possible parse problem)" -- => IO [(Maybe String, Maybe Integer)] -- @ queryTuples :: String -> Q Exp -queryTuples sql = do - (sql', types) <- prepareSQL sql - [| liftM (map $(convertRow types)) . executeSimpleQuery $(returnQ sql') |] +queryTuples sql = [| \c -> pgQuery c $(makePGQuery sql) |] -- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ -- @@ -137,11 +66,7 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- $(execute \"CREATE ROLE {rolename}\") h -- @ execute :: String -> Q Exp -execute sql = do - (sql', types) <- prepareSQL sql - case types of - [] -> [| executeSimpleStatement $(returnQ sql') |] - _ -> error "Execute can't be used on queries, only statements." +execute sql = [| \c -> pgExecute c $(makePGQuery sql) |] -- |Run a sequence of IO actions (presumably SQL statements) wrapped in a -- transaction. Unfortunately you're restricted to using this in the 'IO' @@ -149,15 +74,15 @@ execute sql = do -- 'MonadPeelIO' version. withTransaction :: PGConnection -> IO a -> IO a withTransaction h a = - onException (do executeSimpleStatement "BEGIN" h + onException (do void $ pgSimpleQuery "BEGIN" h c <- a - executeSimpleStatement "COMMIT" h + void $ pgSimpleQuery "COMMIT" h return c) - (executeSimpleStatement "ROLLBACK" h) + (void $ pgSimpleQuery "ROLLBACK" h) -- |Roll back a transaction. rollback :: PGConnection -> IO () -rollback = executeSimpleStatement "ROLLBACK" +rollback = void . pgSimpleQuery "ROLLBACK" -- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. insertIgnore :: IO () -> IO () @@ -166,61 +91,3 @@ insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) PGException m -> case messageCode m of "23505" -> Just () _ -> Nothing - --- |Given a result description, create a function to convert a result to a --- tuple. -convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description - -> Q Exp -- ^ A function for converting a row of the given result description -convertRow types = do - n <- newName "result" - lamE [varP n] $ tupE $ map (convertColumn n) $ zip types [0..] - --- |Given a raw PostgreSQL result and a result field type, convert the --- appropriate field to a Haskell value. -convertColumn :: Name -- ^ the name of the variable containing the result list (of 'Maybe' 'ByteString') - -> ((String, PGTypeHandler, Bool), Int) -- ^ the result field type and index - -> Q Exp -convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) ($(varE name) !! i) |] - --- |Like 'pgStringToType', but deal with possible @NULL@s. If the boolean --- argument is 'False', that means that we know that the value is not nullable --- and we can use 'fromJust' to keep the code simple. If it's 'True', then we --- don't know if the value is nullable and must return a 'Maybe' value in case --- it is. -pgStringToType' :: PGTypeHandler - -> Bool -- ^ nullability indicator - -> Q Exp -pgStringToType' t False = [| $(pgTypeDecoder t) . fromJust |] -pgStringToType' t True = [| liftM $(pgTypeDecoder t) |] - --- SQL Parser -- - --- |Given a SQL string return a list of SQL parts and expression parts. --- For example: @\"SELECT * FROM table WHERE id = {someID} AND age > {baseAge * 1.5}\"@ --- becomes: @(["SELECT * FROM table WHERE id = ", " AND age > "], --- ["someID", "baseAge * 1.5"])@ -parseSql :: String -> ([String], [String]) -parseSql sql = case (P.parse sqlStatement "" sql) of - Left err -> error (show err) - Right ss -> every2nd ss - -every2nd :: [a] -> ([a], [a]) -every2nd = foldr (\a ~(x,y) -> (a:y,x)) ([],[]) - -sqlStatement :: P.Parser [String] -sqlStatement = P.many1 $ P.choice [sqlText, sqlParameter] - -sqlText :: P.Parser String -sqlText = P.many1 (P.noneOf "{") - --- |Parameters are enclosed in @{}@ and can be any Haskell expression supported --- by haskell-src-meta. -sqlParameter :: P.Parser String -sqlParameter = P.between (P.char '{') (P.char '}') $ P.many1 (P.noneOf "}") - -handlePGType :: String -> Type -> Q [Dec] -handlePGType name typ = [] <$ runIO (do - (oid, loid) <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) - modifyTHConnection (pgAddType oid (PGType name typ)) - when (loid /= 0) $ - modifyTHConnection (pgAddType loid (pgArrayType name typ))) diff --git a/templatepg.cabal b/templatepg.cabal index d6eb8ed..21b6a24 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -48,7 +48,9 @@ Library utf8-string Exposed-Modules: Database.TemplatePG + Database.TemplatePG.Connection Database.TemplatePG.Protocol + Database.TemplatePG.Query Database.TemplatePG.SQL Database.TemplatePG.Types Extensions: TemplateHaskell From 7552721ee9b85bb1e7ebc00f6f5a0696c50abe67 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 13:50:25 -0500 Subject: [PATCH 025/306] Improve connection state handling; send Sync as necessary --- Database/TemplatePG/Protocol.hs | 159 +++++++++++++++++++------------- 1 file changed, 94 insertions(+), 65 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index ed2cd25..34e6e42 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -19,10 +19,10 @@ module Database.TemplatePG.Protocol ( PGConnection import Database.TemplatePG.Types -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<$)) import Control.Arrow (second) -import Control.Exception (Exception, throwIO) -import Control.Monad (liftM, liftM2, replicateM, when, unless) +import Control.Exception (Exception, throwIO, catch) +import Control.Monad (liftM, liftM2, replicateM, when) #ifdef USE_MD5 import qualified Crypto.Hash as Hash #endif @@ -35,6 +35,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (foldMap) +import Data.IORef (IORef, newIORef, writeIORef, readIORef) import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) import Data.Monoid ((<>), mconcat) @@ -44,13 +45,22 @@ import System.Environment (lookupEnv) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) import Text.Read (readMaybe) +data PGState + = StateUnknown + | StateIdle + | StateTransaction + | StateTransactionFailed + deriving (Show, Eq) + data PGConnection = PGConnection - { pgHandle :: Handle - , pgDebug :: !Bool - , pgPid :: !Word32 - , pgKey :: !Word32 - , pgParameters :: Map.Map L.ByteString L.ByteString - , pgTypes :: PGTypeMap + { connHandle :: Handle + , connDebug :: !Bool + , connLogMessage :: MessageFields -> IO () + , connPid :: !Word32 + , connKey :: !Word32 + , connParameters :: Map.Map L.ByteString L.ByteString + , connTypes :: PGTypeMap + , connState :: IORef PGState } data ColDescription = ColDescription @@ -104,7 +114,7 @@ data PGMessage = AuthenticationOk | ParseComplete | PasswordMessage L.ByteString | PortalSuspended - | ReadyForQuery + | 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. @@ -141,6 +151,9 @@ instance Show PGException where instance Exception PGException +defaultLogMessage :: MessageFields -> IO () +defaultLogMessage = hPutStrLn stderr . displayMessage + protocolVersion :: Word32 protocolVersion = 0x30000 @@ -158,53 +171,60 @@ pgConnect :: HostName -- ^ the host to connect to -> IO PGConnection -- ^ a handle to communicate with the PostgreSQL server on pgConnect host port db user pass = do debug <- isJust <$> lookupEnv "TPG_DEBUG" + state <- newIORef StateUnknown h <- connectTo host port - L.hPut h $ B.toLazyByteString $ pgMessage handshake + L.hPut h $ B.toLazyByteString $ B.putWord32be $ fromIntegral $ 4 + L.length handshake + L.hPut h handshake hFlush h - conn (PGConnection h debug 0 0 Map.empty defaultTypeMap) - -- These are here since the handshake message differs a bit from other - -- messages (it's missing the inital identifying character). I could probably - -- get rid of it with some refactoring. - where handshake = mconcat - [ B.putWord32be protocolVersion - , pgString "user", pgString user - , pgString "database", pgString db - , pgString "client_encoding", pgString "UTF8" - , pgString "standard_conforming_strings", pgString "on" - , pgString "bytea_output", pgString "hex" - , pgString "DateStyle", pgString "ISO, YMD" - , pgString "IntervalStyle", pgString "iso_8601" - , B.singleton 0 ] - pgMessage :: B.Builder -> B.Builder - pgMessage msg = B.append len msg - where len = B.putWord32be $ fromIntegral $ (L.length $ B.toLazyByteString msg) + 4 - conn c = do - m <- pgReceive c - case m of - ReadyForQuery -> return c - BackendKeyData p k -> conn c{ pgPid = p, pgKey = k } - ParameterStatus k v -> conn c{ pgParameters = Map.insert k v $ pgParameters c } - AuthenticationOk -> conn c - AuthenticationCleartextPassword -> do - pgSend c $ PasswordMessage $ U.fromString pass - conn c + conn $ PGConnection + { connHandle = h + , connDebug = debug + , connLogMessage = defaultLogMessage + , connPid = 0 + , connKey = 0 + , connParameters = Map.empty + , connTypes = defaultTypeMap + , connState = state + } + where + -- These are here since the handshake message differs a bit from other + -- messages (it's missing the inital identifying character). I could probably + -- get rid of it with some refactoring. + handshake = B.toLazyByteString $ mconcat + [ B.putWord32be protocolVersion + , pgString "user", pgString user + , pgString "database", pgString db + , pgString "client_encoding", pgString "UTF8" + , pgString "standard_conforming_strings", pgString "on" + , pgString "bytea_output", pgString "hex" + , pgString "DateStyle", pgString "ISO, YMD" + , pgString "IntervalStyle", pgString "iso_8601" + , B.singleton 0 ] + conn c = msg c =<< pgReceive c + msg c (ReadyForQuery _) = return c + 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 $ U.fromString pass + conn c #ifdef USE_MD5 - AuthenticationMD5Password salt -> do - pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pass ++ user)) `L.append` salt) - conn c + msg c (AuthenticationMD5Password salt) = do + pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pass ++ user)) `L.append` salt) + conn c #endif - _ -> throwIO $ PGException $ errorMessage $ "unexpected: " ++ show m + msg _ m = throwIO $ PGException $ errorMessage $ "unexpected: " ++ show m -- |Disconnect from a PostgreSQL server. Note that this currently doesn't send -- a close message. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () -pgDisconnect c@PGConnection{ pgHandle = h } = do +pgDisconnect c@PGConnection{ connHandle = h } = do pgSend c Terminate hClose h pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection -pgAddType oid th p = p{ pgTypes = Map.insert oid th $ pgTypes p } +pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } -- |Convert a string to a NULL-terminated UTF-8 string. The PostgreSQL -- protocol transmits most strings in this format. @@ -237,7 +257,7 @@ pgMessageID m = c2w $ case m of ParseComplete -> '1' (PasswordMessage _) -> 'p' PortalSuspended -> 's' - ReadyForQuery -> 'Z' + (ReadyForQuery _) -> 'Z' (RowDescription _) -> 'T' (SimpleQuery _) -> 'Q' Sync -> 'S' @@ -291,6 +311,13 @@ getMessageFields = g =<< G.getWord8 where g 0 = return Map.empty g f = liftM2 (Map.insert f) G.getLazyByteStringNul getMessageFields +getReadyState :: Get PGState +getReadyState = rs . w2c =<< G.getWord8 where + rs 'I' = return StateIdle + rs 'T' = return StateTransaction + rs 'E' = return StateTransactionFailed + rs s = fail $ "Unknown ready state: " ++ show s + -- |Parse an incoming message. getMessageBody :: Word8 -- ^ the type of the message to parse -> Get PGMessage @@ -323,7 +350,7 @@ getMessageBody typ = , colNumber = fromIntegral col , colType = typ' } - 'Z' -> G.getWord8 >> return ReadyForQuery + 'Z' -> liftM ReadyForQuery getReadyState '1' -> return ParseComplete 'C' -> liftM CommandComplete G.getLazyByteStringNul 'S' -> liftM2 ParameterStatus G.getLazyByteStringNul G.getLazyByteStringNul @@ -343,7 +370,8 @@ getMessageBody typ = -- |Send a message to PostgreSQL (low-level). pgSend :: PGConnection -> PGMessage -> IO () -pgSend PGConnection{ pgHandle = h, pgDebug = d } msg = do +pgSend PGConnection{ connHandle = h, connDebug = d, connState = sr } msg = do + writeIORef sr StateUnknown when d $ putStrLn $ "> " ++ show msg L.hPut h (encode msg) >> hFlush h @@ -353,27 +381,26 @@ runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOr -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. pgReceive :: PGConnection -> IO PGMessage -pgReceive c@PGConnection{ pgHandle = h, pgDebug = d } = do - (typ, body) <- recv - msg <- runGet (getMessageBody typ) body +pgReceive c@PGConnection{ connHandle = h, connDebug = d } = do + (typ, len) <- runGet getMessageHeader =<< L.hGet h 5 + msg <- runGet (getMessageBody typ) =<< L.hGet h (len - 4) when d $ putStrLn $ "< " ++ show msg case msg of - ErrorResponse{ messageFields = m } -> do - pgSend c Sync >> wait - throwIO (PGException m) - where - wait = do - (t, _) <- recv - unless (t == pgMessageID ReadyForQuery) wait + ReadyForQuery s -> msg <$ writeIORef (connState c) s NoticeResponse{ messageFields = m } -> - hPutStrLn stderr (displayMessage m) >> pgReceive c + connLogMessage c m >> pgReceive c + ErrorResponse{ messageFields = m } -> + writeIORef (connState c) StateUnknown >> throwIO (PGException m) _ -> return msg - where - recv = do - (typ, len) <- runGet getMessageHeader =<< L.hGet h 5 - body <- L.hGet h (len - 4) - return (typ, body) +pgSync :: PGConnection -> IO () +pgSync c@PGConnection{ connState = sr } = do + s <- readIORef sr + when (s == StateUnknown) $ do + pgSend c Sync + _ <- pgReceive c `catch` \(PGException m) -> ErrorResponse m <$ connLogMessage c m + pgSync c + getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c t = do (_, r) <- pgSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c @@ -384,7 +411,7 @@ getTypeOID c t = do _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r getPGType :: PGConnection -> OID -> IO PGTypeHandler -getPGType c@PGConnection{ pgTypes = types } oid = +getPGType c@PGConnection{ connTypes = types } oid = maybe notype return $ Map.lookup oid types where notype = do (_, r) <- pgSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) c @@ -400,6 +427,7 @@ describeStatement :: PGConnection -> String -- ^ SQL string -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. describeStatement h sql = do + pgSync h pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = [] } pgSend h $ Describe "" pgSend h $ Flush @@ -441,6 +469,7 @@ pgSimpleQuery :: String -- ^ SQL string -> PGConnection -> IO (Int, [PGData]) -- ^ The number of rows affected and a list of result rows pgSimpleQuery sql h = do + pgSync h pgSend h $ SimpleQuery sql go start where go = (>>=) $ pgReceive h @@ -453,6 +482,6 @@ pgSimpleQuery sql h = do got c = (,) (rowsAffected $ LC.words c) <$> go end rowsAffected [] = -1 rowsAffected l = fromMaybe (-1) $ readMaybe $ LC.unpack $ last l - end ReadyForQuery = return [] + end (ReadyForQuery _) = return [] end EmptyQueryResponse = go end end m = fail $ "executeSimpleQuery: unexpected message: " ++ show m From d073f28e4cd207e91fc83af2d43e45fadd25bcb9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 16:46:31 -0500 Subject: [PATCH 026/306] Refactor protocol into separate frontend/backend messages Also switch to more efficient and flexible Data.ByteString.Builder --- Database/TemplatePG.hs | 2 +- Database/TemplatePG/Protocol.hs | 507 +++++++++++++++----------------- Database/TemplatePG/SQL.hs | 9 +- templatepg.cabal | 2 +- 4 files changed, 239 insertions(+), 281 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index cc5f3d4..b626f5f 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -21,7 +21,7 @@ module Database.TemplatePG (-- *Introduction -- **Other Workarounds -- $other - PGException(..) + PGError(..) , pgConnect , pgDisconnect , useTHConnection diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 34e6e42..66310cd 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -7,7 +7,7 @@ module Database.TemplatePG.Protocol ( PGConnection , PGData - , PGException(..) + , PGError(..) , messageCode , pgConnect , pgDisconnect @@ -22,14 +22,12 @@ import Database.TemplatePG.Types import Control.Applicative ((<$>), (<$)) import Control.Arrow (second) import Control.Exception (Exception, throwIO, catch) -import Control.Monad (liftM, liftM2, replicateM, when) +import Control.Monad (liftM2, replicateM, when) #ifdef USE_MD5 import qualified Crypto.Hash as Hash #endif -import Data.Binary -import qualified Data.Binary.Builder as B import qualified Data.Binary.Get as G -import qualified Data.Binary.Put as P +import qualified Data.ByteString.Builder as B import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC @@ -38,8 +36,9 @@ import Data.Foldable (foldMap) import Data.IORef (IORef, newIORef, writeIORef, readIORef) import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) -import Data.Monoid ((<>), mconcat) +import Data.Monoid (mempty, (<>)) import Data.Typeable (Typeable) +import Data.Word (Word8, Word32) import Network (HostName, PortID, connectTo) import System.Environment (lookupEnv) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) @@ -58,7 +57,7 @@ data PGConnection = PGConnection , connLogMessage :: MessageFields -> IO () , connPid :: !Word32 , connKey :: !Word32 - , connParameters :: Map.Map L.ByteString L.ByteString + , connParameters :: Map.Map String String , connTypes :: PGTypeMap , connState :: IORef PGState } @@ -73,65 +72,82 @@ data ColDescription = ColDescription -- |A list of (nullable) data values, e.g. a single row or query parameters. type PGData = [Maybe L.ByteString] --- |PGMessage represents a PostgreSQL protocol message that we'll either send --- or receive. See --- . -data PGMessage = AuthenticationOk - | AuthenticationCleartextPassword - | AuthenticationMD5Password L.ByteString - | BackendKeyData Word32 Word32 - | Bind { statementName :: String, bindParameters :: PGData } - | Close { statementName :: String } - -- |CommandComplete is bare for now, although it could be made - -- to contain the number of rows affected by statements in a - -- later version. - | CommandComplete L.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 PGData - -- |Describe a SQL query/statement. The SQL string can contain - -- parameters ($1, $2, etc.). - | Describe { statementName :: String } - | EmptyQueryResponse - -- |An ErrorResponse contains the severity, "SQLSTATE", and - -- message of an error. See - -- . - | ErrorResponse { messageFields :: MessageFields } - | Execute Word32 - | Flush - | 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 L.ByteString L.ByteString - -- |Parse SQL Destination (prepared statement) - | Parse { statementName :: String, queryString :: String, parseTypes :: [OID] } - | ParseComplete - | PasswordMessage L.ByteString - | 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] - -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, - -- etc.) aren't allowed. - | SimpleQuery { queryString :: String } - | Sync - | Terminate - | UnknownMessage Word8 +type MessageFields = Map.Map Word8 L.ByteString + +-- |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 :: PGData } + | 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 L.ByteString + -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, + -- etc.) aren't allowed. + | SimpleQuery { queryString :: String } + | Sync + | Terminate deriving (Show) -type MessageFields = Map.Map Word8 L.ByteString +-- |PGBackendMessage represents a PostgreSQL protocol message that we'll receive. +-- See . +data PGBackendMessage + = AuthenticationOk + | AuthenticationCleartextPassword + | AuthenticationMD5Password L.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 L.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 PGData + | 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 -errorMessage :: String -> MessageFields -errorMessage = Map.singleton (c2w 'M') . U.fromString +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 = maybe "" U.toString $ Map.lookup (c2w c) m @@ -141,27 +157,139 @@ displayMessage m = "PG" ++ f 'S' ++ " [" ++ f 'C' ++ "]: " ++ f 'M' ++ '\n' : f messageCode :: MessageFields -> String messageCode = maybe "" LC.unpack . Map.lookup (c2w 'C') --- |PGException is thrown upon encountering an 'ErrorResponse' with severity of --- ERROR, FATAL, or PANIC. It holds the message of the error. -data PGException = PGException MessageFields - deriving (Typeable) - -instance Show PGException where - show (PGException m) = displayMessage m - -instance Exception PGException - defaultLogMessage :: MessageFields -> IO () defaultLogMessage = hPutStrLn stderr . displayMessage -protocolVersion :: Word32 -protocolVersion = 0x30000 - #ifdef USE_MD5 md5 :: L.ByteString -> L.ByteString md5 = L.fromStrict . Hash.digestToHexByteString . (Hash.hashlazy :: L.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 + <> 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 } = (Just 'B', + nul <> pgString n + <> B.word16BE 0 + <> B.word16BE (fromIntegral $ length p) <> foldMap (maybe (B.word32BE 0xFFFFFFFF) val) p + <> B.word16BE 0) + where val v = B.word32BE (fromIntegral $ L.length v) <> B.lazyByteString 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) <> foldMap B.word32BE t) +messageBody (PasswordMessage s) = (Just 'p', + B.lazyByteString 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 PGConnection{ connHandle = h, connDebug = d, connState = sr } msg = do + writeIORef sr StateUnknown + when d $ putStrLn $ "> " ++ show msg + B.hPutBuilder h $ foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + L.length b) + L.hPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length + where (t, b) = second B.toLazyByteString $ messageBody msg + +pgFlush :: PGConnection -> IO () +pgFlush = hFlush . connHandle + + +getPGString :: G.Get String +getPGString = U.toString <$> G.getLazyByteStringNul + +getMessageFields :: G.Get MessageFields +getMessageFields = g =<< G.getWord8 where + g 0 = return Map.empty + g f = liftM2 (Map.insert f) G.getLazyByteStringNul 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.getLazyByteString 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 <- G.getLazyByteStringNul + oid <- G.getWord32be -- table OID + col <- G.getWord16be -- column number + typ' <- G.getWord32be -- type + _ <- G.getWord16be -- type size + _ <- G.getWord32be -- type modifier + 0 <- G.getWord16be -- format code + return $ ColDescription + { colName = U.toString name + , colTable = oid + , colNumber = fromIntegral col + , colType = typ' + } +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 'C' = CommandComplete <$> G.getLazyByteStringNul +getMessageBody 'S' = liftM2 ParameterStatus getPGString getPGString +getMessageBody 'D' = do + numFields <- G.getWord16be + DataRow <$> replicateM (fromIntegral numFields) (getField =<< G.getWord32be) where + getField 0xFFFFFFFF = return Nothing + getField len = Just <$> G.getLazyByteString (fromIntegral len) +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 + +runGet :: Monad m => G.Get a -> L.ByteString -> m a +runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOrFail g s + +-- |Receive the next message from PostgreSQL (low-level). Note that this will +-- block until it gets a message. +pgReceive :: PGConnection -> IO PGBackendMessage +pgReceive c@PGConnection{ connHandle = h, connDebug = d } = do + (typ, len) <- runGet (liftM2 (,) G.getWord8 G.getWord32be) =<< L.hGet h 5 + msg <- runGet (getMessageBody $ w2c typ) =<< L.hGet h (fromIntegral len - 4) + when d $ putStrLn $ "< " ++ show msg + case msg of + ReadyForQuery s -> msg <$ writeIORef (connState c) s + NoticeResponse{ messageFields = m } -> + connLogMessage c m >> pgReceive c + ErrorResponse{ messageFields = m } -> + writeIORef (connState c) StateUnknown >> throwIO (PGError m) + _ -> return msg + -- |Connect to a PostgreSQL server. pgConnect :: HostName -- ^ the host to connect to -> PortID -- ^ the port to connect on @@ -173,33 +301,28 @@ pgConnect host port db user pass = do debug <- isJust <$> lookupEnv "TPG_DEBUG" state <- newIORef StateUnknown h <- connectTo host port - L.hPut h $ B.toLazyByteString $ B.putWord32be $ fromIntegral $ 4 + L.length handshake - L.hPut h handshake - hFlush h - conn $ PGConnection - { connHandle = h - , connDebug = debug - , connLogMessage = defaultLogMessage - , connPid = 0 - , connKey = 0 - , connParameters = Map.empty - , connTypes = defaultTypeMap - , connState = state - } + let c = PGConnection + { connHandle = h + , connDebug = debug + , connLogMessage = defaultLogMessage + , connPid = 0 + , connKey = 0 + , connParameters = Map.empty + , connTypes = defaultTypeMap + , connState = state + } + pgSend c $ StartupMessage + [ ("user", user) + , ("database", db) + , ("client_encoding", "UTF8") + , ("standard_conforming_strings", "on") + , ("bytea_output", "hex") + , ("DateStyle", "ISO, YMD") + , ("IntervalStyle", "iso_8601") + ] + pgFlush c + conn c where - -- These are here since the handshake message differs a bit from other - -- messages (it's missing the inital identifying character). I could probably - -- get rid of it with some refactoring. - handshake = B.toLazyByteString $ mconcat - [ B.putWord32be protocolVersion - , pgString "user", pgString user - , pgString "database", pgString db - , pgString "client_encoding", pgString "UTF8" - , pgString "standard_conforming_strings", pgString "on" - , pgString "bytea_output", pgString "hex" - , pgString "DateStyle", pgString "ISO, YMD" - , pgString "IntervalStyle", pgString "iso_8601" - , B.singleton 0 ] conn c = msg c =<< pgReceive c msg c (ReadyForQuery _) = return c msg c (BackendKeyData p k) = conn c{ connPid = p, connKey = k } @@ -207,13 +330,15 @@ pgConnect host port db user pass = do msg c AuthenticationOk = conn c msg c AuthenticationCleartextPassword = do pgSend c $ PasswordMessage $ U.fromString pass + pgFlush c conn c #ifdef USE_MD5 msg c (AuthenticationMD5Password salt) = do pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pass ++ user)) `L.append` salt) + pgFlush c conn c #endif - msg _ m = throwIO $ PGException $ errorMessage $ "unexpected: " ++ show m + msg _ m = fail $ "pgConnect: unexpected response: " ++ show m -- |Disconnect from a PostgreSQL server. Note that this currently doesn't send -- a close message. @@ -223,184 +348,18 @@ pgDisconnect c@PGConnection{ connHandle = h } = do pgSend c Terminate hClose h -pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection -pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } - --- |Convert a string to a NULL-terminated UTF-8 string. The PostgreSQL --- protocol transmits most strings in this format. --- I haven't yet found a function for doing this without requiring manual --- memory management. -pgString :: String -> B.Builder -pgString s = B.fromLazyByteString (U.fromString s) <> B.singleton 0 - -pgMessageID :: PGMessage -> Word8 -pgMessageID (UnknownMessage t) = t -pgMessageID m = c2w $ case m of - AuthenticationOk -> 'R' - AuthenticationCleartextPassword -> 'R' - (AuthenticationMD5Password _) -> 'R' - (BackendKeyData _ _) -> 'K' - (Bind _ _) -> 'B' - (Close _) -> 'C' - (CommandComplete _) -> 'C' - (DataRow _) -> 'D' - (Describe _) -> 'D' - EmptyQueryResponse -> 'I' - (ErrorResponse _) -> 'E' - (Execute _) -> 'E' - Flush -> 'H' - NoData -> 'n' - (NoticeResponse _) -> 'N' - (ParameterDescription _) -> 't' - (ParameterStatus _ _) -> 'S' - (Parse _ _ _) -> 'P' - ParseComplete -> '1' - (PasswordMessage _) -> 'p' - PortalSuspended -> 's' - (ReadyForQuery _) -> 'Z' - (RowDescription _) -> 'T' - (SimpleQuery _) -> 'Q' - Sync -> 'S' - Terminate -> 'X' - (UnknownMessage _) -> error "Unknown message type" - --- |All PostgreSQL messages have a common header: an identifying character and --- a 32-bit size field. -instance Binary PGMessage where - -- |Putting a message automatically adds the necessary message type and - -- message size fields. - put m = do - let body = B.toLazyByteString $ putMessageBody m - P.putWord8 $ pgMessageID m - P.putWord32be $ fromIntegral $ L.length body + 4 - P.putLazyByteString body - get = getMessageBody . fst =<< getMessageHeader - --- |Given a message, build the over-the-wire representation of it. Note that we --- send fewer messages than we receive. -putMessageBody :: PGMessage -> B.Builder -putMessageBody Describe{ statementName = n } = - B.singleton (c2w 'S') <> pgString n -putMessageBody Close{ statementName = n } = - B.singleton (c2w 'S') <> pgString n -putMessageBody (Execute r) = B.singleton 0 <> B.putWord32be r -putMessageBody Parse{ statementName = n, queryString = s, parseTypes = t } = - pgString n <> pgString s <> - B.putWord16be (fromIntegral $ length t) <> foldMap B.putWord32be t -putMessageBody Bind{ statementName = n, bindParameters = p } = - B.singleton 0 <> pgString n <> B.putWord16be 0 <> - B.putWord16be (fromIntegral $ length p) <> foldMap (maybe (B.putWord32be 0xFFFFFFFF) val) p <> - B.putWord16be 0 - where val v = B.putWord32be (fromIntegral $ L.length v) <> B.fromLazyByteString v -putMessageBody SimpleQuery{ queryString = s } = - pgString s -putMessageBody (PasswordMessage s) = - B.fromLazyByteString s <> B.singleton 0 -putMessageBody _ = B.empty - --- |Get the type and size of an incoming message. -getMessageHeader :: Get (Word8, Int) -getMessageHeader = do - typ <- G.getWord8 - len <- G.getWord32be - return (typ, fromIntegral len) - -getMessageFields :: Get MessageFields -getMessageFields = g =<< G.getWord8 where - g :: Word8 -> Get MessageFields - g 0 = return Map.empty - g f = liftM2 (Map.insert f) G.getLazyByteStringNul getMessageFields - -getReadyState :: Get PGState -getReadyState = rs . w2c =<< G.getWord8 where - rs 'I' = return StateIdle - rs 'T' = return StateTransaction - rs 'E' = return StateTransactionFailed - rs s = fail $ "Unknown ready state: " ++ show s - --- |Parse an incoming message. -getMessageBody :: Word8 -- ^ the type of the message to parse - -> Get PGMessage -getMessageBody typ = - case w2c typ of - 'R' -> do - op <- G.getWord32be - case op of - 0 -> return AuthenticationOk - 3 -> return AuthenticationCleartextPassword - 5 -> AuthenticationMD5Password `liftM` G.getLazyByteString 4 - _ -> fail $ "Unsupported authentication message: " ++ show op - 't' -> do numParams <- fromIntegral `liftM` G.getWord16be - ps <- replicateM numParams readParam - return $ ParameterDescription ps - where readParam = G.getWord32be - 'T' -> do numFields <- fromIntegral `liftM` G.getWord16be - ds <- replicateM numFields readField - return $ RowDescription ds - where readField = do name <- G.getLazyByteStringNul - oid <- G.getWord32be -- table OID - col <- G.getWord16be -- column number - typ' <- G.getWord32be -- type - _ <- G.getWord16be -- type size - _ <- G.getWord32be -- type modifier - 0 <- G.getWord16be -- format code - return $ ColDescription - { colName = U.toString name - , colTable = oid - , colNumber = fromIntegral col - , colType = typ' - } - 'Z' -> liftM ReadyForQuery getReadyState - '1' -> return ParseComplete - 'C' -> liftM CommandComplete G.getLazyByteStringNul - 'S' -> liftM2 ParameterStatus G.getLazyByteStringNul G.getLazyByteStringNul - 'D' -> do numFields <- G.getWord16be - DataRow <$> replicateM (fromIntegral numFields) readField - where readField = do len <- G.getWord32be - case len of - 0xFFFFFFFF -> return Nothing - _ -> Just `liftM` G.getLazyByteString (fromIntegral len) - 'K' -> liftM2 BackendKeyData G.getWord32be G.getWord32be - 'E' -> ErrorResponse `liftM` getMessageFields - 'I' -> return EmptyQueryResponse - 'n' -> return NoData - 's' -> return PortalSuspended - 'N' -> NoticeResponse `liftM` getMessageFields - _ -> return $ UnknownMessage typ - --- |Send a message to PostgreSQL (low-level). -pgSend :: PGConnection -> PGMessage -> IO () -pgSend PGConnection{ connHandle = h, connDebug = d, connState = sr } msg = do - writeIORef sr StateUnknown - when d $ putStrLn $ "> " ++ show msg - L.hPut h (encode msg) >> hFlush h - -runGet :: Monad m => G.Get a -> L.ByteString -> m a -runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOrFail g s - --- |Receive the next message from PostgreSQL (low-level). Note that this will --- block until it gets a message. -pgReceive :: PGConnection -> IO PGMessage -pgReceive c@PGConnection{ connHandle = h, connDebug = d } = do - (typ, len) <- runGet getMessageHeader =<< L.hGet h 5 - msg <- runGet (getMessageBody typ) =<< L.hGet h (len - 4) - when d $ putStrLn $ "< " ++ show msg - case msg of - ReadyForQuery s -> msg <$ writeIORef (connState c) s - NoticeResponse{ messageFields = m } -> - connLogMessage c m >> pgReceive c - ErrorResponse{ messageFields = m } -> - writeIORef (connState c) StateUnknown >> throwIO (PGException m) - _ -> return msg - pgSync :: PGConnection -> IO () pgSync c@PGConnection{ connState = sr } = do s <- readIORef sr when (s == StateUnknown) $ do pgSend c Sync - _ <- pgReceive c `catch` \(PGException m) -> ErrorResponse m <$ connLogMessage c m + pgFlush c + _ <- pgReceive c `catch` \(PGError m) -> ErrorResponse m <$ connLogMessage c m pgSync c +pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection +pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } + getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c t = do (_, r) <- pgSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c @@ -431,6 +390,7 @@ describeStatement h sql = do pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = [] } pgSend h $ Describe "" pgSend h $ Flush + pgFlush h ParseComplete <- pgReceive h ParameterDescription ps <- pgReceive h m <- pgReceive h @@ -471,6 +431,7 @@ pgSimpleQuery :: String -- ^ SQL string pgSimpleQuery sql h = do pgSync h pgSend h $ SimpleQuery sql + pgFlush h go start where go = (>>=) $ pgReceive h start (CommandComplete c) = got c diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 949e1f8..78f27a3 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -19,7 +19,7 @@ module Database.TemplatePG.SQL ( makePGQuery ) where import Control.Exception (onException, catchJust) -import Control.Monad (liftM, void) +import Control.Monad (liftM, void, guard) import Data.Maybe (listToMaybe) import Language.Haskell.TH @@ -86,8 +86,5 @@ rollback = void . pgSimpleQuery "ROLLBACK" -- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. insertIgnore :: IO () -> IO () -insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) - where uniquenessError e = case e of - PGException m -> case messageCode m of - "23505" -> Just () - _ -> Nothing +insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where + uniquenessError (PGError m) = guard (messageCode m == "24505") diff --git a/templatepg.cabal b/templatepg.cabal index 21b6a24..bfd4180 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -34,7 +34,7 @@ Library Build-Depends: base >= 4.6 && < 5, binary, - bytestring, + bytestring >= 0.10.2, containers, haskell-src-meta, mtl, From a4f8887f15f5596040a4165bd87fa6532ff1f65a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 17:02:50 -0500 Subject: [PATCH 027/306] Make function names and arg order more consistent --- Database/TemplatePG/Protocol.hs | 29 ++++++++++++----------------- Database/TemplatePG/Query.hs | 6 +++--- Database/TemplatePG/SQL.hs | 8 ++++---- 3 files changed, 19 insertions(+), 24 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 66310cd..a645994 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -11,7 +11,7 @@ module Database.TemplatePG.Protocol ( PGConnection , messageCode , pgConnect , pgDisconnect - , describeStatement + , pgDescribe , pgSimpleQuery , pgAddType , getTypeOID @@ -238,7 +238,7 @@ getMessageBody 'T' = do numFields <- G.getWord16be RowDescription <$> replicateM (fromIntegral numFields) getField where getField = do - name <- G.getLazyByteStringNul + name <- getPGString oid <- G.getWord32be -- table OID col <- G.getWord16be -- column number typ' <- G.getWord32be -- type @@ -246,7 +246,7 @@ getMessageBody 'T' = do _ <- G.getWord32be -- type modifier 0 <- G.getWord16be -- format code return $ ColDescription - { colName = U.toString name + { colName = name , colTable = oid , colNumber = fromIntegral col , colType = typ' @@ -362,7 +362,7 @@ pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c t = do - (_, r) <- pgSimpleQuery ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) c + (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) case r of [] -> return Nothing [[Just o, Just lo]] | Just to <- pgDecodeBS o, Just lto <- pgDecodeBS lo -> @@ -373,7 +373,7 @@ getPGType :: PGConnection -> OID -> IO PGTypeHandler getPGType c@PGConnection{ connTypes = types } oid = maybe notype return $ Map.lookup oid types where notype = do - (_, r) <- pgSimpleQuery ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) c + (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) case r of [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ U.toString s _ -> fail $ "Unknown PostgreSQL type: " ++ show oid @@ -382,10 +382,9 @@ getPGType c@PGConnection{ connTypes = types } oid = -- more parameter descriptions (a PostgreSQL type) and zero or more result -- field descriptions (for queries) (consist of the name of the field, the -- type of the field, and a nullability indicator). -describeStatement :: PGConnection - -> String -- ^ SQL string +pgDescribe :: PGConnection -> String -- ^ SQL string -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. -describeStatement h sql = do +pgDescribe h sql = do pgSync h pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = [] } pgSend h $ Describe "" @@ -412,23 +411,19 @@ describeStatement h sql = do then return True -- In cases where the resulting field is tracable to the column of a -- table, we can check there. - else do (_, r) <- pgSimpleQuery ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) h + else do (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) case r of - [[Just s]] -> return $ case U.toString s of - "t" -> False - "f" -> True - _ -> error "Unexpected result from PostgreSQL" + [[Just s]] -> maybe (fail "Failed to parse nullability value") (return . not) $ pgDecodeBS s [] -> return True - _ -> fail $ "Can't determine nullability of column #" ++ show col + _ -> fail $ "Failed to determine nullability of column #" ++ show col -- |A simple query is one which requires sending only a single 'SimpleQuery' -- message to the PostgreSQL server. The query is sent as a single string; you -- cannot bind parameters. Note that queries can return 0 results (an empty -- list). -pgSimpleQuery :: String -- ^ SQL string - -> PGConnection +pgSimpleQuery :: PGConnection -> String -- ^ SQL string -> IO (Int, [PGData]) -- ^ The number of rows affected and a list of result rows -pgSimpleQuery sql h = do +pgSimpleQuery h sql = do pgSync h pgSend h $ SimpleQuery sql pgFlush h diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 3703d13..fb91fc8 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -28,13 +28,13 @@ instance Functor PGQuery where -- |Run a query and return a list of row results. pgQuery :: PGConnection -> PGQuery a -> IO [a] pgQuery c PGSimpleQuery{ pgQueryString = s, pgQueryParser = p } = - map p . snd <$> pgSimpleQuery s c + map p . snd <$> pgSimpleQuery c s -- |Execute a query that does not return result. -- Return the number of rows affected (or -1 if not known). pgExecute :: PGConnection -> PGQuery () -> IO Int pgExecute c PGSimpleQuery{ pgQueryString = s } = - fst <$> pgSimpleQuery s c + fst <$> pgSimpleQuery c s -- |Produce a new PGQuery from a SQL query string. -- This should be used as @$(makePGQuery \"SELECT ...\")@ @@ -42,7 +42,7 @@ makePGQuery :: String -- ^ a SQL query string -> TH.Q TH.Exp -- ^ a PGQuery makePGQuery sql = do (pTypes, fTypes) <- TH.runIO $ withTHConnection $ \c -> - describeStatement c (holdPlaces sqlStrings expStrings) + pgDescribe c (holdPlaces sqlStrings expStrings) s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings [| PGSimpleQuery $(return s) $(convertRow fTypes) |] where diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 78f27a3..1d34202 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -74,15 +74,15 @@ execute sql = [| \c -> pgExecute c $(makePGQuery sql) |] -- 'MonadPeelIO' version. withTransaction :: PGConnection -> IO a -> IO a withTransaction h a = - onException (do void $ pgSimpleQuery "BEGIN" h + onException (do void $ pgSimpleQuery h "BEGIN" c <- a - void $ pgSimpleQuery "COMMIT" h + void $ pgSimpleQuery h "COMMIT" return c) - (void $ pgSimpleQuery "ROLLBACK" h) + (void $ pgSimpleQuery h "ROLLBACK") -- |Roll back a transaction. rollback :: PGConnection -> IO () -rollback = void . pgSimpleQuery "ROLLBACK" +rollback h = void $ pgSimpleQuery h "ROLLBACK" -- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. insertIgnore :: IO () -> IO () From 4962033a94ff327287244b3a116698f5d53a7158 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 17:13:25 -0500 Subject: [PATCH 028/306] Make decode just return a value These are unexpected conditions and we're just going to fail anyway --- Database/TemplatePG/Protocol.hs | 5 +-- Database/TemplatePG/Types.hs | 69 ++++++++++++++++----------------- 2 files changed, 35 insertions(+), 39 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index a645994..141c0ef 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -365,8 +365,7 @@ getTypeOID c t = do (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) case r of [] -> return Nothing - [[Just o, Just lo]] | Just to <- pgDecodeBS o, Just lto <- pgDecodeBS lo -> - return (Just (to, lto)) + [[Just o, Just lo]] -> return (Just (pgDecodeBS o, pgDecodeBS lo)) _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r getPGType :: PGConnection -> OID -> IO PGTypeHandler @@ -413,7 +412,7 @@ pgDescribe h sql = do -- table, we can check there. else do (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) case r of - [[Just s]] -> maybe (fail "Failed to parse nullability value") (return . not) $ pgDecodeBS s + [[Just s]] -> return $ not $ pgDecodeBS s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 302cf7a..415c0ee 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -25,7 +25,6 @@ import Data.Char (isDigit, digitToInt, intToDigit) import Data.Int import Data.List (intercalate) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) @@ -34,7 +33,6 @@ import Numeric (readFloat) import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) -import Text.Read (readMaybe) pgQuoteUnsafe :: String -> String pgQuoteUnsafe s = '\'' : s ++ "'" @@ -50,10 +48,10 @@ pgQuote = ('\'':) . es where -- The default implementations do UTF-8 conversion. class PGType a where -- |Decode a postgres raw text representation into a value. - pgDecodeBS :: L.ByteString -> Maybe a + pgDecodeBS :: L.ByteString -> a pgDecodeBS = pgDecode . U.toString -- |Decode a postgres unicode string representation into a value. - pgDecode :: String -> Maybe a + pgDecode :: String -> a pgDecode = pgDecodeBS . U.fromString -- |Encode a value to a postgres raw text representation. pgEncodeBS :: a -> L.ByteString @@ -66,9 +64,9 @@ class PGType a where pgLiteral = pgQuote . pgEncode instance PGType Bool where - pgDecode "f" = return False - pgDecode "t" = return True - pgDecode _ = fail "bool" + pgDecode "f" = False + pgDecode "t" = True + pgDecode s = error $ "pgDecode bool: " ++ s pgEncode False = "f" pgEncode True = "t" pgLiteral False = "false" @@ -78,43 +76,43 @@ type OID = Word32 instance PGType OID where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType Int where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType Int16 where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType Int32 where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType Int64 where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType Char where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode [c] = return c - pgDecode _ = fail "char" + pgDecode [c] = c + pgDecode s = error $ "pgDecode char: " ++ s pgEncode c | fromEnum c < 256 = [c] | otherwise = error "pgEncode: Char out of range" @@ -122,19 +120,19 @@ instance PGType Char where instance PGType Float where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType Double where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = readMaybe + pgDecode = read pgEncode = show pgLiteral = show instance PGType String where - pgDecode = return + pgDecode = id pgEncode = id type Bytea = L.ByteString @@ -142,12 +140,13 @@ instance PGType Bytea where pgDecode = pgDecodeBS . LC.pack pgEncodeBS = LC.pack . pgEncode pgDecodeBS s - | LC.unpack m /= "\\x" = fail "bytea" - | otherwise = return $ L.pack $ pd $ L.unpack d where + | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm + | otherwise = L.pack $ pd $ L.unpack d where (m, d) = L.splitAt 2 s + sm = LC.unpack m pd [] = [] pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r - pd [x] = error $ "parseBytea: " ++ show x + pd [x] = error $ "pgDecode bytea: " ++ show x unhex = fromIntegral . digitToInt . w2c pgEncode = (++) "'\\x" . ed . L.unpack where ed [] = "\'" @@ -158,28 +157,28 @@ instance PGType Bytea where instance PGType Time.Day where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.parseTime defaultTimeLocale "%F" + pgDecode = Time.readTime defaultTimeLocale "%F" pgEncode = Time.showGregorian pgLiteral = pgQuoteUnsafe . pgEncode instance PGType Time.TimeOfDay where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.parseTime defaultTimeLocale "%T%Q" + pgDecode = Time.readTime defaultTimeLocale "%T%Q" pgEncode = Time.formatTime defaultTimeLocale "%T%Q" pgLiteral = pgQuoteUnsafe . pgEncode instance PGType Time.LocalTime where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.parseTime defaultTimeLocale "%F %T%Q" + pgDecode = Time.readTime defaultTimeLocale "%F %T%Q" pgEncode = Time.formatTime defaultTimeLocale "%F %T%Q" pgLiteral = pgQuoteUnsafe . pgEncode instance PGType Time.ZonedTime where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.parseTime defaultTimeLocale "%F %T%Q%z" . fixTZ + pgDecode = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ pgEncode = fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" pgLiteral = pgQuoteUnsafe . pgEncode @@ -199,7 +198,7 @@ fixTZ (c:s) = c:fixTZ s instance PGType Time.DiffTime where pgDecode = pgDecodeBS . LC.pack pgEncodeBS = LC.pack . pgEncode - pgDecodeBS = either (fail . show) return . P.parse ps "interval" where + pgDecodeBS = 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)] @@ -238,8 +237,10 @@ instance PGType Time.DiffTime where instance PGType Rational where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode - pgDecode "NaN" = Just (0 % 0) -- this won't work - pgDecode s = unReads $ readFloat s + pgDecode "NaN" = 0 % 0 -- this won't work + pgDecode s = ur $ readFloat s where + ur [(x,"")] = x + ur _ = error $ "pgDecode numeric: " ++ s pgEncode r | denominator r == 0 = "NaN" -- this can't happen | otherwise = take 30 (showRational (r / (10 ^^ e))) ++ 'e' : show e where @@ -248,19 +249,15 @@ instance PGType Rational where | denominator r == 0 = "'NaN'" -- this can't happen | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" --- This may produce infinite strings +-- 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) -unReads :: [(a,String)] -> Maybe a -unReads [(x,"")] = return x -unReads _ = fail "unReads: no parse" - instance PGType a => PGType [Maybe a] where - pgDecodeBS = either (fail . show) return . P.parse pa "array" where + pgDecodeBS = 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 ',') @@ -268,7 +265,7 @@ instance PGType a => PGType [Maybe a] where return l nel = Nothing <$ nul P.<|> Just <$> el nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll" - el = maybe (fail "array element") return . pgDecodeBS . LC.pack =<< qel P.<|> uqel + el = pgDecodeBS . LC.pack <$> (qel P.<|> uqel) qel = P.between (P.char '"') (P.char '"') $ P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" uqel = P.many1 (P.noneOf "\",{}") @@ -287,7 +284,7 @@ data PGTypeHandler = PGType pgTypeDecoder :: PGTypeHandler -> Q Exp pgTypeDecoder PGType{ pgTypeType = t } = - [| fromMaybe (error "pgDecode: no parse") . pgDecodeBS :: L.ByteString -> $(return t) |] + [| pgDecodeBS :: L.ByteString -> $(return t) |] pgTypeEscaper :: PGTypeHandler -> Q Exp pgTypeEscaper PGType{ pgTypeType = t } = @@ -318,7 +315,7 @@ pgTypes = --, ( 650, 651, "cidr", ?) , ( 700, 1021, "float4", ''Float) , ( 701, 1022, "float8", ''Double) ---, ( 790, 791, "money", Centi? Fixed?) +--, ( 790, 791, "money", Centi? Fixed?) --, ( 829, 1040, "macaddr", ?) --, ( 869, 1041, "inet", ?) , (1042, 1014, "bpchar", ''String) From f25bfe8f3f8c5081b462d02e8f8b93437e9e2bd4 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 17:49:51 -0500 Subject: [PATCH 029/306] Allow Maybes to be passed as placeholder arguments At the cost of some loss of type inference. This is maybe questionable but seems to work in normal cases. It will just have trouble with things like numeric literals. --- Database/TemplatePG/Types.hs | 29 +++++++++++++++++++++++++++-- test/Main.hs | 12 ++++++++---- 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 415c0ee..92da419 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, OverlappingInstances, ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies #-} -- Copyright 2010, 2011, 2013 Chris Forno -- Copyright 2014 Dylan Simon @@ -6,6 +6,7 @@ module Database.TemplatePG.Types ( pgQuote , PGType(..) , OID + , PossiblyMaybe(..) , PGTypeHandler(..) , pgTypeDecoder , pgTypeEscaper @@ -277,6 +278,30 @@ instance PGType a => PGType [Maybe a] where es (c@'\\':r) = '\\':c:es r es (c:r) = c:es r +{- +-- Since PG values cannot contain '\0', we use it as a special flag for NULL values (which will later be encoded with length -1) +pgNull :: String +pgNull = "\0" +pgNullBS :: L.ByteString +pgNullBS = L.singleton 0 + +-- This is a nice idea, but isn't actually useful because these types will never be resolved +instance PGType a => PGType (Maybe a) where + pgDecodeBS s = pgDecodeBS s <$ guard (s /= pgNullBS) + pgDecode s = pgDecode s <$ guard (s /= pgNull) + pgEncodeBS = maybe pgNullBS pgEncodeBS + pgEncode = maybe pgNull pgEncode + pgLiteral = maybe "NULL" pgLiteral +-} + +class PGType a => PossiblyMaybe m a {- | m -> a -} where + possiblyMaybe :: m -> Maybe a + +instance PGType a => PossiblyMaybe a a where + possiblyMaybe = Just +instance PGType a => PossiblyMaybe (Maybe a) a where + possiblyMaybe = id + data PGTypeHandler = PGType { pgTypeName :: String , pgTypeType :: Type @@ -288,7 +313,7 @@ pgTypeDecoder PGType{ pgTypeType = t } = pgTypeEscaper :: PGTypeHandler -> Q Exp pgTypeEscaper PGType{ pgTypeType = t } = - [| pgLiteral :: $(return t) -> String |] + [| maybe "NULL" (pgLiteral :: $(return t) -> String) . possiblyMaybe |] type PGTypeMap = Map.Map OID PGTypeHandler diff --git a/test/Main.hs b/test/Main.hs index 38ba0aa..fd55993 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ module Main (main) where import qualified Data.Time as Time +import Data.Int (Int32) import System.Environment (setEnv) import System.Exit (exitSuccess, exitFailure) @@ -18,11 +19,14 @@ main = do c <- connect _ <- $(queryTuples "SELECT oid, typname from pg_type") c z <- Time.getZonedTime - let t = Time.zonedTimeToLocalTime z + let i = 1 + b = True + f = 3.14 + t = Time.zonedTimeToLocalTime z d = Time.localDay t p = -34881559 l = [Just "a\\\"b,c", Nothing] - Just (Just 1, Just True, Just 3.14, Just d', Just t', Just z', Just p', Just l') <- - $(queryTuple "SELECT {1}::int, {True}::bool, {3.14}::float4, {d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval, {l}::text[]") c - assert $ d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' && l == l' + Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l') <- + $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval, {l}::text[]") c + assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' && l == l' exitSuccess From f9f2b23665b9618e3c8fa5e3f292ec961af89bee Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 17:52:50 -0500 Subject: [PATCH 030/306] Remove some stale dependencies --- templatepg.cabal | 3 --- 1 file changed, 3 deletions(-) diff --git a/templatepg.cabal b/templatepg.cabal index bfd4180..ae342a2 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -37,12 +37,9 @@ Library bytestring >= 0.10.2, containers, haskell-src-meta, - mtl, network, old-locale, parsec, - regex-compat, - regex-posix, template-haskell, time, utf8-string From b30493cceb5dd21c4a320aa5fed5a1f782cdc66d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 17:56:19 -0500 Subject: [PATCH 031/306] Update documentation to reflect Maybe parameters --- Database/TemplatePG.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index b626f5f..b52a562 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -86,9 +86,9 @@ import Database.TemplatePG.SQL -- To pass parameters to a query, include them in the string with {}. Most -- Haskell expressions should work. For example: -- --- @let owner = 33 +-- @let owner = 33 :: Int32 -- --- tuples <- $(queryTuples \"SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3}\") h +-- tuples <- $(queryTuples \"SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int32}\") h -- @ -- -- Note that parameters may only be used where PostgreSQL will allow them. This @@ -96,6 +96,9 @@ import Database.TemplatePG.SQL -- -- @tuples <- $(queryTuples \"SELECT * FROM {tableName}\") h@ -- +-- The types of any parameter expressions must be fully known. This may +-- require explicit casts in some cases. +-- -- And in general, you cannot construct queries at run-time, since they -- wouldn't be available to be analyzed at compile time. @@ -136,9 +139,7 @@ import Database.TemplatePG.SQL -- and column (such as when a function is applied to a result column), it's -- assumed to be nullable and will be returned as a 'Maybe' value. -- --- Additionally, you cannot directly use @NULL@ values in parameters. As a --- workaround, you might have to use 2 or more separate queries (and @DEFAULT --- NULL@) to @INSERT@ rows with @NULL@s. +-- You can use @NULL@ values in parameters as well by using 'Maybe'. -- -- Nullability is indicated incorrectly in the case of outer joins. TemplatePG -- incorrectly infers that a field cannot be @NULL@ when it's able to trace the From 8e2e65f95be3afaf16d5d9b59d38b0fd39089e9c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 18:43:32 -0500 Subject: [PATCH 032/306] Make convertRow much more efficient By using list patterns. This also now errors on extra columns. --- Database/TemplatePG/Query.hs | 37 +++++++++++++++++------------------- Database/TemplatePG/Types.hs | 4 ++++ 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index fb91fc8..18fb3c3 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -6,8 +6,8 @@ module Database.TemplatePG.Query ) where import Control.Applicative ((<$>)) -import Control.Monad (zipWithM, liftM) -import Data.Maybe (fromJust) +import Control.Monad (zipWithM, mapAndUnzipM) +import Data.Maybe (fromMaybe) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH import qualified Text.ParserCombinators.Parsec as P @@ -73,15 +73,23 @@ weaveString _ _ = error "Weave mismatch (possible parse problem)" convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description -> TH.Q TH.Exp -- ^ A function for converting a row of the given result description convertRow types = do - n <- TH.newName "result" - TH.lamE [TH.varP n] $ TH.tupE $ map (convertColumn n) $ zip types [0..] + (pats, conv) <- mapAndUnzipM (\t@(n, _, _) -> do + v <- TH.newName n + return (TH.varP v, convertColumn (TH.varE v) t)) types + TH.lamE [TH.listP pats] $ TH.tupE conv -- |Given a raw PostgreSQL result and a result field type, convert the --- appropriate field to a Haskell value. -convertColumn :: TH.Name -- ^ the name of the variable containing the result list (of 'Maybe' 'ByteString') - -> ((String, PGTypeHandler, Bool), Int) -- ^ the result field type and index - -> TH.Q TH.Exp -convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) ($(TH.varE name) !! i) |] +-- field to a Haskell value. +-- If the boolean +-- argument is 'False', that means that we know that the value is not nullable +-- and we can use 'fromJust' to keep the code simple. If it's 'True', then we +-- don't know if the value is nullable and must return a 'Maybe' value in case +-- it is. +convertColumn :: TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') + -> (String, PGTypeHandler, Bool) -- ^ the result field type + -> TH.ExpQ +convertColumn v (n, t, False) = [| $(pgTypeDecoder t) . fromMaybe (error $ "Unexpected NULL value in " ++ n) $(v) |] +convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] -- SQL Parser -- @@ -97,17 +105,6 @@ parseSql sql = case (P.parse sqlStatement "" sql) of Left err -> error (show err) Right ss -> every2nd ss --- |Like 'pgStringToType', but deal with possible @NULL@s. If the boolean --- argument is 'False', that means that we know that the value is not nullable --- and we can use 'fromJust' to keep the code simple. If it's 'True', then we --- don't know if the value is nullable and must return a 'Maybe' value in case --- it is. -pgStringToType' :: PGTypeHandler - -> Bool -- ^ nullability indicator - -> TH.Q TH.Exp -pgStringToType' t False = [| $(pgTypeDecoder t) . fromJust |] -pgStringToType' t True = [| liftM $(pgTypeDecoder t) |] - sqlStatement :: P.Parser [String] sqlStatement = P.many1 $ P.choice [sqlText, sqlParameter] diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 92da419..7c13ade 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -26,6 +26,7 @@ import Data.Char (isDigit, digitToInt, intToDigit) import Data.Int import Data.List (intercalate) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) @@ -296,11 +297,14 @@ instance PGType a => PGType (Maybe a) where class PGType a => PossiblyMaybe m a {- | m -> a -} where possiblyMaybe :: m -> Maybe a + maybePossibly :: Maybe a -> m instance PGType a => PossiblyMaybe a a where possiblyMaybe = Just + maybePossibly = fromMaybe (error "Unexpected NULL value") instance PGType a => PossiblyMaybe (Maybe a) a where possiblyMaybe = id + maybePossibly = id data PGTypeHandler = PGType { pgTypeName :: String From d56ca6cd1a5788eb9e19b59ec69305633f2a1bb0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 18:57:01 -0500 Subject: [PATCH 033/306] Fixup last for non-null columns --- Database/TemplatePG/Query.hs | 2 +- test/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 18fb3c3..c00afbb 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -88,7 +88,7 @@ convertRow types = do convertColumn :: TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') -> (String, PGTypeHandler, Bool) -- ^ the result field type -> TH.ExpQ -convertColumn v (n, t, False) = [| $(pgTypeDecoder t) . fromMaybe (error $ "Unexpected NULL value in " ++ n) $(v) |] +convertColumn v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $ "Unexpected NULL value in " ++ n) $(v)) |] convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] -- SQL Parser -- diff --git a/test/Main.hs b/test/Main.hs index fd55993..cf1e9b2 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -17,7 +17,7 @@ useTHConnection connect main :: IO () main = do c <- connect - _ <- $(queryTuples "SELECT oid, typname from pg_type") c + _ <- $(queryTuples "SELECT typname from pg_type") c :: IO [String] z <- Time.getZonedTime let i = 1 b = True From 4a0915f12804d81776306d83cabe445f0e5441fc Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 28 Dec 2014 19:18:02 -0500 Subject: [PATCH 034/306] Rename handlePGType to registerPGType --- Database/TemplatePG.hs | 2 +- Database/TemplatePG/Connection.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index b52a562..cf5284e 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -25,7 +25,7 @@ module Database.TemplatePG (-- *Introduction , pgConnect , pgDisconnect , useTHConnection - , handlePGType + , registerPGType , queryTuples , queryTuple , execute diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs index 3fd1224..761b702 100644 --- a/Database/TemplatePG/Connection.hs +++ b/Database/TemplatePG/Connection.hs @@ -1,7 +1,7 @@ module Database.TemplatePG.Connection ( withTHConnection , useTHConnection - , handlePGType + , registerPGType ) where import Control.Applicative ((<$>), (<$)) @@ -49,8 +49,8 @@ modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . liftM -- |Register a new handler for PostgreSQL type and a Haskell type, which should be an instance of 'PGType'. -- This should be called as a top-level declaration and produces no code. -handlePGType :: String -> TH.Type -> TH.Q [TH.Dec] -handlePGType name typ = [] <$ TH.runIO (do +registerPGType :: String -> TH.Type -> TH.Q [TH.Dec] +registerPGType name typ = [] <$ TH.runIO (do (oid, loid) <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) modifyTHConnection (pgAddType oid (PGType name typ)) when (loid /= 0) $ From bfef1aa6480a59e23959267dc72b0614e8a1e2d0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 29 Dec 2014 21:06:52 -0500 Subject: [PATCH 035/306] Rewrite query parser to use ${} and allow $N First step towards supporting prepared queries --- Database/TemplatePG/Query.hs | 115 ++++++++++++++++++----------------- Database/TemplatePG/SQL.hs | 13 ++-- templatepg.cabal | 7 +-- 3 files changed, 69 insertions(+), 66 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index c00afbb..0a92cb7 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -1,16 +1,20 @@ +{-# LANGUAGE PatternGuards #-} module Database.TemplatePG.Query ( PGQuery , pgExecute , pgQuery - , makePGQuery + , makePGSimpleQuery ) where import Control.Applicative ((<$>)) -import Control.Monad (zipWithM, mapAndUnzipM) +import Control.Arrow ((***), first) +import Control.Monad (when, zipWithM, mapAndUnzipM) +import Data.Array (listArray, (!), inRange) +import Data.Char (isDigit) import Data.Maybe (fromMaybe) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH -import qualified Text.ParserCombinators.Parsec as P +import Numeric (readDec) import Database.TemplatePG.Types import Database.TemplatePG.Protocol @@ -36,37 +40,6 @@ pgExecute :: PGConnection -> PGQuery () -> IO Int pgExecute c PGSimpleQuery{ pgQueryString = s } = fst <$> pgSimpleQuery c s --- |Produce a new PGQuery from a SQL query string. --- This should be used as @$(makePGQuery \"SELECT ...\")@ -makePGQuery :: String -- ^ a SQL query string - -> TH.Q TH.Exp -- ^ a PGQuery -makePGQuery sql = do - (pTypes, fTypes) <- TH.runIO $ withTHConnection $ \c -> - pgDescribe c (holdPlaces sqlStrings expStrings) - s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings - [| PGSimpleQuery $(return s) $(convertRow fTypes) |] - where - holdPlaces ss es = concat $ weave ss (take (length es) placeholders) - placeholders = map (('$' :) . show) ([1..]::[Int]) - stringify t s = [| $(pgTypeEscaper t) $(parseExp' s) |] - parseExp' e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e - (sqlStrings, expStrings) = parseSql sql - --- |"weave" 2 lists of equal length into a single list. -weave :: [a] -> [a] -> [a] -weave x [] = x -weave [] y = y -weave (x:xs) (y:ys) = x:y:(weave xs ys) - --- |"weave" a list of SQL fragements an Haskell expressions into a single SQL string. -weaveString :: [String] -- ^ SQL fragments - -> [TH.Exp] -- ^ Haskell expressions - -> TH.Q TH.Exp -weaveString [] [] = [| "" |] -weaveString [x] [] = [| x |] -weaveString [] [y] = return y -weaveString (x:xs) (y:ys) = [| x ++ $(return y) ++ $(weaveString xs ys) |] -weaveString _ _ = error "Weave mismatch (possible parse problem)" -- |Given a result description, create a function to convert a result to a -- tuple. @@ -91,27 +64,55 @@ convertColumn :: TH.ExpQ -- ^ the name of the variable containing the column val convertColumn v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $ "Unexpected NULL value in " ++ n) $(v)) |] convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] --- SQL Parser -- - -every2nd :: [a] -> ([a], [a]) -every2nd = foldr (\a ~(x,y) -> (a:y,x)) ([],[]) +-- |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 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 occurances may need to be escaped with '$$'" + + se = uncurry ((+$+) . lit) . 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 "" = ("", lit "") + + lit = TH.LitE . TH.StringL + TH.LitE (TH.StringL "") +$+ e = e + e +$+ TH.LitE (TH.StringL "") = e + TH.LitE (TH.StringL l) +$+ TH.LitE (TH.StringL r) = lit (l ++ r) + l +$+ r = TH.InfixE (Just l) (TH.VarE '(++)) (Just r) --- |Given a SQL string return a list of SQL parts and expression parts. --- For example: @\"SELECT * FROM table WHERE id = {someID} AND age > {baseAge * 1.5}\"@ --- becomes: @(["SELECT * FROM table WHERE id = ", " AND age > "], --- ["someID", "baseAge * 1.5"])@ -parseSql :: String -> ([String], [String]) -parseSql sql = case (P.parse sqlStatement "" sql) of - Left err -> error (show err) - Right ss -> every2nd ss - -sqlStatement :: P.Parser [String] -sqlStatement = P.many1 $ P.choice [sqlText, sqlParameter] - -sqlText :: P.Parser String -sqlText = P.many1 (P.noneOf "{") - --- |Parameters are enclosed in @{}@ and can be any Haskell expression supported --- by haskell-src-meta. -sqlParameter :: P.Parser String -sqlParameter = P.between (P.char '{') (P.char '}') $ P.many1 (P.noneOf "}") +-- |Produce a new PGQuery from a SQL query string. +-- This should be used as @$(makePGQuery \"SELECT ...\")@ +makePGSimpleQuery :: String -> TH.Q TH.Exp -- ^ a PGQuery +makePGSimpleQuery sqle = do + (pTypes, fTypes) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp + let np = length pTypes + when (np < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurances of '${' may need to be escaped with '$${'" + + rowp <- convertRow fTypes + vars <- mapM (TH.newName . ('p':) . show) [1..np] + lits <- zipWithM (\v t -> (`TH.AppE` TH.VarE v) <$> pgTypeEscaper t) vars pTypes + let pgf = TH.LamE (map TH.VarP vars) $ + TH.ConE 'PGSimpleQuery `TH.AppE` sqlSubstitute sqlp lits `TH.AppE` rowp + foldl TH.AppE pgf <$> mapM parse exprs + where + (sqlp, exprs) = sqlPlaceholders sqle + parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 1d34202..784332d 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -9,8 +9,7 @@ -- Note that transactions are messy and untested. Attempt to use them at your -- own risk. -module Database.TemplatePG.SQL ( makePGQuery - , queryTuples +module Database.TemplatePG.SQL ( queryTuples , queryTuple , execute , insertIgnore @@ -26,6 +25,12 @@ import Language.Haskell.TH import Database.TemplatePG.Protocol import Database.TemplatePG.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. @@ -37,7 +42,7 @@ import Database.TemplatePG.Query -- => IO [(Maybe String, Maybe Integer)] -- @ queryTuples :: String -> Q Exp -queryTuples sql = [| \c -> pgQuery c $(makePGQuery sql) |] +queryTuples sql = [| \c -> pgQuery c $(makePGSimpleQuery $ querySQL sql) |] -- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ -- @@ -66,7 +71,7 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- $(execute \"CREATE ROLE {rolename}\") h -- @ execute :: String -> Q Exp -execute sql = [| \c -> pgExecute c $(makePGQuery sql) |] +execute sql = [| \c -> pgExecute c $(makePGSimpleQuery $ 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' diff --git a/templatepg.cabal b/templatepg.cabal index ae342a2..c486529 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -33,15 +33,12 @@ Flag md5 Library Build-Depends: base >= 4.6 && < 5, - binary, + array, binary, containers, old-locale, time, bytestring >= 0.10.2, - containers, + template-haskell, haskell-src-meta, network, - old-locale, parsec, - template-haskell, - time, utf8-string Exposed-Modules: Database.TemplatePG From da357bcedce7baeb96223aae3cc88affb71ab321 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 29 Dec 2014 23:59:07 -0500 Subject: [PATCH 036/306] More work towards prepared statements --- Database/TemplatePG/Query.hs | 78 ++++++++++++++++++++++++------------ Database/TemplatePG/Types.hs | 5 +++ 2 files changed, 57 insertions(+), 26 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 0a92cb7..1debfe1 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -1,14 +1,19 @@ {-# LANGUAGE PatternGuards #-} module Database.TemplatePG.Query - ( PGQuery + ( PGStatement + , PGSimpleQuery + , PGPreparedStatement + , PGQueryParser + , pgRawParser , pgExecute , pgQuery , makePGSimpleQuery + , makePGPreparedQuery ) where import Control.Applicative ((<$>)) import Control.Arrow ((***), first) -import Control.Monad (when, zipWithM, mapAndUnzipM) +import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) import Data.Char (isDigit) import Data.Maybe (fromMaybe) @@ -20,25 +25,40 @@ import Database.TemplatePG.Types import Database.TemplatePG.Protocol import Database.TemplatePG.Connection --- |A query returning rows of the given type. -data PGQuery a = PGSimpleQuery - { pgQueryString :: String +class PGStatement q where + pgRawQuery :: PGConnection -> q -> IO (Int, [PGData]) + +pgRawExecute :: PGStatement q => PGConnection -> q -> IO Int +pgRawExecute c q = fst <$> pgRawQuery c q + +data PGSimpleQuery = PGSimpleQuery String +instance PGStatement PGSimpleQuery where + pgRawQuery c (PGSimpleQuery sql) = pgSimpleQuery c sql + +data PGPreparedStatement = PGPreparedStatement String [PGData] + +data PGQueryParser q a = PGQueryParser + { pgQueryStatement :: q , pgQueryParser :: PGData -> a } +instance PGStatement q => PGStatement (PGQueryParser q a) where + pgRawQuery c (PGQueryParser q _) = pgRawQuery c q -instance Functor PGQuery where +instance Functor (PGQueryParser q) where fmap f q = q{ pgQueryParser = f . pgQueryParser q } +pgRawParser :: q -> PGQueryParser q PGData +pgRawParser q = PGQueryParser q id + -- |Run a query and return a list of row results. -pgQuery :: PGConnection -> PGQuery a -> IO [a] -pgQuery c PGSimpleQuery{ pgQueryString = s, pgQueryParser = p } = - map p . snd <$> pgSimpleQuery c s +pgQuery :: PGStatement q => PGConnection -> PGQueryParser q a -> IO [a] +pgQuery c PGQueryParser{ pgQueryStatement = s, pgQueryParser = p } = + map p . snd <$> pgRawQuery c s -- |Execute a query that does not return result. -- Return the number of rows affected (or -1 if not known). -pgExecute :: PGConnection -> PGQuery () -> IO Int -pgExecute c PGSimpleQuery{ pgQueryString = s } = - fst <$> pgSimpleQuery c s +pgExecute :: PGStatement q => PGConnection -> PGQueryParser q () -> IO Int +pgExecute = pgRawExecute -- |Given a result description, create a function to convert a result to a @@ -99,20 +119,26 @@ sqlSubstitute sql exprl = se sql where TH.LitE (TH.StringL l) +$+ TH.LitE (TH.StringL r) = lit (l ++ r) l +$+ r = TH.InfixE (Just l) (TH.VarE '(++)) (Just r) --- |Produce a new PGQuery from a SQL query string. --- This should be used as @$(makePGQuery \"SELECT ...\")@ -makePGSimpleQuery :: String -> TH.Q TH.Exp -- ^ a PGQuery -makePGSimpleQuery sqle = do - (pTypes, fTypes) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp - let np = length pTypes - when (np < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurances of '${' may need to be escaped with '$${'" - - rowp <- convertRow fTypes - vars <- mapM (TH.newName . ('p':) . show) [1..np] - lits <- zipWithM (\v t -> (`TH.AppE` TH.VarE v) <$> pgTypeEscaper t) vars pTypes - let pgf = TH.LamE (map TH.VarP vars) $ - TH.ConE 'PGSimpleQuery `TH.AppE` sqlSubstitute sqlp lits `TH.AppE` rowp - foldl TH.AppE pgf <$> mapM parse exprs +makePGQuery :: (PGTypeHandler -> TH.ExpQ) -> (String -> [TH.Exp] -> TH.Exp) -> String -> TH.ExpQ -- ^ a PGQuery +makePGQuery encf pgf sqle = do + (pt, rt) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp + when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurances of '${' may need to be escaped with '$${'" + + (vars, vals) <- mapAndUnzipM (\t -> do + v <- TH.newName "p" + (,) (TH.VarP v) . (`TH.AppE` TH.VarE v) <$> encf t) pt + conv <- convertRow rt + foldl TH.AppE (TH.LamE vars $ TH.ConE 'PGQueryParser `TH.AppE` pgf sqlp vals `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e + +-- |Produce a new PGQuery from a SQL query string. +-- This should be used as @$(makePGQuery \"SELECT ...\")@ +makePGSimpleQuery :: String -> TH.Q TH.Exp +makePGSimpleQuery = makePGQuery pgTypeEscaper $ \sql ps -> + TH.ConE 'PGSimpleQuery `TH.AppE` sqlSubstitute sql ps + +makePGPreparedQuery :: String -> TH.Q TH.Exp +makePGPreparedQuery = makePGQuery pgTypeEncoder $ \sql ps -> + TH.ConE 'PGPreparedStatement `TH.AppE` TH.LitE (TH.StringL sql) `TH.AppE` TH.ListE ps diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 7c13ade..de54600 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -9,6 +9,7 @@ module Database.TemplatePG.Types , PossiblyMaybe(..) , PGTypeHandler(..) , pgTypeDecoder + , pgTypeEncoder , pgTypeEscaper , PGTypeMap , defaultTypeMap @@ -315,6 +316,10 @@ pgTypeDecoder :: PGTypeHandler -> Q Exp pgTypeDecoder PGType{ pgTypeType = t } = [| pgDecodeBS :: L.ByteString -> $(return t) |] +pgTypeEncoder :: PGTypeHandler -> Q Exp +pgTypeEncoder PGType{ pgTypeType = t } = + [| fmap (pgEncodeBS :: $(return t) -> L.ByteString) . possiblyMaybe |] + pgTypeEscaper :: PGTypeHandler -> Q Exp pgTypeEscaper PGType{ pgTypeType = t } = [| maybe "NULL" (pgLiteral :: $(return t) -> String) . possiblyMaybe |] From 0c07e66cb38129b9c464dd65962f46e86e67de78 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 00:14:04 -0500 Subject: [PATCH 037/306] Slightly cleaner types for PGQuery --- Database/TemplatePG/Query.hs | 56 +++++++++++++++++------------------- 1 file changed, 26 insertions(+), 30 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 1debfe1..2670d97 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} module Database.TemplatePG.Query - ( PGStatement + ( PGQuery(..) + , pgExecute + , pgQuery , PGSimpleQuery , PGPreparedStatement , PGQueryParser , pgRawParser - , pgExecute - , pgQuery , makePGSimpleQuery , makePGPreparedQuery ) where import Control.Applicative ((<$>)) -import Control.Arrow ((***), first) +import Control.Arrow ((***), first, second) import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) import Data.Char (isDigit) @@ -25,40 +25,36 @@ import Database.TemplatePG.Types import Database.TemplatePG.Protocol import Database.TemplatePG.Connection -class PGStatement q where - pgRawQuery :: PGConnection -> q -> IO (Int, [PGData]) +class PGQuery q a | q -> a where + pgRunQuery :: PGConnection -> q -> IO (Int, [a]) + +-- |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 = snd <$> pgRunQuery c q -pgRawExecute :: PGStatement q => PGConnection -> q -> IO Int -pgRawExecute c q = fst <$> pgRawQuery c q data PGSimpleQuery = PGSimpleQuery String -instance PGStatement PGSimpleQuery where - pgRawQuery c (PGSimpleQuery sql) = pgSimpleQuery c sql +instance PGQuery PGSimpleQuery PGData where + pgRunQuery c (PGSimpleQuery sql) = pgSimpleQuery c sql -data PGPreparedStatement = PGPreparedStatement String [PGData] -data PGQueryParser q a = PGQueryParser - { pgQueryStatement :: q - , pgQueryParser :: PGData -> a - } -instance PGStatement q => PGStatement (PGQueryParser q a) where - pgRawQuery c (PGQueryParser q _) = pgRawQuery c q +data PGPreparedStatement = PGPreparedStatement String [PGData] -instance Functor (PGQueryParser q) where - fmap f q = q{ pgQueryParser = f . pgQueryParser q } -pgRawParser :: q -> PGQueryParser q PGData -pgRawParser q = PGQueryParser q id +data PGQueryParser q a b = PGQueryParser q (a -> b) +instance PGQuery q a => PGQuery (PGQueryParser q a b) b where + pgRunQuery c (PGQueryParser q p) = second (map p) <$> pgRunQuery c q --- |Run a query and return a list of row results. -pgQuery :: PGStatement q => PGConnection -> PGQueryParser q a -> IO [a] -pgQuery c PGQueryParser{ pgQueryStatement = s, pgQueryParser = p } = - map p . snd <$> pgRawQuery c s +instance Functor (PGQueryParser q a) where + fmap f (PGQueryParser q p) = PGQueryParser q (f . p) --- |Execute a query that does not return result. --- Return the number of rows affected (or -1 if not known). -pgExecute :: PGStatement q => PGConnection -> PGQueryParser q () -> IO Int -pgExecute = pgRawExecute +pgRawParser :: q -> PGQueryParser q a a +pgRawParser q = PGQueryParser q id -- |Given a result description, create a function to convert a result to a From f4a31693383d0a5696cb30a8942bc7d9ceb497cd Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 01:21:58 -0500 Subject: [PATCH 038/306] Complete interface for prepared statements Untested --- Database/TemplatePG/Protocol.hs | 75 +++++++++++++++++++++++++++------ Database/TemplatePG/Query.hs | 8 ++-- 2 files changed, 68 insertions(+), 15 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 141c0ef..807edb4 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -13,6 +13,8 @@ module Database.TemplatePG.Protocol ( PGConnection , pgDisconnect , pgDescribe , pgSimpleQuery + , pgPreparedQuery + , pgCloseQuery , pgAddType , getTypeOID ) where @@ -22,7 +24,7 @@ import Database.TemplatePG.Types import Control.Applicative ((<$>), (<$)) import Control.Arrow (second) import Control.Exception (Exception, throwIO, catch) -import Control.Monad (liftM2, replicateM, when) +import Control.Monad (liftM2, replicateM, when, unless) #ifdef USE_MD5 import qualified Crypto.Hash as Hash #endif @@ -32,8 +34,8 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U -import Data.Foldable (foldMap) -import Data.IORef (IORef, newIORef, writeIORef, readIORef) +import Data.Foldable (foldMap, forM_) +import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) import Data.Monoid (mempty, (<>)) @@ -51,6 +53,8 @@ data PGState | StateTransactionFailed deriving (Show, Eq) +-- |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 , connDebug :: !Bool @@ -59,6 +63,7 @@ data PGConnection = PGConnection , connKey :: !Word32 , connParameters :: Map.Map String String , connTypes :: PGTypeMap + , connPreparedStatements :: IORef (Integer, Map.Map String Integer) , connState :: IORef PGState } @@ -300,6 +305,7 @@ pgConnect :: HostName -- ^ the host to connect to pgConnect host port db user pass = do debug <- isJust <$> lookupEnv "TPG_DEBUG" state <- newIORef StateUnknown + prep <- newIORef (0, Map.empty) h <- connectTo host port let c = PGConnection { connHandle = h @@ -309,6 +315,7 @@ pgConnect host port db user pass = do , connKey = 0 , connParameters = Map.empty , connTypes = defaultTypeMap + , connPreparedStatements = prep , connState = state } pgSend c $ StartupMessage @@ -340,8 +347,7 @@ pgConnect host port db user pass = do #endif msg _ m = fail $ "pgConnect: unexpected response: " ++ show m --- |Disconnect from a PostgreSQL server. Note that this currently doesn't send --- a close message. +-- |Disconnect cleanly from the PostgreSQL server. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () pgDisconnect c@PGConnection{ connHandle = h } = do @@ -416,6 +422,11 @@ pgDescribe h sql = do [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col +rowsAffected :: L.ByteString -> Int +rowsAffected = ra . LC.words where + ra [] = -1 + ra l = fromMaybe (-1) $ readMaybe $ LC.unpack $ last 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 @@ -430,13 +441,53 @@ pgSimpleQuery h sql = do go = (>>=) $ pgReceive h start (CommandComplete c) = got c start (RowDescription _) = go row - start m = fail $ "executeSimpleQuery: unexpected response: " ++ show m - row (CommandComplete c) = got c + start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m row (DataRow fs) = second (fs:) <$> go row - row m = fail $ "executeSimpleQuery: unexpected row: " ++ show m - got c = (,) (rowsAffected $ LC.words c) <$> go end - rowsAffected [] = -1 - rowsAffected l = fromMaybe (-1) $ readMaybe $ LC.unpack $ last l + row (CommandComplete c) = got c + row m = fail $ "pgSimpleQuery: unexpected row: " ++ show m + got c = (,) (rowsAffected c) <$> go end end (ReadyForQuery _) = return [] end EmptyQueryResponse = go end - end m = fail $ "executeSimpleQuery: unexpected message: " ++ show m + end m = fail $ "pgSimpleQuery: unexpected message: " ++ show m + +-- |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 + -> PGData -- ^ Paremeters to bind to placeholders + -> IO (Int, [PGData]) +pgPreparedQuery c@PGConnection{ connPreparedStatements = psr } sql bind = do + pgSync c + (p, n) <- atomicModifyIORef' psr $ \(i, m) -> + maybe ((succ i, m), (False, i)) ((,) (i, m) . (,) True) $ Map.lookup sql m + let sn = show n + unless p $ + pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = [] } + pgSend c $ Bind{ statementName = sn, bindParameters = bind } + pgSend c $ Execute 0 + pgSend c $ Flush + pgFlush c + let + start ParseComplete = do + modifyIORef psr $ \(i, m) -> + (i, Map.insert sql n m) + go start + start BindComplete = go row + start m = fail $ "pgPreparedQuery: unexpected response: " ++ show m + go start + where + go = (>>=) $ pgReceive c + row (DataRow fs) = second (fs:) <$> go row + row (CommandComplete r) = return (rowsAffected r, []) + row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m + +-- |Close a previously prepared query (if necessary). +pgCloseQuery :: PGConnection -> String -- ^ SQL statement with placeholders + -> IO () +pgCloseQuery c@PGConnection{ connPreparedStatements = psr } sql = do + mn <- atomicModifyIORef psr $ \(i, m) -> + let (n, m') = Map.updateLookupWithKey (\_ _ -> Nothing) sql m in ((i, m'), n) + forM_ mn $ \n -> do + pgSend c $ Close{ statementName = show n } + pgFlush c + CloseComplete <- pgReceive c + return () diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 2670d97..2cba305 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -4,7 +4,7 @@ module Database.TemplatePG.Query , pgExecute , pgQuery , PGSimpleQuery - , PGPreparedStatement + , PGPreparedQuery , PGQueryParser , pgRawParser , makePGSimpleQuery @@ -43,7 +43,9 @@ instance PGQuery PGSimpleQuery PGData where pgRunQuery c (PGSimpleQuery sql) = pgSimpleQuery c sql -data PGPreparedStatement = PGPreparedStatement String [PGData] +data PGPreparedQuery = PGPreparedQuery String PGData +instance PGQuery PGPreparedQuery PGData where + pgRunQuery c (PGPreparedQuery sql bind) = pgPreparedQuery c sql bind data PGQueryParser q a b = PGQueryParser q (a -> b) @@ -137,4 +139,4 @@ makePGSimpleQuery = makePGQuery pgTypeEscaper $ \sql ps -> makePGPreparedQuery :: String -> TH.Q TH.Exp makePGPreparedQuery = makePGQuery pgTypeEncoder $ \sql ps -> - TH.ConE 'PGPreparedStatement `TH.AppE` TH.LitE (TH.StringL sql) `TH.AppE` TH.ListE ps + TH.ConE 'PGPreparedQuery `TH.AppE` TH.LitE (TH.StringL sql) `TH.AppE` TH.ListE ps From 4609c4eb7044a0899f73f0edbd157b4eaf9af3e1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 10:32:50 -0500 Subject: [PATCH 039/306] Add some more tests and minor fixes --- Database/TemplatePG.hs | 8 ++++++++ Database/TemplatePG/Protocol.hs | 11 ++++++++--- test/Main.hs | 17 ++++++++++++++++- 3 files changed, 32 insertions(+), 4 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index cf5284e..5af5bd2 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -22,10 +22,17 @@ module Database.TemplatePG (-- *Introduction -- **Other Workarounds -- $other PGError(..) + , PGConnection , pgConnect , pgDisconnect , useTHConnection , registerPGType + + , makePGSimpleQuery + , makePGPreparedQuery + , pgQuery + , pgExecute + , queryTuples , queryTuple , execute @@ -35,6 +42,7 @@ module Database.TemplatePG (-- *Introduction import Database.TemplatePG.Protocol import Database.TemplatePG.Connection +import Database.TemplatePG.Query import Database.TemplatePG.SQL -- $intro diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 807edb4..2d87829 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -51,6 +51,7 @@ data PGState | StateIdle | StateTransaction | StateTransactionFailed + | StateClosed deriving (Show, Eq) -- |An established connection to the PostgreSQL server. @@ -83,13 +84,13 @@ type MessageFields = Map.Map Word8 L.ByteString -- See . data PGFrontendMessage = StartupMessage [(String, String)] -- only sent first - | CancelRequest Word32 Word32 -- sent first on separate connection + | CancelRequest !Word32 !Word32 -- sent first on separate connection | Bind { statementName :: String, bindParameters :: PGData } | Close { statementName :: String } -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). | Describe { statementName :: String } - | Execute Word32 + | Execute !Word32 | Flush -- |Parse SQL Destination (prepared statement) | Parse { statementName :: String, queryString :: String, parseTypes :: [OID] } @@ -262,6 +263,8 @@ getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where 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 <$> G.getLazyByteStringNul getMessageBody 'S' = liftM2 ParameterStatus getPGString getPGString getMessageBody 'D' = do @@ -350,13 +353,15 @@ pgConnect host port db user pass = do -- |Disconnect cleanly from the PostgreSQL server. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () -pgDisconnect c@PGConnection{ connHandle = h } = do +pgDisconnect c@PGConnection{ connHandle = h, connState = s } = do pgSend c Terminate + writeIORef s StateClosed hClose h pgSync :: PGConnection -> IO () pgSync c@PGConnection{ connState = sr } = do s <- readIORef sr + when (s == StateClosed) $ fail "pgSync: operation on closed connection" when (s == StateUnknown) $ do pgSend c Sync pgFlush c diff --git a/test/Main.hs b/test/Main.hs index cf1e9b2..995ea16 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import System.Environment (setEnv) import System.Exit (exitSuccess, exitFailure) import Database.TemplatePG +import Database.TemplatePG.Types (OID) import Connect assert :: Bool -> IO () @@ -14,10 +15,15 @@ assert True = return () useTHConnection connect +simple, simpleApply, prepared, preparedApply :: PGConnection -> OID -> IO [String] +simple c t = pgQuery c $(makePGSimpleQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1") +simpleApply c = pgQuery c . $(makePGSimpleQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = $1") +prepared c t = pgQuery c $(makePGPreparedQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1") +preparedApply c = pgQuery c . $(makePGPreparedQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = $1") + main :: IO () main = do c <- connect - _ <- $(queryTuples "SELECT typname from pg_type") c :: IO [String] z <- Time.getZonedTime let i = 1 b = True @@ -29,4 +35,13 @@ main = do Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l') <- $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval, {l}::text[]") c assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' && l == l' + + ["box"] <- simple c 603 + ["box"] <- simpleApply c 603 + ["box"] <- prepared c 603 + ["box"] <- preparedApply c 603 + ["line"] <- prepared c 628 + ["line"] <- preparedApply c 628 + + pgDisconnect c exitSuccess From eaea66e924e14f8ee5454285dfa06e342b34eb7f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 10:38:12 -0500 Subject: [PATCH 040/306] Change some type names to make exported interface cleaner --- Database/TemplatePG/Query.hs | 37 ++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 2cba305..2cfd541 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -5,8 +5,6 @@ module Database.TemplatePG.Query , pgQuery , PGSimpleQuery , PGPreparedQuery - , PGQueryParser - , pgRawParser , makePGSimpleQuery , makePGPreparedQuery ) where @@ -38,25 +36,28 @@ pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] pgQuery c q = snd <$> pgRunQuery c q -data PGSimpleQuery = PGSimpleQuery String -instance PGQuery PGSimpleQuery PGData where - pgRunQuery c (PGSimpleQuery sql) = pgSimpleQuery c sql +data SimpleQuery = SimpleQuery String +instance PGQuery SimpleQuery PGData where + pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql -data PGPreparedQuery = PGPreparedQuery String PGData -instance PGQuery PGPreparedQuery PGData where - pgRunQuery c (PGPreparedQuery sql bind) = pgPreparedQuery c sql bind +data PreparedQuery = PreparedQuery String PGData +instance PGQuery PreparedQuery PGData where + pgRunQuery c (PreparedQuery sql bind) = pgPreparedQuery c sql bind -data PGQueryParser q a b = PGQueryParser q (a -> b) -instance PGQuery q a => PGQuery (PGQueryParser q a b) b where - pgRunQuery c (PGQueryParser q p) = second (map p) <$> pgRunQuery c q +data QueryParser q a b = QueryParser q (a -> b) +instance PGQuery q a => PGQuery (QueryParser q a b) b where + pgRunQuery c (QueryParser q p) = second (map p) <$> pgRunQuery c q -instance Functor (PGQueryParser q a) where - fmap f (PGQueryParser q p) = PGQueryParser q (f . p) +instance Functor (QueryParser q a) where + fmap f (QueryParser q p) = QueryParser q (f . p) -pgRawParser :: q -> PGQueryParser q a a -pgRawParser q = PGQueryParser q id +idParser :: q -> QueryParser q a a +idParser q = QueryParser q id + +type PGSimpleQuery = QueryParser SimpleQuery +type PGPreparedQuery = QueryParser PreparedQuery -- |Given a result description, create a function to convert a result to a @@ -126,7 +127,7 @@ makePGQuery encf pgf sqle = do v <- TH.newName "p" (,) (TH.VarP v) . (`TH.AppE` TH.VarE v) <$> encf t) pt conv <- convertRow rt - foldl TH.AppE (TH.LamE vars $ TH.ConE 'PGQueryParser `TH.AppE` pgf sqlp vals `TH.AppE` conv) <$> mapM parse exprs + foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgf sqlp vals `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e @@ -135,8 +136,8 @@ makePGQuery encf pgf sqle = do -- This should be used as @$(makePGQuery \"SELECT ...\")@ makePGSimpleQuery :: String -> TH.Q TH.Exp makePGSimpleQuery = makePGQuery pgTypeEscaper $ \sql ps -> - TH.ConE 'PGSimpleQuery `TH.AppE` sqlSubstitute sql ps + TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sql ps makePGPreparedQuery :: String -> TH.Q TH.Exp makePGPreparedQuery = makePGQuery pgTypeEncoder $ \sql ps -> - TH.ConE 'PGPreparedQuery `TH.AppE` TH.LitE (TH.StringL sql) `TH.AppE` TH.ListE ps + TH.ConE 'PreparedQuery `TH.AppE` TH.LitE (TH.StringL sql) `TH.AppE` TH.ListE ps From 98123ba8ec80349ab50766e776e0639dfa098089 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 11:13:00 -0500 Subject: [PATCH 041/306] Add pgPreparedLazyQuery to retrieve rows lazily --- Database/TemplatePG/Protocol.hs | 67 ++++++++++++++++++++++++--------- Database/TemplatePG/Query.hs | 13 ++++++- 2 files changed, 61 insertions(+), 19 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 2d87829..5b74a84 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -14,6 +14,7 @@ module Database.TemplatePG.Protocol ( PGConnection , pgDescribe , pgSimpleQuery , pgPreparedQuery + , pgPreparedLazyQuery , pgCloseQuery , pgAddType , getTypeOID @@ -44,6 +45,7 @@ import Data.Word (Word8, Word32) import Network (HostName, PortID, connectTo) import System.Environment (lookupEnv) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) +import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) data PGState @@ -298,6 +300,9 @@ pgReceive c@PGConnection{ connHandle = h, connDebug = d } = do writeIORef (connState c) StateUnknown >> throwIO (PGError m) _ -> return msg +pgHandle :: PGConnection -> (PGBackendMessage -> IO a) -> IO a +pgHandle c = (pgReceive c >>=) + -- |Connect to a PostgreSQL server. pgConnect :: HostName -- ^ the host to connect to -> PortID -- ^ the port to connect on @@ -333,7 +338,7 @@ pgConnect host port db user pass = do pgFlush c conn c where - conn c = msg c =<< pgReceive c + conn c = pgHandle c (msg c) msg c (ReadyForQuery _) = return c 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 } @@ -443,7 +448,7 @@ pgSimpleQuery h sql = do pgSend h $ SimpleQuery sql pgFlush h go start where - go = (>>=) $ pgReceive h + go = pgHandle h start (CommandComplete c) = got c start (RowDescription _) = go row start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m @@ -455,12 +460,8 @@ pgSimpleQuery h sql = do end EmptyQueryResponse = go end end m = fail $ "pgSimpleQuery: unexpected message: " ++ show m --- |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 - -> PGData -- ^ Paremeters to bind to placeholders - -> IO (Int, [PGData]) -pgPreparedQuery c@PGConnection{ connPreparedStatements = psr } sql bind = do +pgPreparedBind :: PGConnection -> String -> PGData -> IO (IO ()) +pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql bind = do pgSync c (p, n) <- atomicModifyIORef' psr $ \(i, m) -> maybe ((succ i, m), (False, i)) ((,) (i, m) . (,) True) $ Map.lookup sql m @@ -468,23 +469,55 @@ pgPreparedQuery c@PGConnection{ connPreparedStatements = psr } sql bind = do unless p $ pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = [] } pgSend c $ Bind{ statementName = sn, bindParameters = bind } - pgSend c $ Execute 0 - pgSend c $ Flush - pgFlush c let + go = pgHandle c start start ParseComplete = do modifyIORef psr $ \(i, m) -> (i, Map.insert sql n m) - go start - start BindComplete = go row - start m = fail $ "pgPreparedQuery: unexpected response: " ++ show m - go start + go + start BindComplete = return () + start m = fail $ "pgPrepared: unexpected response: " ++ show m + return go + +-- |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 + -> PGData -- ^ Paremeters to bind to placeholders + -> IO (Int, [PGData]) +pgPreparedQuery c sql bind = do + start <- pgPreparedBind c sql bind + pgSend c $ Execute 0 + pgSend c $ Flush + pgFlush c + start + go where - go = (>>=) $ pgReceive c - row (DataRow fs) = second (fs:) <$> go row + go = pgHandle c row + row (DataRow fs) = second (fs:) <$> go row (CommandComplete r) = return (rowsAffected r, []) row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m +pgPreparedLazyQuery :: PGConnection -> String -- ^ SQL statement with placeholders + -> PGData -- ^ Paremeters to bind to placeholders + -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) + -> IO [PGData] +pgPreparedLazyQuery c sql bind count = do + start <- pgPreparedBind c sql bind + unsafeInterleaveIO $ do + execute + start + go + where + execute = do + pgSend c $ Execute count + pgSend c $ Flush + pgFlush c + go = pgHandle c row + row (DataRow fs) = (fs:) <$> go + row PortalSuspended = unsafeInterleaveIO (execute >> go) + row (CommandComplete _) = return [] + row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m + -- |Close a previously prepared query (if necessary). pgCloseQuery :: PGConnection -> String -- ^ SQL statement with placeholders -> IO () diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 2cfd541..2a9a2d8 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -3,6 +3,7 @@ module Database.TemplatePG.Query ( PGQuery(..) , pgExecute , pgQuery + , pgLazyQuery , PGSimpleQuery , PGPreparedQuery , makePGSimpleQuery @@ -15,6 +16,7 @@ import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) import Data.Char (isDigit) import Data.Maybe (fromMaybe) +import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH import Numeric (readDec) @@ -56,9 +58,16 @@ instance Functor (QueryParser q a) where idParser :: q -> QueryParser q a a idParser q = QueryParser q id -type PGSimpleQuery = QueryParser SimpleQuery -type PGPreparedQuery = QueryParser PreparedQuery +type PGSimpleQuery = QueryParser SimpleQuery PGData +type PGPreparedQuery = QueryParser PreparedQuery PGData +-- |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-at-once) + -> IO [a] +pgLazyQuery c (QueryParser (PreparedQuery sql bind) p) count = + fmap p <$> pgPreparedLazyQuery c sql bind count -- |Given a result description, create a function to convert a result to a -- tuple. From 0c17ce34c8bf51dfeed233eb9e8f4ce31ca9605a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 11:17:25 -0500 Subject: [PATCH 042/306] Add rawPG*Query for direct creation of un-templated queries --- Database/TemplatePG/Query.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 2a9a2d8..044fcdb 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -1,13 +1,15 @@ {-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} module Database.TemplatePG.Query ( PGQuery(..) - , pgExecute - , pgQuery - , pgLazyQuery , PGSimpleQuery , PGPreparedQuery + , rawPGSimpleQuery + , rawPGPreparedQuery , makePGSimpleQuery , makePGPreparedQuery + , pgExecute + , pgQuery + , pgLazyQuery ) where import Control.Applicative ((<$>)) @@ -61,6 +63,14 @@ idParser q = QueryParser q id type PGSimpleQuery = QueryParser SimpleQuery PGData type PGPreparedQuery = QueryParser PreparedQuery PGData +-- Make a simple query directly from a query string, with no type inference +rawPGSimpleQuery :: String -> PGSimpleQuery PGData +rawPGSimpleQuery = idParser . SimpleQuery + +-- Make a prepared query directly from a query string and bind parameters, with no type inference +rawPGPreparedQuery :: String -> PGData -> PGPreparedQuery PGData +rawPGPreparedQuery sql = idParser . PreparedQuery sql + -- |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.) From 7e846eb6b276f5b0a0ee6922f5e816df5c7c14ab Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 16:28:49 -0500 Subject: [PATCH 043/306] Bump version and update documentation --- Database/TemplatePG.hs | 232 +++++++++++++++++++++-------------- Database/TemplatePG/Query.hs | 3 +- Database/TemplatePG/SQL.hs | 8 +- Database/TemplatePG/Types.hs | 2 +- README | 4 +- templatepg.cabal | 2 +- 6 files changed, 151 insertions(+), 100 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 5af5bd2..17e0089 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -1,44 +1,64 @@ -- Copyright 2010, 2011, 2012, 2013 Chris Forno +-- Copyright 2014 Dylan Simon -module Database.TemplatePG (-- *Introduction - -- $intro +module Database.TemplatePG + ( + -- *Introduction + -- $intro - -- *Usage - -- $usage + PGError(..) - -- **Compile-Time Parameters - -- $compiletime + -- *Usage + -- $usage - -- *Caveats - -- $caveats + -- **Connections + -- $connect - -- *Limitations and Workarounds - -- **A Note About NULL - -- $nulls + , PGConnection + , pgConnect + , pgDisconnect + , useTHConnection - -- **Tips - -- $tips + -- **Queries + -- $query + + -- ***Compile time + -- $compile + , makePGSimpleQuery + , makePGPreparedQuery - -- **Other Workarounds - -- $other - PGError(..) - , PGConnection - , pgConnect - , pgDisconnect - , useTHConnection - , registerPGType + -- ***Runtime + -- $run + , pgQuery + , pgExecute - , makePGSimpleQuery - , makePGPreparedQuery - , pgQuery - , pgExecute + -- **Basic queries + -- $basic - , queryTuples - , queryTuple - , execute - , withTransaction - , rollback - , insertIgnore ) where + , queryTuples + , queryTuple + , execute + -- *Advanced usage + + -- **Types + -- $types + + , registerPGType + + -- **A Note About NULL + -- $nulls + + -- *Caveats + -- $caveats + + , withTransaction + , rollback + , insertIgnore + + -- **Tips + -- $tips + + ) where import Database.TemplatePG.Protocol import Database.TemplatePG.Connection @@ -60,25 +80,80 @@ import Database.TemplatePG.SQL -- While compile-time query analysis eliminates many errors, it doesn't -- eliminate all of them. If you modify the database without recompilation or -- have an error in a trigger or function, for example, you can still trigger a --- 'PGException'. --- --- With that in mind, TemplatePG currently does a number of unsafe things. It --- doesn't properly close the connection with the PostgreSQL server. It doesn't --- handle unexpected messages from the server very gracefully, and it's not --- entirely safe when working with nullable result fields. I hope to fix all of --- these at some point in the future. In the meantime, use the software at your --- own risk. Note however that TemplatePG is currently powering +-- 'PGException' or other failure (if types change). Also, nullable result fields resulting from outer joins are not +-- detected and need to be handled specially. +-- +-- Use the software at your own risk. Note however that TemplatePG is currently powering -- with no problems yet. (For usage examples, you -- can see the Vocabulink source code at ). --- --- To improve performance, TemplatePG does not use prepared statements. In --- theory, this saves bandwidth (and a potential round-trip) and time for the --- extra step of binding parameters. Again in theory, this is also safe because --- we know the types of parameters at compile time. However, it still feels --- risky (and I would appreciate any audit of the code doing this, especially --- 'escapeString'). -- $usage +-- Basic usage consists of calling 'pgConnect', 'makePGSimpleQuery' (Template Haskell), 'pgQuery', and 'pgDisconnect': +-- +-- @ +-- c <- pgConnect +-- let name = \"Joe\" +-- people :: [Int32] <- pgQuery c $(makePGSimpleQuery "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, TemplatePG needs to make its own connection to the database in order to describe queries. +-- By default, it will use the following environment variables. You must set at least @TPG_DB@: +-- +-- [@TPG_DB@] the database name to use +-- +-- [@TPG_USER@] the username to connect as (default: @postgres@) +-- +-- [@TPG_PASS@] the password to use (default: /empty/) +-- +-- [@TPG_HOST@] the host to connect to (default: @localhost@) +-- +-- [@TPG_PORT@ 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 function to perform type-inference at compile time and create a 'PGQuery' ('makePGSimpleQuery', 'makePGPreparedQuery'); 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 = $(makePGSimpleQuery \"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: +-- +-- @$(makePGSimpleQuery \"SELECT id FROM people WHERE name = $1\") :: String -> PGSimpleQuery [Int32]@ +-- +-- 'makePGPreparedQuery' works identically, but produces 'PGPreparedQuery' objects instead. +-- 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'.) + +-- $basic +-- There is also an older, simpler interface that combines both the compile and runtime steps. -- 'queryTuples' does all the work ('queryTuple' and 'execute' are convenience -- functions). -- @@ -98,47 +173,21 @@ import Database.TemplatePG.SQL -- -- tuples <- $(queryTuples \"SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int32}\") h -- @ --- --- Note that parameters may only be used where PostgreSQL will allow them. This --- will not work: --- --- @tuples <- $(queryTuples \"SELECT * FROM {tableName}\") h@ --- --- The types of any parameter expressions must be fully known. This may --- require explicit casts in some cases. --- --- And in general, you cannot construct queries at run-time, since they --- wouldn't be available to be analyzed at compile time. --- $compiletime --- TemplatePG needs information about the database to connect to at compile --- time (in the form of environment variables). --- --- You must set at least @TPG_DB@: --- --- [@TPG_DB@] the database name to use --- --- [@TPG_USER@] the username to connect as (default: @postgres@) --- --- [@TPG_PASS@] the password to use (default: /empty/) --- --- [@TPG_HOST@] the host to connect to (default: @localhost@) --- --- [@TPG_PORT@] the port number to connect on (default: @5432@) --- --- You can set @TPG_DEBUG@ to get a rough protocol-level trace (pipe to --- @hexdump@). - --- $caveats --- TemplatePG assumes that it has a UTF-8 connection to a UTF-8 database. +-- $types +-- All supported types have instances of the 'PGType' class. +-- For the most part, only exactly equivalent types are used (e.g., 'Int32' for int4). +-- However, you can add support for your own types or replace the existing types just by making a new instance of 'PGType' and calling 'registerPGType' at the top level: -- --- TemplatePG does not bind parameters with prepared statements (at run-time), --- instead it relies on its own type conversion and string escaping. The --- technique might have a security vulnerability. You should also set --- @standard_conforming_strings = on@ in your @postgresql.conf@. --- --- I've included 'withTransaction', 'rollback', and 'insertIgnore', but they've --- not been thoroughly tested, so use them at your own risk. +-- @ +-- instance PGType MyType where ... +-- registerPGType \"mytype\" ''MyType +-- @ +-- +-- This will cause the PostgreSQL type @mytype@ to be converted to/from @MyType@. +-- Only one 'PGType' may be registered per PostgreSQL type, but the same 'PGType' may serve multiple PostgreSQL types. +-- This also automatically registers a handler for @_mytype@ (the PostgreSQL name for a vector or array of @mytype@) to @[Maybe MyType]@. +-- Like 'useTHConnection', this must be evaluated before any use of the type. -- $nulls -- Sometimes TemplatePG cannot determine whether or not a result field can @@ -158,10 +207,15 @@ import Database.TemplatePG.SQL -- placeholders can't be used in place of lists in PostgreSQL (such as @IN -- (?)@), it's not currently possible to use non-static @IN ()@ clauses. --- $other --- There's no support for reading time intervals yet. As a workaround, you can --- use @extract(epoch from ...)::int@ to get the interval as a number of --- seconds. +-- $caveats +-- I've included 'withTransaction', 'rollback', and 'insertIgnore', but they've +-- not been thoroughly tested, so use them at your own risk. +-- +-- The types of any parameter expressions must be fully known. This may +-- require explicit casts in some cases. +-- +-- And in general, you cannot construct queries at run-time, since they +-- wouldn't be available to be analyzed at compile time. -- $tips -- If you find yourself pattern matching on result tuples just to pass them on diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 044fcdb..9b192a9 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -28,6 +28,7 @@ import Database.TemplatePG.Protocol import Database.TemplatePG.Connection class PGQuery q a | q -> a where + -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results. pgRunQuery :: PGConnection -> q -> IO (Int, [a]) -- |Execute a query that does not return result. @@ -74,7 +75,7 @@ rawPGPreparedQuery sql = idParser . PreparedQuery sql -- |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-at-once) +pgLazyQuery :: PGConnection -> PGPreparedQuery a -> Word32 -- ^ Chunk size (1 is common, 0 is all-or-nothing) -> IO [a] pgLazyQuery c (QueryParser (PreparedQuery sql bind) p) count = fmap p <$> pgPreparedLazyQuery c sql bind count diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 784332d..de0ff6e 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -37,9 +37,7 @@ querySQL "" = "" -- -- Example (where @h@ is a handle from 'pgConnect'): -- --- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h --- --- => IO [(Maybe String, Maybe Integer)] +-- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h :: IO [(Maybe String, Maybe Integer)] -- @ queryTuples :: String -> Q Exp queryTuples sql = [| \c -> pgQuery c $(makePGSimpleQuery $ querySQL sql) |] @@ -53,9 +51,7 @@ queryTuples sql = [| \c -> pgQuery c $(makePGSimpleQuery $ querySQL sql) |] -- -- @let sysid = 10::Integer; -- --- $(queryTuple \"SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}\") h --- --- => IO (Maybe (Maybe String, Maybe Integer)) +-- $(queryTuple \"SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}\") h :: IO (Maybe (Maybe String, Maybe Integer)) -- @ queryTuple :: String -> Q Exp queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index de54600..c48426b 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -296,7 +296,7 @@ instance PGType a => PGType (Maybe a) where pgLiteral = maybe "NULL" pgLiteral -} -class PGType a => PossiblyMaybe m a {- | m -> a -} where +class PGType a => PossiblyMaybe m a {- ideally should have fundep: | m -> a -} where possiblyMaybe :: m -> Maybe a maybePossibly :: Maybe a -> m diff --git a/README b/README index 4f0b2b3..dc722ff 100644 --- a/README +++ b/README @@ -2,9 +2,9 @@ TemplatePG is designed with 2 goals in mind: safety and performance. The primary To help ensure safety, it uses the PostgreSQL server to parse every query and statement in your code to infer types at compile-time. This means that in theory you cannot get a syntax error at runtime. Getting proper types at compile time has the nice side-effect that it eliminates run-time type casting and usually results in less code. This approach was inspired by MetaHDBC (http://haskell.org/haskellwiki/MetaHDBC) and PG'OCaml (http://pgocaml.berlios.de/). -While compile-time query analysis eliminates many errors, it doesn't eliminate all of them. If you modify the database without recompilation or have an error in a trigger or function, for example, you can still trigger a PGException. +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. Also, nullable result fields resulting from outer joins are not detected and need to be handled specially. -With that in mind, TemplatePG currently does a number of unsafe things. It doesn't properly close the connection with the PostgreSQL server. It doesn't handle unexpected messages from the server very gracefully, and it's not entirely safe when working with nullable result fields. I hope to fix all of these at some point in the future. In the meantime, use the software at your own risk. Note however that TemplatePG is currently powering http://www.vocabulink.com/ with no problems yet. (For usage examples, you can see the Vocabulink source code at http://jekor.com/vocabulink/vocabulink.tar.gz). +Use the software at your own risk. Note however that TemplatePG is currently powering http://www.vocabulink.com/ with no problems yet. (For usage examples, you can see the Vocabulink source code at http://jekor.com/vocabulink/vocabulink.tar.gz). To improve performance, TemplatePG does not use prepared statements. In theory, this saves bandwidth (and a potential round-trip) and time for the extra step of binding parameters. Again in theory, this is also safe because we know the types of parameters at compile time. However, it still feels risky (and I would appreciate any audit of the code doing this, especially escapeString). diff --git a/templatepg.cabal b/templatepg.cabal index c486529..6089197 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -1,5 +1,5 @@ Name: templatepg -Version: 0.2.6 +Version: 0.3.0 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From b67b1cd250ad1d1c8ff9c4408f005fb2468595be Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 19:01:28 -0500 Subject: [PATCH 044/306] Promote some TH utils to top level --- Database/TemplatePG/Query.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 9b192a9..033d545 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -126,17 +126,21 @@ sqlSubstitute sql exprl = se sql where | inRange bnds n = exprs ! n | otherwise = error $ "SQL placeholder '$" ++ show n ++ "' out of range (not recognized by PostgreSQL); literal occurances may need to be escaped with '$$'" - se = uncurry ((+$+) . lit) . ss + 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 "" = ("", lit "") + ss "" = ("", stringL "") - lit = TH.LitE . TH.StringL - TH.LitE (TH.StringL "") +$+ e = e - e +$+ TH.LitE (TH.StringL "") = e - TH.LitE (TH.StringL l) +$+ TH.LitE (TH.StringL r) = lit (l ++ r) - l +$+ r = TH.InfixE (Just l) (TH.VarE '(++)) (Just r) +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) makePGQuery :: (PGTypeHandler -> TH.ExpQ) -> (String -> [TH.Exp] -> TH.Exp) -> String -> TH.ExpQ -- ^ a PGQuery makePGQuery encf pgf sqle = do @@ -160,4 +164,4 @@ makePGSimpleQuery = makePGQuery pgTypeEscaper $ \sql ps -> makePGPreparedQuery :: String -> TH.Q TH.Exp makePGPreparedQuery = makePGQuery pgTypeEncoder $ \sql ps -> - TH.ConE 'PreparedQuery `TH.AppE` TH.LitE (TH.StringL sql) `TH.AppE` TH.ListE ps + TH.ConE 'PreparedQuery `TH.AppE` stringL sql `TH.AppE` TH.ListE ps From 9d675b2d0a3410e5b29b5cde0a73cc1b8d01f0d1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 19:34:41 -0500 Subject: [PATCH 045/306] Eliminate unnecessary generality (type var) of QueryParser --- Database/TemplatePG/Query.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 033d545..cd324cd 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -30,6 +30,7 @@ import Database.TemplatePG.Connection class PGQuery q a | q -> a where -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results. pgRunQuery :: PGConnection -> q -> IO (Int, [a]) +class PGQuery q PGData => PGRawQuery q -- |Execute a query that does not return result. -- Return the number of rows affected (or -1 if not known). @@ -44,33 +45,35 @@ pgQuery c q = snd <$> pgRunQuery c q data SimpleQuery = SimpleQuery String instance PGQuery SimpleQuery PGData where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql +instance PGRawQuery SimpleQuery where data PreparedQuery = PreparedQuery String PGData instance PGQuery PreparedQuery PGData where pgRunQuery c (PreparedQuery sql bind) = pgPreparedQuery c sql bind +instance PGRawQuery PreparedQuery where -data QueryParser q a b = QueryParser q (a -> b) -instance PGQuery q a => PGQuery (QueryParser q a b) b where +data QueryParser q a = QueryParser q (PGData -> a) +instance PGRawQuery q => PGQuery (QueryParser q a) a where pgRunQuery c (QueryParser q p) = second (map p) <$> pgRunQuery c q -instance Functor (QueryParser q a) where +instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (f . p) -idParser :: q -> QueryParser q a a -idParser q = QueryParser q id +rawParser :: q -> QueryParser q PGData +rawParser q = QueryParser q id -type PGSimpleQuery = QueryParser SimpleQuery PGData -type PGPreparedQuery = QueryParser PreparedQuery PGData +type PGSimpleQuery = QueryParser SimpleQuery +type PGPreparedQuery = QueryParser PreparedQuery -- Make a simple query directly from a query string, with no type inference rawPGSimpleQuery :: String -> PGSimpleQuery PGData -rawPGSimpleQuery = idParser . SimpleQuery +rawPGSimpleQuery = rawParser . SimpleQuery -- Make a prepared query directly from a query string and bind parameters, with no type inference rawPGPreparedQuery :: String -> PGData -> PGPreparedQuery PGData -rawPGPreparedQuery sql = idParser . PreparedQuery sql +rawPGPreparedQuery sql = rawParser . PreparedQuery sql -- |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. From 2c2e582bf6d81fd2b46f1b769c4333b9d8548398 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 19:57:29 -0500 Subject: [PATCH 046/306] Fix documentation for registerPGType --- Database/TemplatePG.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 17e0089..1470ac0 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -181,7 +181,7 @@ import Database.TemplatePG.SQL -- -- @ -- instance PGType MyType where ... --- registerPGType \"mytype\" ''MyType +-- registerPGType \"mytype\" (Language.Haskell.TH.ConT ''MyType) -- @ -- -- This will cause the PostgreSQL type @mytype@ to be converted to/from @MyType@. From ff56b087db2f2eaf63dfdff3d2e72fcf84454562 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 20:55:35 -0500 Subject: [PATCH 047/306] Make SQL.execute :: IO () for backwards compatibility --- Database/TemplatePG/SQL.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index de0ff6e..4c85ecb 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -67,7 +67,7 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- $(execute \"CREATE ROLE {rolename}\") h -- @ execute :: String -> Q Exp -execute sql = [| \c -> pgExecute c $(makePGSimpleQuery $ querySQL sql) |] +execute sql = [| \c -> void $ pgExecute c $(makePGSimpleQuery $ 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' From ccf3fd5891188e74aaf432b2f21ff3993763e8b8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 21:21:12 -0500 Subject: [PATCH 048/306] Add nullable result versions of query builders --- Database/TemplatePG/Query.hs | 53 ++++++++++++++++++++++++------------ 1 file changed, 36 insertions(+), 17 deletions(-) diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index cd324cd..19e478e 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -6,7 +6,9 @@ module Database.TemplatePG.Query , rawPGSimpleQuery , rawPGPreparedQuery , makePGSimpleQuery + , makePGSimpleQuery' , makePGPreparedQuery + , makePGPreparedQuery' , pgExecute , pgQuery , pgLazyQuery @@ -64,14 +66,16 @@ instance Functor (QueryParser q) where rawParser :: q -> QueryParser q PGData rawParser q = QueryParser q 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 +-- |Make a simple query directly from a query string, with no type inference rawPGSimpleQuery :: String -> PGSimpleQuery PGData rawPGSimpleQuery = rawParser . SimpleQuery --- Make a prepared query directly from a query string and bind parameters, with no type inference +-- |Make a prepared query directly from a query string and bind parameters, with no type inference rawPGPreparedQuery :: String -> PGData -> PGPreparedQuery PGData rawPGPreparedQuery sql = rawParser . PreparedQuery sql @@ -85,12 +89,12 @@ pgLazyQuery c (QueryParser (PreparedQuery sql bind) p) count = -- |Given a result description, create a function to convert a result to a -- tuple. -convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description +convertRow :: Bool -> [(String, PGTypeHandler, Bool)] -- ^ result description -> TH.Q TH.Exp -- ^ A function for converting a row of the given result description -convertRow types = do +convertRow nulls types = do (pats, conv) <- mapAndUnzipM (\t@(n, _, _) -> do v <- TH.newName n - return (TH.varP v, convertColumn (TH.varE v) t)) types + return (TH.varP v, convertColumn nulls (TH.varE v) t)) types TH.lamE [TH.listP pats] $ TH.tupE conv -- |Given a raw PostgreSQL result and a result field type, convert the @@ -100,11 +104,11 @@ convertRow types = do -- and we can use 'fromJust' to keep the code simple. If it's 'True', then we -- don't know if the value is nullable and must return a 'Maybe' value in case -- it is. -convertColumn :: TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') +convertColumn :: Bool -> TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') -> (String, PGTypeHandler, Bool) -- ^ the result field type -> TH.ExpQ -convertColumn v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $ "Unexpected NULL value in " ++ n) $(v)) |] -convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] +convertColumn False v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] +convertColumn _ v (_, t, _) = [| fmap $(pgTypeDecoder t) $(v) |] -- |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 @$${@. @@ -145,26 +149,41 @@ 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) -makePGQuery :: (PGTypeHandler -> TH.ExpQ) -> (String -> [TH.Exp] -> TH.Exp) -> String -> TH.ExpQ -- ^ a PGQuery -makePGQuery encf pgf sqle = do +makeQuery :: Bool -> (PGTypeHandler -> TH.ExpQ) -> (String -> [TH.Exp] -> TH.Exp) -> String -> TH.ExpQ -- ^ a PGQuery +makeQuery nulls encf pgf sqle = do (pt, rt) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurances of '${' may need to be escaped with '$${'" (vars, vals) <- mapAndUnzipM (\t -> do v <- TH.newName "p" (,) (TH.VarP v) . (`TH.AppE` TH.VarE v) <$> encf t) pt - conv <- convertRow rt + conv <- convertRow nulls rt foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgf sqlp vals `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e --- |Produce a new PGQuery from a SQL query string. --- This should be used as @$(makePGQuery \"SELECT ...\")@ -makePGSimpleQuery :: String -> TH.Q TH.Exp -makePGSimpleQuery = makePGQuery pgTypeEscaper $ \sql ps -> +makeSimpleQuery :: Bool -> String -> TH.Q TH.Exp +makeSimpleQuery nulls = makeQuery nulls pgTypeEscaper $ \sql ps -> TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sql ps -makePGPreparedQuery :: String -> TH.Q TH.Exp -makePGPreparedQuery = makePGQuery pgTypeEncoder $ \sql ps -> +makePreparedQuery :: Bool -> String -> TH.Q TH.Exp +makePreparedQuery nulls = makeQuery nulls pgTypeEncoder $ \sql ps -> TH.ConE 'PreparedQuery `TH.AppE` stringL sql `TH.AppE` TH.ListE ps + +-- |Produce a new 'PGSimpleQuery' from a SQL query string. +-- This should be used as @$(makePGSimpleQuery \"SELECT ...\")@ +makePGSimpleQuery :: String -> TH.Q TH.Exp +makePGSimpleQuery = makeSimpleQuery False + +-- |Like 'makePGSimpleQuery' but treats all results as nullable ('Maybe'). +makePGSimpleQuery' :: String -> TH.Q TH.Exp +makePGSimpleQuery' = makeSimpleQuery True + +-- |Like 'makePGSimpleQuery' but produce a 'PGPreparedQuery' instead. +makePGPreparedQuery :: String -> TH.Q TH.Exp +makePGPreparedQuery = makePreparedQuery False + +-- |Like 'makePGPreparedQuery' but treats all results as nullable ('Maybe'). +makePGPreparedQuery' :: String -> TH.Q TH.Exp +makePGPreparedQuery' = makePreparedQuery True From ed90ccb9058f8f4aa1c1709ed699ea63549ec07e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Dec 2014 23:46:03 -0500 Subject: [PATCH 049/306] Switch to quasi-quoting So much more concise! --- Database/TemplatePG.hs | 28 ++++----- Database/TemplatePG/Protocol.hs | 58 ++++++++++-------- Database/TemplatePG/Query.hs | 102 +++++++++++++++++++------------- Database/TemplatePG/SQL.hs | 4 +- templatepg.cabal | 2 +- test/Main.hs | 8 +-- 6 files changed, 115 insertions(+), 87 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 1470ac0..b607853 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -24,8 +24,7 @@ module Database.TemplatePG -- ***Compile time -- $compile - , makePGSimpleQuery - , makePGPreparedQuery + , pgSQL -- ***Runtime -- $run @@ -88,12 +87,13 @@ import Database.TemplatePG.SQL -- can see the Vocabulink source code at ). -- $usage --- Basic usage consists of calling 'pgConnect', 'makePGSimpleQuery' (Template Haskell), 'pgQuery', and 'pgDisconnect': +-- 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 $(makePGSimpleQuery "SELECT id FROM people WHERE name = ${name}") +-- people :: [Int32] <- pgQuery c [pgSQL|SELECT id FROM people WHERE name = ${name}|] -- pgDisconnect c -- @ @@ -125,20 +125,20 @@ import Database.TemplatePG.SQL -- 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 function to perform type-inference at compile time and create a 'PGQuery' ('makePGSimpleQuery', 'makePGPreparedQuery'); and a run-time function to execute the query ('pgRunQuery', 'pgQuery', 'pgExecute'). +-- 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 = $(makePGSimpleQuery \"SELECT id, name, address FROM people WHERE name LIKE ${query++\\\"%\\\"} OR email LIKE $1") :: PGSimpleQuery [(Int32, String, Maybe String)]@ +-- @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: -- --- @$(makePGSimpleQuery \"SELECT id FROM people WHERE name = $1\") :: String -> PGSimpleQuery [Int32]@ +-- @[pgSQL|SELECT id FROM people WHERE name = $1|] :: String -> PGSimpleQuery [Int32]@ -- --- 'makePGPreparedQuery' works identically, but produces 'PGPreparedQuery' objects instead. +-- 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 @@ -177,6 +177,7 @@ import Database.TemplatePG.SQL -- $types -- All supported types have instances of the 'PGType' class. -- For the most part, only exactly equivalent types are used (e.g., 'Int32' for int4). +-- (You can also use @[pgSQL|int4|]@ to substitute the equivalent Haskell type.) -- However, you can add support for your own types or replace the existing types just by making a new instance of 'PGType' and calling 'registerPGType' at the top level: -- -- @ @@ -200,22 +201,21 @@ import Database.TemplatePG.SQL -- -- Nullability is indicated incorrectly in the case of outer joins. TemplatePG -- incorrectly infers that a field cannot be @NULL@ when it's able to trace the --- result field back to a non-@NULL@ table column. As a workround, you can wrap --- columns with @COALESCE()@ to force them to be returned as 'Maybe' values. +-- result field back to a non-@NULL@ table column. You can disable nullability inference by prepending your query with '?' to assume all columns are nullable. -- -- Because TemplatePG has to prepare statements at compile time and -- placeholders can't be used in place of lists in PostgreSQL (such as @IN --- (?)@), it's not currently possible to use non-static @IN ()@ clauses. +-- (?)@), you must replace such cases with equivalent arrays (@= ANY (?)@). -- $caveats -- I've included 'withTransaction', 'rollback', and 'insertIgnore', but they've -- not been thoroughly tested, so use them at your own risk. -- -- The types of any parameter expressions must be fully known. This may --- require explicit casts in some cases. +-- require explicit casts in some cases (especially with numeric literals). -- --- And in general, you cannot construct queries at run-time, since they --- wouldn't be available to be analyzed at compile time. +-- 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 that call 'makePGQuery'). -- $tips -- If you find yourself pattern matching on result tuples just to pass them on diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 5b74a84..7e088bf 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -18,6 +18,7 @@ module Database.TemplatePG.Protocol ( PGConnection , pgCloseQuery , pgAddType , getTypeOID + , getPGType ) where import Database.TemplatePG.Types @@ -37,6 +38,7 @@ import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (foldMap, forM_) import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) +import Data.List (find) import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) import Data.Monoid (mempty, (<>)) @@ -377,12 +379,16 @@ pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) -getTypeOID c t = do - (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t) - case r of - [] -> return Nothing - [[Just o, Just lo]] -> return (Just (pgDecodeBS o, pgDecodeBS lo)) - _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r +getTypeOID c@PGConnection{ connTypes = types } t + | Just oid <- findType t = return $ Just (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of + | otherwise = do + (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) + case r of + [] -> return Nothing + [[Just o, Just lo]] -> return (Just (pgDecodeBS o, pgDecodeBS lo)) + _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r + where + findType n = fmap fst $ find ((==) n . pgTypeName . snd) $ Map.toList types getPGType :: PGConnection -> OID -> IO PGTypeHandler getPGType c@PGConnection{ connTypes = types } oid = @@ -398,8 +404,9 @@ getPGType c@PGConnection{ connTypes = types } oid = -- 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 + -> Bool -- ^ Guess nullability, otherwise assume everything is -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. -pgDescribe h sql = do +pgDescribe h sql nulls = do pgSync h pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = [] } pgSend h $ Describe "" @@ -412,25 +419,24 @@ pgDescribe h sql = do NoData -> return [] RowDescription r -> mapM desc r _ -> fail $ "describeStatement: unexpected response: " ++ show m - where - desc (ColDescription name tab col typ) = do - t <- getPGType h typ - n <- nullable tab col - return (name, t, n) - nullable oid col = - -- We don't get nullability indication from PostgreSQL, at least not - -- directly. - if oid == 0 - -- Without any hints, we have to assume that the result can be null and - -- leave it up to the developer to figure it out. - then return True - -- In cases where the resulting field is tracable to the column of a - -- table, we can check there. - else do (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) - case r of - [[Just s]] -> return $ not $ pgDecodeBS s - [] -> return True - _ -> fail $ "Failed to determine nullability of column #" ++ show col + where + desc (ColDescription name tab col typ) = do + t <- getPGType h typ + n <- nullable tab col + return (name, t, 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 = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) + case r of + [[Just s]] -> return $ not $ pgDecodeBS s + [] -> return True + _ -> fail $ "Failed to determine nullability of column #" ++ show col + | otherwise = return True rowsAffected :: L.ByteString -> Int rowsAffected = ra . LC.words where diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 19e478e..4280029 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -5,10 +5,10 @@ module Database.TemplatePG.Query , PGPreparedQuery , rawPGSimpleQuery , rawPGPreparedQuery - , makePGSimpleQuery - , makePGSimpleQuery' - , makePGPreparedQuery - , makePGPreparedQuery' + , QueryFlags(..) + , simpleFlags + , makePGQuery + , pgSQL , pgExecute , pgQuery , pgLazyQuery @@ -23,6 +23,7 @@ import Data.Maybe (fromMaybe) 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.TemplatePG.Types @@ -89,12 +90,12 @@ pgLazyQuery c (QueryParser (PreparedQuery sql bind) p) count = -- |Given a result description, create a function to convert a result to a -- tuple. -convertRow :: Bool -> [(String, PGTypeHandler, Bool)] -- ^ result description +convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description -> TH.Q TH.Exp -- ^ A function for converting a row of the given result description -convertRow nulls types = do +convertRow types = do (pats, conv) <- mapAndUnzipM (\t@(n, _, _) -> do v <- TH.newName n - return (TH.varP v, convertColumn nulls (TH.varE v) t)) types + return (TH.varP v, convertColumn (TH.varE v) t)) types TH.lamE [TH.listP pats] $ TH.tupE conv -- |Given a raw PostgreSQL result and a result field type, convert the @@ -104,11 +105,11 @@ convertRow nulls types = do -- and we can use 'fromJust' to keep the code simple. If it's 'True', then we -- don't know if the value is nullable and must return a 'Maybe' value in case -- it is. -convertColumn :: Bool -> TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') +convertColumn :: TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') -> (String, PGTypeHandler, Bool) -- ^ the result field type -> TH.ExpQ -convertColumn False v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] -convertColumn _ v (_, t, _) = [| fmap $(pgTypeDecoder t) $(v) |] +convertColumn v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] +convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] -- |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 @$${@. @@ -149,41 +150,62 @@ 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) -makeQuery :: Bool -> (PGTypeHandler -> TH.ExpQ) -> (String -> [TH.Exp] -> TH.Exp) -> String -> TH.ExpQ -- ^ a PGQuery -makeQuery nulls encf pgf sqle = do - (pt, rt) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp +data QueryFlags = QueryFlags + { flagNullable :: Bool + , flagPrepared :: Bool + } + +simpleFlags :: QueryFlags +simpleFlags = QueryFlags False False + +makePGQuery :: QueryFlags -> String -> TH.ExpQ +makePGQuery QueryFlags{ flagNullable = nulls, flagPrepared = prep } sqle = do + (pt, rt) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp (not nulls) when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurances of '${' may need to be escaped with '$${'" (vars, vals) <- mapAndUnzipM (\t -> do v <- TH.newName "p" (,) (TH.VarP v) . (`TH.AppE` TH.VarE v) <$> encf t) pt - conv <- convertRow nulls rt - foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgf sqlp vals `TH.AppE` conv) <$> mapM parse exprs + conv <- convertRow rt + let pgq + | prep = TH.ConE 'PreparedQuery `TH.AppE` stringL sqlp `TH.AppE` TH.ListE vals + | otherwise = TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals + foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e - -makeSimpleQuery :: Bool -> String -> TH.Q TH.Exp -makeSimpleQuery nulls = makeQuery nulls pgTypeEscaper $ \sql ps -> - TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sql ps - -makePreparedQuery :: Bool -> String -> TH.Q TH.Exp -makePreparedQuery nulls = makeQuery nulls pgTypeEncoder $ \sql ps -> - TH.ConE 'PreparedQuery `TH.AppE` stringL sql `TH.AppE` TH.ListE ps - --- |Produce a new 'PGSimpleQuery' from a SQL query string. --- This should be used as @$(makePGSimpleQuery \"SELECT ...\")@ -makePGSimpleQuery :: String -> TH.Q TH.Exp -makePGSimpleQuery = makeSimpleQuery False - --- |Like 'makePGSimpleQuery' but treats all results as nullable ('Maybe'). -makePGSimpleQuery' :: String -> TH.Q TH.Exp -makePGSimpleQuery' = makeSimpleQuery True - --- |Like 'makePGSimpleQuery' but produce a 'PGPreparedQuery' instead. -makePGPreparedQuery :: String -> TH.Q TH.Exp -makePGPreparedQuery = makePreparedQuery False - --- |Like 'makePGPreparedQuery' but treats all results as nullable ('Maybe'). -makePGPreparedQuery' :: String -> TH.Q TH.Exp -makePGPreparedQuery' = makePreparedQuery True + encf + | prep = pgTypeEncoder + | otherwise = pgTypeEscaper + +qqQuery :: QueryFlags -> String -> TH.ExpQ +qqQuery f@QueryFlags{ flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q +qqQuery f@QueryFlags{ flagPrepared = False } ('$':q) = qqQuery f{ flagPrepared = True } q +qqQuery f q = makePGQuery f q + +qqType :: String -> TH.TypeQ +qqType t = fmap pgTypeType $ TH.runIO $ withTHConnection $ \c -> + maybe (fail $ "Unknown PostgreSQL type: " ++ t) (getPGType c . fst) =<< getTypeOID c t + +-- |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 occurances 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 create a 'PGPreparedQuery' rather than a 'PGSimpleQuery' +-- [@?@] To treat all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. +-- +-- In type context, [pgSQL|typname|] will be replaced with the Haskell type that corresponds to PostgreSQL type @typname@. +pgSQL :: QuasiQuoter +pgSQL = QuasiQuoter + { quoteExp = qqQuery simpleFlags + , quoteType = qqType + , quotePat = const $ fail "pgSQL not supported in patterns" + , quoteDec = const $ fail "pgSQL not supported at top level" + } diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 4c85ecb..88713c9 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -40,7 +40,7 @@ querySQL "" = "" -- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h :: IO [(Maybe String, Maybe Integer)] -- @ queryTuples :: String -> Q Exp -queryTuples sql = [| \c -> pgQuery c $(makePGSimpleQuery $ querySQL sql) |] +queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleFlags $ querySQL sql) |] -- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ -- @@ -67,7 +67,7 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- $(execute \"CREATE ROLE {rolename}\") h -- @ execute :: String -> Q Exp -execute sql = [| \c -> void $ pgExecute c $(makePGSimpleQuery $ querySQL sql) |] +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' diff --git a/templatepg.cabal b/templatepg.cabal index 6089197..55b61d5 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -59,4 +59,4 @@ test-suite test main-is: Main.hs buildable: True hs-source-dirs: test - Extensions: TemplateHaskell + Extensions: TemplateHaskell, QuasiQuotes diff --git a/test/Main.hs b/test/Main.hs index 995ea16..b405b59 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -16,10 +16,10 @@ assert True = return () useTHConnection connect simple, simpleApply, prepared, preparedApply :: PGConnection -> OID -> IO [String] -simple c t = pgQuery c $(makePGSimpleQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1") -simpleApply c = pgQuery c . $(makePGSimpleQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = $1") -prepared c t = pgQuery c $(makePGPreparedQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1") -preparedApply c = pgQuery c . $(makePGPreparedQuery "SELECT typname FROM pg_catalog.pg_type WHERE oid = $1") +simple c t = pgQuery c [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] +simpleApply c = pgQuery c . [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] +prepared c t = pgQuery c [pgSQL|$SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] +preparedApply c = pgQuery c . [pgSQL|$SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] main :: IO () main = do From 8d21fa8e2f7643634309753da4b95162ac2c4b13 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 00:02:17 -0500 Subject: [PATCH 050/306] Update and cleanup more docs --- Database/TemplatePG.hs | 2 +- Database/TemplatePG/Protocol.hs | 3 +++ Database/TemplatePG/Query.hs | 7 ++++--- Database/TemplatePG/Types.hs | 30 ++++++++++++++++++------------ 4 files changed, 26 insertions(+), 16 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index b607853..1bdd5ba 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -193,7 +193,7 @@ import Database.TemplatePG.SQL -- $nulls -- Sometimes TemplatePG cannot determine whether or not a result field can -- potentially be @NULL@. In those cases it will assume that it can. Basically, --- any time a result field is not immediately tracable to an originating table +-- 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. -- diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 7e088bf..fc0c121 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -375,9 +375,11 @@ pgSync c@PGConnection{ connState = sr } = do _ <- pgReceive c `catch` \(PGError m) -> ErrorResponse m <$ connLogMessage c m pgSync c +-- |Add a new type handler for the given type OID. pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } +-- |Lookup the OID of a database type by internal or formatted name (case sensitive). getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c@PGConnection{ connTypes = types } t | Just oid <- findType t = return $ Just (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of @@ -390,6 +392,7 @@ getTypeOID c@PGConnection{ connTypes = types } t where findType n = fmap fst $ find ((==) n . pgTypeName . snd) $ Map.toList types +-- |Lookup the type handler for a given type OID. getPGType :: PGConnection -> OID -> IO PGTypeHandler getPGType c@PGConnection{ connTypes = types } oid = maybe notype return $ Map.lookup oid types where diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 4280029..017fa27 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -132,7 +132,7 @@ sqlSubstitute sql exprl = se sql where 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 occurances may need to be escaped with '$$'" + | 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 @@ -158,10 +158,11 @@ data QueryFlags = QueryFlags simpleFlags :: QueryFlags simpleFlags = QueryFlags False False +-- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepared = prep } sqle = do (pt, rt) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp (not nulls) - when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurances of '${' may need to be escaped with '$${'" + when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" (vars, vals) <- mapAndUnzipM (\t -> do v <- TH.newName "p" @@ -193,7 +194,7 @@ qqType t = fmap pgTypeType $ TH.runIO $ withTHConnection $ \c -> -- 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 occurances 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. +-- 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: diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index c48426b..1e06b3a 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -31,7 +31,7 @@ import Data.Maybe (fromMaybe) import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) -import Language.Haskell.TH +import qualified Language.Haskell.TH as TH import Numeric (readFloat) import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P @@ -40,6 +40,7 @@ import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) 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 "" = "'" @@ -296,6 +297,8 @@ instance PGType a => PGType (Maybe a) where pgLiteral = maybe "NULL" pgLiteral -} +-- |A special class inhabited only by @a@ and @Maybe a@. +-- This is used to provide added flexibility in parameter types. class PGType a => PossiblyMaybe m a {- ideally should have fundep: | m -> a -} where possiblyMaybe :: m -> Maybe a maybePossibly :: Maybe a -> m @@ -308,31 +311,34 @@ instance PGType a => PossiblyMaybe (Maybe a) a where maybePossibly = id data PGTypeHandler = PGType - { pgTypeName :: String - , pgTypeType :: Type + { pgTypeName :: String -- ^ The internal PostgreSQL name of the type + , pgTypeType :: TH.Type -- ^ The equivalent Haskell type to which it is marshalled (must be an instance of 'PGType' } -pgTypeDecoder :: PGTypeHandler -> Q Exp +-- |TH expression to decode a 'L.ByteString' to a value. +pgTypeDecoder :: PGTypeHandler -> TH.ExpQ pgTypeDecoder PGType{ pgTypeType = t } = [| pgDecodeBS :: L.ByteString -> $(return t) |] -pgTypeEncoder :: PGTypeHandler -> Q Exp +-- |TH expression to encode a ('PossiblyMayble') value to an 'Maybe' 'L.ByteString'. +pgTypeEncoder :: PGTypeHandler -> TH.ExpQ pgTypeEncoder PGType{ pgTypeType = t } = [| fmap (pgEncodeBS :: $(return t) -> L.ByteString) . possiblyMaybe |] -pgTypeEscaper :: PGTypeHandler -> Q Exp +-- |TH expression to escape a ('PossiblyMaybe') value to a SQL literal. +pgTypeEscaper :: PGTypeHandler -> TH.ExpQ pgTypeEscaper PGType{ pgTypeType = t } = [| maybe "NULL" (pgLiteral :: $(return t) -> String) . possiblyMaybe |] type PGTypeMap = Map.Map OID PGTypeHandler -arrayType :: Type -> Type -arrayType = AppT ListT . AppT (ConT ''Maybe) +arrayType :: TH.Type -> TH.Type +arrayType = TH.AppT TH.ListT . TH.AppT (TH.ConT ''Maybe) -pgArrayType :: String -> Type -> PGTypeHandler +pgArrayType :: String -> TH.Type -> PGTypeHandler pgArrayType n t = PGType ('_':n) (arrayType t) -pgTypes :: [(OID, OID, String, Name)] +pgTypes :: [(OID, OID, String, TH.Name)] pgTypes = [ ( 16, 1000, "bool", ''Bool) , ( 17, 1001, "bytea", ''L.ByteString) @@ -367,5 +373,5 @@ pgTypes = ] defaultTypeMap :: PGTypeMap -defaultTypeMap = Map.fromAscList [(o, PGType n (ConT t)) | (o, _, n, t) <- pgTypes] - `Map.union` Map.fromList [(o, pgArrayType n (ConT t)) | (_, o, n, t) <- pgTypes] +defaultTypeMap = Map.fromAscList [(o, PGType n (TH.ConT t)) | (o, _, n, t) <- pgTypes] + `Map.union` Map.fromList [(o, pgArrayType n (TH.ConT t)) | (_, o, n, t) <- pgTypes] From 8c1ba35107249a2512c90725e0725ea725a39279 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 10:05:43 -0500 Subject: [PATCH 051/306] Don't export queryTuples by default anymore; fix more docs Require explicit SQL import --- Database/TemplatePG.hs | 19 +++++++++---------- test/Main.hs | 1 + 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 1bdd5ba..d5b9430 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -34,9 +34,6 @@ module Database.TemplatePG -- **Basic queries -- $basic - , queryTuples - , queryTuple - , execute -- *Advanced usage -- **Types @@ -161,7 +158,8 @@ import Database.TemplatePG.SQL -- 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 ... +-- @ +-- h <- pgConnect ... -- -- tuples <- $(queryTuples \"SELECT * FROM pg_database\") h -- @ @@ -169,9 +167,10 @@ import Database.TemplatePG.SQL -- To pass parameters to a query, include them in the string with {}. Most -- Haskell expressions should work. For example: -- --- @let owner = 33 :: Int32 +-- @ +-- let owner = 33 :: Int32 -- --- tuples <- $(queryTuples \"SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int32}\") h +-- tuples <- $(queryTuples \"SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int64}\") h -- @ -- $types @@ -222,10 +221,10 @@ import Database.TemplatePG.SQL -- to functions, you can use @uncurryN@ from the tuple package. The following -- examples are equivalent. -- --- @(a, b, c) <- $(queryTuple \"SELECT a, b, c FROM {tableName} LIMIT 1\") --- --- someFunction a b c -- @ +-- (a, b, c) <- $(queryTuple \"SELECT a, b, c FROM table LIMIT 1\") -- --- @uncurryN someFunction \`liftM\` $(queryTuple \"SELECT a, b, c FROM {tableName} LIMIT 1\") +-- someFunction a b c +-- +-- uncurryN someFunction \`liftM\` $(queryTuple \"SELECT a, b, c FROM table LIMIT 1\") -- @ diff --git a/test/Main.hs b/test/Main.hs index b405b59..71f289a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import System.Exit (exitSuccess, exitFailure) import Database.TemplatePG import Database.TemplatePG.Types (OID) +import Database.TemplatePG.SQL import Connect assert :: Bool -> IO () From cb691205fc442dce593d298ff89921eacba5dfa1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 10:06:24 -0500 Subject: [PATCH 052/306] Allow literal OIDs for pg type names --- Database/TemplatePG/Protocol.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index fc0c121..db427f1 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -382,6 +382,7 @@ pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } -- |Lookup the OID of a database type by internal or formatted name (case sensitive). getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) getTypeOID c@PGConnection{ connTypes = types } t + | Just oid <- readMaybe t = return $ Just (oid, 0) | Just oid <- findType t = return $ Just (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of | otherwise = do (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) From b57f87c1eb311dc8ef4cef2f7e1630309801cf0d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 11:04:31 -0500 Subject: [PATCH 053/306] Allow explicit type specifications in prepared queries --- Database/TemplatePG/Connection.hs | 2 +- Database/TemplatePG/Protocol.hs | 53 +++++++++++++++------------- Database/TemplatePG/Query.hs | 58 +++++++++++++++++++++---------- Database/TemplatePG/Types.hs | 2 +- test/Main.hs | 17 +++++---- 5 files changed, 79 insertions(+), 53 deletions(-) diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs index 761b702..a58f56f 100644 --- a/Database/TemplatePG/Connection.hs +++ b/Database/TemplatePG/Connection.hs @@ -51,7 +51,7 @@ modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . liftM -- This should be called as a top-level declaration and produces no code. registerPGType :: String -> TH.Type -> TH.Q [TH.Dec] registerPGType name typ = [] <$ TH.runIO (do - (oid, loid) <- maybe (fail $ "PostgreSQL type not found: " ++ name) return =<< withTHConnection (\c -> getTypeOID c name) + (oid, loid) <- withTHConnection (\c -> getTypeOID c name) modifyTHConnection (pgAddType oid (PGType name typ)) when (loid /= 0) $ modifyTHConnection (pgAddType loid (pgArrayType name typ))) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index db427f1..a9661dd 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -15,7 +15,7 @@ module Database.TemplatePG.Protocol ( PGConnection , pgSimpleQuery , pgPreparedQuery , pgPreparedLazyQuery - , pgCloseQuery + , pgCloseStatement , pgAddType , getTypeOID , getPGType @@ -68,7 +68,7 @@ data PGConnection = PGConnection , connKey :: !Word32 , connParameters :: Map.Map String String , connTypes :: PGTypeMap - , connPreparedStatements :: IORef (Integer, Map.Map String Integer) + , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) , connState :: IORef PGState } @@ -380,15 +380,16 @@ pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } -- |Lookup the OID of a database type by internal or formatted name (case sensitive). -getTypeOID :: PGConnection -> String -> IO (Maybe (OID, OID)) +-- Fail if not found. +getTypeOID :: PGConnection -> String -> IO (OID, OID) getTypeOID c@PGConnection{ connTypes = types } t - | Just oid <- readMaybe t = return $ Just (oid, 0) - | Just oid <- findType t = return $ Just (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of + | Just oid <- readMaybe t = return (oid, 0) + | Just oid <- findType t = return (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of | otherwise = do (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) case r of - [] -> return Nothing - [[Just o, Just lo]] -> return (Just (pgDecodeBS o, pgDecodeBS lo)) + [] -> fail $ "Unknown PostgreSQL type: " ++ t + [[Just o, Just lo]] -> return (pgDecodeBS o, pgDecodeBS lo) _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r where findType n = fmap fst $ find ((==) n . pgTypeName . snd) $ Map.toList types @@ -408,11 +409,12 @@ getPGType c@PGConnection{ connTypes = types } oid = -- 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 ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. -pgDescribe h sql nulls = do +pgDescribe h sql types nulls = do pgSync h - pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = [] } + pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = types } pgSend h $ Describe "" pgSend h $ Flush pgFlush h @@ -470,32 +472,34 @@ pgSimpleQuery h sql = do end EmptyQueryResponse = go end end m = fail $ "pgSimpleQuery: unexpected message: " ++ show m -pgPreparedBind :: PGConnection -> String -> PGData -> IO (IO ()) -pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql bind = do +pgPreparedBind :: PGConnection -> String -> [OID] -> PGData -> IO (IO ()) +pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = do pgSync c (p, n) <- atomicModifyIORef' psr $ \(i, m) -> - maybe ((succ i, m), (False, i)) ((,) (i, m) . (,) True) $ Map.lookup sql 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 = [] } + pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = types } pgSend c $ Bind{ statementName = sn, bindParameters = bind } let go = pgHandle c start start ParseComplete = do modifyIORef psr $ \(i, m) -> - (i, Map.insert sql n 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) -> PGData -- ^ Paremeters to bind to placeholders -> IO (Int, [PGData]) -pgPreparedQuery c sql bind = do - start <- pgPreparedBind c sql bind +pgPreparedQuery c sql types bind = do + start <- pgPreparedBind c sql types bind pgSend c $ Execute 0 pgSend c $ Flush pgFlush c @@ -507,12 +511,12 @@ pgPreparedQuery c sql bind = do row (CommandComplete r) = return (rowsAffected r, []) row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m -pgPreparedLazyQuery :: PGConnection -> String -- ^ SQL statement with placeholders - -> PGData -- ^ Paremeters to bind to placeholders - -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) +-- |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] -> PGData -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) -> IO [PGData] -pgPreparedLazyQuery c sql bind count = do - start <- pgPreparedBind c sql bind +pgPreparedLazyQuery c sql types bind count = do + start <- pgPreparedBind c sql types bind unsafeInterleaveIO $ do execute start @@ -529,11 +533,10 @@ pgPreparedLazyQuery c sql bind count = do row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m -- |Close a previously prepared query (if necessary). -pgCloseQuery :: PGConnection -> String -- ^ SQL statement with placeholders - -> IO () -pgCloseQuery c@PGConnection{ connPreparedStatements = psr } sql = do +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 m in ((i, m'), n) + let (n, m') = Map.updateLookupWithKey (\_ _ -> Nothing) (sql, types) m in ((i, m'), n) forM_ mn $ \n -> do pgSend c $ Close{ statementName = show n } pgFlush c diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 017fa27..14060a2 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -18,8 +18,9 @@ import Control.Applicative ((<$>)) import Control.Arrow ((***), first, second) import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) -import Data.Char (isDigit) -import Data.Maybe (fromMaybe) +import Data.Char (isDigit, isSpace) +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe, isNothing) import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH @@ -51,9 +52,9 @@ instance PGQuery SimpleQuery PGData where instance PGRawQuery SimpleQuery where -data PreparedQuery = PreparedQuery String PGData +data PreparedQuery = PreparedQuery String [OID] PGData instance PGQuery PreparedQuery PGData where - pgRunQuery c (PreparedQuery sql bind) = pgPreparedQuery c sql bind + pgRunQuery c (PreparedQuery sql types bind) = pgPreparedQuery c sql types bind instance PGRawQuery PreparedQuery where @@ -78,15 +79,15 @@ rawPGSimpleQuery = rawParser . SimpleQuery -- |Make a prepared query directly from a query string and bind parameters, with no type inference rawPGPreparedQuery :: String -> PGData -> PGPreparedQuery PGData -rawPGPreparedQuery sql = rawParser . PreparedQuery sql +rawPGPreparedQuery sql = rawParser . PreparedQuery sql [] -- |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 (PreparedQuery sql bind) p) count = - fmap p <$> pgPreparedLazyQuery c sql bind count +pgLazyQuery c (QueryParser (PreparedQuery sql types bind) p) count = + fmap p <$> pgPreparedLazyQuery c sql types bind count -- |Given a result description, create a function to convert a result to a -- tuple. @@ -150,18 +151,31 @@ 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 + data QueryFlags = QueryFlags - { flagNullable :: Bool - , flagPrepared :: Bool + { 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) } simpleFlags :: QueryFlags -simpleFlags = QueryFlags False False +simpleFlags = QueryFlags False Nothing -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ -makePGQuery QueryFlags{ flagNullable = nulls, flagPrepared = prep } sqle = do - (pt, rt) <- TH.runIO $ withTHConnection $ \c -> pgDescribe c sqlp (not nulls) +makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do + (at, pt, rt) <- TH.runIO $ withTHConnection $ \c -> do + at <- mapM (fmap fst . getTypeOID c) $ fromMaybe [] prep + (pt, rt) <- pgDescribe c sqlp at (not nulls) + return (at, pt, rt) when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" (vars, vals) <- mapAndUnzipM (\t -> do @@ -169,24 +183,29 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepared = prep } sqle = do (,) (TH.VarP v) . (`TH.AppE` TH.VarE v) <$> encf t) pt conv <- convertRow rt let pgq - | prep = TH.ConE 'PreparedQuery `TH.AppE` stringL sqlp `TH.AppE` TH.ListE vals - | otherwise = TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals + | 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) at) `TH.AppE` TH.ListE vals foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e encf - | prep = pgTypeEncoder - | otherwise = pgTypeEscaper + | isNothing prep = pgTypeEscaper + | otherwise = pgTypeEncoder qqQuery :: QueryFlags -> String -> TH.ExpQ qqQuery f@QueryFlags{ flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q -qqQuery f@QueryFlags{ flagPrepared = False } ('$':q) = qqQuery f{ flagPrepared = 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 qqType :: String -> TH.TypeQ qqType t = fmap pgTypeType $ TH.runIO $ withTHConnection $ \c -> - maybe (fail $ "Unknown PostgreSQL type: " ++ t) (getPGType c . fst) =<< getTypeOID c t + getPGType c . fst =<< getTypeOID c t -- |A quasi-quoter for PGSQL queries. -- @@ -199,8 +218,9 @@ qqType t = fmap pgTypeType $ TH.runIO $ withTHConnection $ \c -> -- -- The statement may start with one of more special flags affecting the interpretation: -- --- [@$@] To create a 'PGPreparedQuery' rather than a 'PGSimpleQuery' -- [@?@] To treat 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). -- -- In type context, [pgSQL|typname|] will be replaced with the Haskell type that corresponds to PostgreSQL type @typname@. pgSQL :: QuasiQuoter diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 1e06b3a..e08fc68 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -313,7 +313,7 @@ instance PGType a => PossiblyMaybe (Maybe a) a where data PGTypeHandler = PGType { pgTypeName :: String -- ^ The internal PostgreSQL name of the type , pgTypeType :: TH.Type -- ^ The equivalent Haskell type to which it is marshalled (must be an instance of 'PGType' - } + } deriving (Show) -- |TH expression to decode a 'L.ByteString' to a value. pgTypeDecoder :: PGTypeHandler -> TH.ExpQ diff --git a/test/Main.hs b/test/Main.hs index 71f289a..300e7eb 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -16,11 +16,14 @@ assert True = return () useTHConnection connect -simple, simpleApply, prepared, preparedApply :: PGConnection -> OID -> IO [String] +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 c = pgQuery c . [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] -prepared c t = pgQuery c [pgSQL|$SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] -preparedApply c = pgQuery c . [pgSQL|$SELECT typname FROM pg_catalog.pg_type WHERE 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 -> IO [Maybe String] +prepared c t = pgQuery c [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] +preparedApply :: PGConnection -> [pgSQL|int4|] -> IO [String] +preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] main :: IO () main = do @@ -38,10 +41,10 @@ main = do assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' && l == l' ["box"] <- simple c 603 - ["box"] <- simpleApply c 603 - ["box"] <- prepared c 603 + [Just "box"] <- simpleApply c 603 + [Just "box"] <- prepared c 603 ["box"] <- preparedApply c 603 - ["line"] <- prepared c 628 + [Just "line"] <- prepared c 628 ["line"] <- preparedApply c 628 pgDisconnect c From 8c56ace4af79d912e519ba3f659b933f568fb6d9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 16:44:37 -0500 Subject: [PATCH 054/306] Update README and cabal --- README | 27 ++++++++++++++++++++------- templatepg.cabal | 4 ++-- 2 files changed, 22 insertions(+), 9 deletions(-) diff --git a/README b/README index dc722ff..42639f3 100644 --- a/README +++ b/README @@ -1,11 +1,24 @@ -TemplatePG is designed with 2 goals in mind: safety and performance. The primary focus is on safety. +TemplatePG is designed with 2 goals in mind: safety and performance. The +primary focus is on safety. -To help ensure safety, it uses the PostgreSQL server to parse every query and statement in your code to infer types at compile-time. This means that in theory you cannot get a syntax error at runtime. Getting proper types at compile time has the nice side-effect that it eliminates run-time type casting and usually results in less code. This approach was inspired by MetaHDBC (http://haskell.org/haskellwiki/MetaHDBC) and PG'OCaml (http://pgocaml.berlios.de/). +To help ensure safety, it uses the PostgreSQL server to parse every query and +statement in your code to infer types at compile-time. This means that in +theory you cannot get a syntax error at runtime. Getting proper types at +compile time has the nice side-effect that it eliminates run-time type casting +and usually results in less code. This approach was inspired by MetaHDBC +(http://haskell.org/haskellwiki/MetaHDBC) and PG'OCaml +(http://pgocaml.berlios.de/). -While compile-time query analysis eliminates many errors, it doesn't eliminate all of them. If you modify the database without recompilation or have an error in a trigger or function, for example, you can still trigger a PGException. Also, nullable result fields resulting from outer joins are not detected and need to be handled specially. +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 specially. -Use the software at your own risk. Note however that TemplatePG is currently powering http://www.vocabulink.com/ with no problems yet. (For usage examples, you can see the Vocabulink source code at http://jekor.com/vocabulink/vocabulink.tar.gz). +Use the software at your own risk. Note however that TemplatePG is currently +powering http://www.vocabulink.com/ with no problems yet. (For usage +examples, you can see the Vocabulink source code at +https://github.com/jekor/vocabulink). -To improve performance, TemplatePG does not use prepared statements. In theory, this saves bandwidth (and a potential round-trip) and time for the extra step of binding parameters. Again in theory, this is also safe because we know the types of parameters at compile time. However, it still feels risky (and I would appreciate any audit of the code doing this, especially escapeString). - -See the Haddock documentation at http://hackage.haskell.org/package/templatepg for how to use TemplatePG. +See the Haddock documentation at http://hackage.haskell.org/package/templatepg +for how to use TemplatePG. diff --git a/templatepg.cabal b/templatepg.cabal index 55b61d5..b20c279 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -4,7 +4,7 @@ Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING Copyright: 2010, 2011, 2012, 2013 Chris Forno -Author: Chris Forno (jekor) +Author: Chris Forno (jekor), Dylan Simon Maintainer: jekor@jekor.com Stability: alpha Bug-Reports: https://github.com/jekor/templatepg/issues @@ -19,7 +19,7 @@ Description: TemplatePG provides PostgreSQL access from Haskell via the This also reduces boilerplate code for dealing with query results, as the type and number of result columns are known at compile-time. -Tested-With: GHC == 7.6.3 +Tested-With: GHC == 7.8.4 Build-Type: Simple source-repository head From 0113056170e5419fb88d4339d1625838d019a0eb Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 17:39:42 -0500 Subject: [PATCH 055/306] Bump minimum base dependency Things like modifyMVar introduced 4.7 Since we're already requiring bytestring 0.10.2, this doesn't do much harm --- templatepg.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templatepg.cabal b/templatepg.cabal index b20c279..060d6b7 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -32,7 +32,7 @@ Flag md5 Library Build-Depends: - base >= 4.6 && < 5, + base >= 4.7 && < 5, array, binary, containers, old-locale, time, bytestring >= 0.10.2, template-haskell, From d42096fa7f373a45689bbe3f6cc91f76940cbefe Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 18:00:11 -0500 Subject: [PATCH 056/306] Add a (mostly useless) finalizer to thConnection --- Database/TemplatePG/Connection.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs index a58f56f..dca71ea 100644 --- a/Database/TemplatePG/Connection.hs +++ b/Database/TemplatePG/Connection.hs @@ -5,13 +5,14 @@ module Database.TemplatePG.Connection ) where import Control.Applicative ((<$>), (<$)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) -import Control.Monad (liftM, (>=>), when) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, swapMVar) +import Control.Monad ((>=>), when, void) import Data.Maybe (fromMaybe) import qualified Language.Haskell.TH as TH import Network (PortID(UnixSocket, PortNumber), PortNumber) import System.Environment (getEnv, lookupEnv) import System.IO.Unsafe (unsafePerformIO) +import System.Mem.Weak (addFinalizer) import Database.TemplatePG.Types import Database.TemplatePG.Protocol @@ -33,10 +34,12 @@ thConnection = unsafePerformIO $ newMVar $ Left $ do -- |Run an action using the TemplatePG connection. -- This is meant to be used from other TH code (though it will work during normal runtime if just want a simple PGConnection based on TPG environment variables). withTHConnection :: (PGConnection -> IO a) -> IO a -withTHConnection f = modifyMVar thConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) +withTHConnection f = modifyMVar thConnection $ either (final =<<) return >=> (\c -> (,) (Right c) <$> f c) where + -- This doesn't work in most cases because thConnection is global, but there doesn't seem to be any way to do TH "cleanup": + final c = c <$ addFinalizer c (pgDisconnect c) setTHConnection :: Either (IO PGConnection) PGConnection -> IO () -setTHConnection c = modifyMVar_ thConnection $ either (const $ return c) ((c <$) . pgDisconnect) +setTHConnection = void . swapMVar thConnection -- |Specify an alternative connection method to use during TemplatePG compilation. -- This lets you override the default connection parameters that are based on TPG environment variables. @@ -45,7 +48,7 @@ useTHConnection :: IO PGConnection -> TH.Q [TH.Dec] useTHConnection c = [] <$ TH.runIO (setTHConnection (Left c)) modifyTHConnection :: (PGConnection -> PGConnection) -> IO () -modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . liftM f) (Right . f) +modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . fmap f) (Right . f) -- |Register a new handler for PostgreSQL type and a Haskell type, which should be an instance of 'PGType'. -- This should be called as a top-level declaration and produces no code. From d92640a79dc998228bf94b4efdff268ef31f56c4 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 18:41:59 -0500 Subject: [PATCH 057/306] Update TODO --- TODO | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/TODO b/TODO index 19ec724..2e7643e 100644 --- a/TODO +++ b/TODO @@ -1,23 +1,21 @@ -* See if we can get rid of -XConstraintKinds (ShowIntegral and ShowReal). -* Bail when standard_conforming_string is off (can be seen in connection details returned from server). * Handle bounds for integers better (automatically allow anything smaller through, but block bigger values). * Add support for returning records (instead of tuples). * Make insertIgnore useable in transactions. -* On disconnect, send a close message? * Figure out how to make withTransaction useable in other monads. * Add support for enumerated types (look in pg_enum with unknown types). -* Support IS NULL insertion for = Nothing. * Add explicit casts to all values going in: $(execute "UPDATE link_to_review \ \SET target_time = {reviewedAt} + {diff} \ \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h -reviewedAt is a UTCTime and diff is a DiffTime, but to PostgreSQL it's ambigious (PGException "42725" "operator is not unique: unknown + unknown"). To fix it: + reviewedAt is a UTCTime and diff is a DiffTime, but to PostgreSQL it's ambigious (PGException "42725" "operator is not unique: unknown + unknown"). To fix it: $(execute "UPDATE link_to_review \ \SET target_time = {reviewedAt}::timestamp with time zone + {diff}::interval \ \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h -But easier for the programmer would be to have TemplatePG add explicit casts to all values it sends in. This is probably safer in the long run as well, although possibly less flexible. + But easier for the programmer would be to have TemplatePG add explicit casts to all values it sends in. This is probably safer in the long run as well, although possibly less flexible. +* Use postgresql-binary package for binary protocol with supported types +* Consider using postgresql-libpq (worse performance but much easier maintenance) From 99cf22f103712ad2f707d920838af91891971b7b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 18:49:37 -0500 Subject: [PATCH 058/306] Change timestamptz to UTCTime Upon further investigation, timestamptz does not actually store a timezone, just display one. (I feel like I knew this but keep forgetting it since it's so counter-intuitive.) This is also what postgresql-binary does. --- Database/TemplatePG/Types.hs | 4 ++-- test/Main.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index e08fc68..231cc77 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -179,7 +179,7 @@ instance PGType Time.LocalTime where pgEncode = Time.formatTime defaultTimeLocale "%F %T%Q" pgLiteral = pgQuoteUnsafe . pgEncode -instance PGType Time.ZonedTime where +instance PGType Time.UTCTime where pgDecodeBS = pgDecode . LC.unpack pgEncodeBS = LC.pack . pgEncode pgDecode = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ @@ -363,7 +363,7 @@ pgTypes = , (1082, 1182, "date", ''Time.Day) , (1083, 1183, "time", ''Time.TimeOfDay) , (1114, 1115, "timestamp", ''Time.LocalTime) - , (1184, 1185, "timestamptz", ''Time.ZonedTime) + , (1184, 1185, "timestamptz", ''Time.UTCTime) , (1186, 1187, "interval", ''Time.DiffTime) --, (1266, 1270, "timetz", ?) --, (1560, 1561, "bit", Bool?) diff --git a/test/Main.hs b/test/Main.hs index 300e7eb..b3ed3ac 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -37,8 +37,8 @@ main = do p = -34881559 l = [Just "a\\\"b,c", Nothing] Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l') <- - $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {z}::timestamptz, {p}::interval, {l}::text[]") c - assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == Time.zonedTimeToUTC z' && p == p' && l == l' + $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[]") c + assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' ["box"] <- simple c 603 [Just "box"] <- simpleApply c 603 From 6eabdfcc662069d23e4bf5eb18c6d0411c7a3a10 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 18:57:23 -0500 Subject: [PATCH 059/306] Update TODO --- TODO | 1 + 1 file changed, 1 insertion(+) diff --git a/TODO b/TODO index 2e7643e..6f500dd 100644 --- a/TODO +++ b/TODO @@ -17,5 +17,6 @@ \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h But easier for the programmer would be to have TemplatePG add explicit casts to all values it sends in. This is probably safer in the long run as well, although possibly less flexible. + Prepared placeholder type specification provides one solution to this [pgSQL|$(type,...)SQL...|] * Use postgresql-binary package for binary protocol with supported types * Consider using postgresql-libpq (worse performance but much easier maintenance) From c711930b2ac2334ca8ea08aa4aaca820a5de3b36 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 19:54:47 -0500 Subject: [PATCH 060/306] Build DataRow results using Seq rather than List This avoids blowing up the stack with the number of rows, but is also probably no more efficient than just using a List and reversing it (unless users actually take advantage of the Seq). --- Database/TemplatePG/Protocol.hs | 47 +++++++++++++++++---------------- Database/TemplatePG/Query.hs | 8 +++--- 2 files changed, 29 insertions(+), 26 deletions(-) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index a9661dd..e57d059 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -36,12 +36,13 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U -import Data.Foldable (foldMap, forM_) +import Data.Foldable (foldMap, forM_, toList) import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) import Data.List (find) import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) import Data.Monoid (mempty, (<>)) +import qualified Data.Sequence as Seq import Data.Typeable (Typeable) import Data.Word (Word8, Word32) import Network (HostName, PortID, connectTo) @@ -387,7 +388,7 @@ getTypeOID c@PGConnection{ connTypes = types } t | Just oid <- findType t = return (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of | otherwise = do (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) - case r of + case toList r of [] -> fail $ "Unknown PostgreSQL type: " ++ t [[Just o, Just lo]] -> return (pgDecodeBS o, pgDecodeBS lo) _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r @@ -400,7 +401,7 @@ getPGType c@PGConnection{ connTypes = types } oid = maybe notype return $ Map.lookup oid types where notype = do (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) - case r of + case toList r of [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ U.toString s _ -> fail $ "Unknown PostgreSQL type: " ++ show oid @@ -438,7 +439,7 @@ pgDescribe h sql types nulls = 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 = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) - case r of + case toList r of [[Just s]] -> return $ not $ pgDecodeBS s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col @@ -454,20 +455,20 @@ rowsAffected = ra . LC.words where -- cannot bind parameters. Note that queries can return 0 results (an empty -- list). pgSimpleQuery :: PGConnection -> String -- ^ SQL string - -> IO (Int, [PGData]) -- ^ The number of rows affected and a list of result rows + -> IO (Int, Seq.Seq PGData) -- ^ 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 = pgHandle h - start (CommandComplete c) = got c - start (RowDescription _) = go row + start (CommandComplete c) = got c Seq.empty + start (RowDescription _) = go (row Seq.empty) start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m - row (DataRow fs) = second (fs:) <$> go row - row (CommandComplete c) = got c - row m = fail $ "pgSimpleQuery: unexpected row: " ++ show m - got c = (,) (rowsAffected c) <$> go end + row s (DataRow fs) = go $ row (s Seq.|> fs) + row s (CommandComplete c) = got c s + row _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m + got c s = (rowsAffected c, s) <$ go end end (ReadyForQuery _) = return [] end EmptyQueryResponse = go end end m = fail $ "pgSimpleQuery: unexpected message: " ++ show m @@ -497,19 +498,19 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = d pgPreparedQuery :: PGConnection -> String -- ^ SQL statement with placeholders -> [OID] -- ^ Optional type specifications (only used for first call) -> PGData -- ^ Paremeters to bind to placeholders - -> IO (Int, [PGData]) + -> IO (Int, Seq.Seq PGData) pgPreparedQuery c sql types bind = do start <- pgPreparedBind c sql types bind pgSend c $ Execute 0 pgSend c $ Flush pgFlush c start - go + go Seq.empty where - go = pgHandle c row - row (DataRow fs) = second (fs:) <$> go - row (CommandComplete r) = return (rowsAffected r, []) - row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m + go = pgHandle c . row + row s (DataRow fs) = go (s Seq.|> fs) + row s (CommandComplete r) = return (rowsAffected r, 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. @@ -520,17 +521,17 @@ pgPreparedLazyQuery c sql types bind count = do unsafeInterleaveIO $ do execute start - go + go Seq.empty where execute = do pgSend c $ Execute count pgSend c $ Flush pgFlush c - go = pgHandle c row - row (DataRow fs) = (fs:) <$> go - row PortalSuspended = unsafeInterleaveIO (execute >> go) - row (CommandComplete _) = return [] - row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m + go = pgHandle c . row + row s (DataRow fs) = go (s Seq.|> fs) + row s PortalSuspended = (toList s ++) <$> unsafeInterleaveIO (execute >> go Seq.empty) + row s (CommandComplete _) = return $ toList s + row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m -- |Close a previously prepared query (if necessary). pgCloseStatement :: PGConnection -> String -> [OID] -> IO () diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 14060a2..03dbcaf 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -19,8 +19,10 @@ import Control.Arrow ((***), first, second) 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 @@ -33,7 +35,7 @@ import Database.TemplatePG.Connection class PGQuery q a | q -> a where -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results. - pgRunQuery :: PGConnection -> q -> IO (Int, [a]) + pgRunQuery :: PGConnection -> q -> IO (Int, Seq a) class PGQuery q PGData => PGRawQuery q -- |Execute a query that does not return result. @@ -43,7 +45,7 @@ pgExecute c q = fst <$> pgRunQuery c q -- |Run a query and return a list of row results. pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] -pgQuery c q = snd <$> pgRunQuery c q +pgQuery c q = toList . snd <$> pgRunQuery c q data SimpleQuery = SimpleQuery String @@ -60,7 +62,7 @@ instance PGRawQuery PreparedQuery where data QueryParser q a = QueryParser q (PGData -> a) instance PGRawQuery q => PGQuery (QueryParser q a) a where - pgRunQuery c (QueryParser q p) = second (map p) <$> pgRunQuery c q + pgRunQuery c (QueryParser q p) = second (fmap p) <$> pgRunQuery c q instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (f . p) From 6cf1dabc9cf0fe3080d458c91fc6a2a7fac5bcaa Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 31 Dec 2014 21:33:31 -0500 Subject: [PATCH 061/306] Remove orphan TODO Single item is no longer relevant --- Database/TemplatePG/TODO | 1 - 1 file changed, 1 deletion(-) delete mode 100644 Database/TemplatePG/TODO diff --git a/Database/TemplatePG/TODO b/Database/TemplatePG/TODO deleted file mode 100644 index 0cd7d6f..0000000 --- a/Database/TemplatePG/TODO +++ /dev/null @@ -1 +0,0 @@ -* Fix defect when trying to use Days for timestamp fields (the last digit of dates are truncated). Temporary workaround: bind parameters to date manually (e.g. {haskellDay}::date). From baa337dec29a874216a91a511f66ad7c2a4a7a67 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 00:38:56 -0500 Subject: [PATCH 062/306] Add support for ranges, via full Range type Maybe overkill, but I will need it at least --- Database/TemplatePG/Range.hs | 135 +++++++++++++++++++++++++++++++++++ Database/TemplatePG/Types.hs | 83 +++++++++++++++++---- templatepg.cabal | 1 + 3 files changed, 206 insertions(+), 13 deletions(-) create mode 100644 Database/TemplatePG/Range.hs diff --git a/Database/TemplatePG/Range.hs b/Database/TemplatePG/Range.hs new file mode 100644 index 0000000..6fed450 --- /dev/null +++ b/Database/TemplatePG/Range.hs @@ -0,0 +1,135 @@ +-- | +-- Module: Database.TemplatePG.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.TemplatePG.Range where + +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 :: a -> Range a +point a = Range (Lower (Bounded True a)) (Upper (Bounded True a)) + +range :: Ord a => Bound a -> Bound a -> Range a +range l u = normalize $ Range (Lower l) (Upper u) + +normalRange :: Ord a => Maybe a -> Maybe a -> Range a +normalRange l u = range (mb True l) (mb False u) where + mb = maybe Unbounded . Bounded + +boundedRange :: Ord a => a -> a -> Range a +boundedRange 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/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 231cc77..916cb68 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} -- Copyright 2010, 2011, 2013 Chris Forno -- Copyright 2014 Dylan Simon @@ -23,7 +23,7 @@ import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U -import Data.Char (isDigit, digitToInt, intToDigit) +import Data.Char (isDigit, digitToInt, intToDigit, toLower) import Data.Int import Data.List (intercalate) import qualified Data.Map as Map @@ -37,6 +37,8 @@ import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) +import qualified Database.TemplatePG.Range as Range + pgQuoteUnsafe :: String -> String pgQuoteUnsafe s = '\'' : s ++ "'" @@ -47,6 +49,22 @@ pgQuote = ('\'':) . es where es (c@'\'':r) = c:c:es r es (c:r) = c:es r +dQuote :: String -> String -> String +dQuote _ "" = "\"\"" +dQuote unsafe s + | all (`notElem` unsafe) s && map toLower s /= "null" = s + | otherwise = '"':es s where + es "" = "\"" + es (c@'"':r) = '\\':c:es r + es (c@'\\':r) = '\\':c:es r + es (c:r) = c:es r + +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) + -- |Any type which can be marshalled to and from PostgreSQL. -- Minimal definition: 'pgDecodeBS' (or 'pgDecode') and 'pgEncode' (or 'pgEncodeBS') -- The default implementations do UTF-8 conversion. @@ -260,6 +278,7 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where frac 0 = "" frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) +-- |Arrays of any type, which may always contain NULLs. instance PGType a => PGType [Maybe a] where pgDecodeBS = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where pa = do @@ -269,17 +288,37 @@ instance PGType a => PGType [Maybe a] where return l nel = Nothing <$ nul P.<|> Just <$> el nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll" - el = pgDecodeBS . LC.pack <$> (qel P.<|> uqel) - qel = P.between (P.char '"') (P.char '"') $ - P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" - uqel = P.many1 (P.noneOf "\",{}") + el = pgDecodeBS . LC.pack <$> parseDQuote "\",{}" pgEncode l = '{' : intercalate "," (map el l) ++ "}" where el Nothing = "null" - el (Just e) = '"' : es (pgEncode e) -- quoting may not be necessary but is always safe - es "" = "\"" - es (c@'"':r) = '\\':c:es r - es (c@'\\':r) = '\\':c:es r - es (c:r) = c:es r + el (Just e) = dQuote "\",\\{}" $ pgEncode e + +instance PGType a => PGType (Range.Range a) where + pgDecodeBS = either (error . ("pgDecode range: " ++) . show) id . P.parse per "array" where + per = Range.Empty <$ pe P.<|> pr + pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy" + pp = pgDecodeBS . LC.pack <$> parseDQuote "\"(),[\\]" + pc c o = True <$ P.char c P.<|> False <$ P.char o + pb = P.optionMaybe 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)) + pgEncode Range.Empty = "empty" + pgEncode (Range.Range (Range.Lower l) (Range.Upper u)) = + pc '[' '(' l + : pb (Range.bound l) + ++ ',' + : pb (Range.bound u) + ++ [pc ']' ')' u] + where + pb Nothing = "" + pb (Just b) = dQuote "\"(),[\\]" $ pgEncode b + pc c o b = if Range.boundClosed b then c else o {- -- Since PG values cannot contain '\0', we use it as a special flag for NULL values (which will later be encoded with length -1) @@ -372,6 +411,24 @@ pgTypes = --, (2950, 2951, "uuid", ?) ] +rangeType :: TH.Type -> TH.Type +rangeType = TH.AppT (TH.ConT ''Range.Range) + +rangeTypes :: [(OID, OID, String, TH.Name)] +rangeTypes = + [ (3904, 3905, "int4range", ''Int32) + , (3906, 3907, "numrange", ''Rational) + , (3908, 3909, "tsrange", ''Time.LocalTime) + , (3910, 3911, "tstzrange", ''Time.UTCTime) + , (3912, 3913, "daterange", ''Time.Day) + , (3926, 3927, "int8range", ''Int32) + ] + defaultTypeMap :: PGTypeMap -defaultTypeMap = Map.fromAscList [(o, PGType n (TH.ConT t)) | (o, _, n, t) <- pgTypes] - `Map.union` Map.fromList [(o, pgArrayType n (TH.ConT t)) | (_, o, n, t) <- pgTypes] +defaultTypeMap = + Map.fromAscList + ([(o, PGType n (TH.ConT t)) | (o, _, n, t) <- pgTypes] + ++ [(o, PGType n (rangeType (TH.ConT t))) | (o, _, n, t) <- rangeTypes]) + `Map.union` Map.fromList + ([(o, pgArrayType n (TH.ConT t)) | (_, o, n, t) <- pgTypes] + ++ [(o, pgArrayType n (rangeType (TH.ConT t))) | (_, o, n, t) <- rangeTypes]) diff --git a/templatepg.cabal b/templatepg.cabal index 060d6b7..90609d3 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -47,6 +47,7 @@ Library Database.TemplatePG.Query Database.TemplatePG.SQL Database.TemplatePG.Types + Database.TemplatePG.Range Extensions: TemplateHaskell GHC-Options: -Wall -fno-warn-type-defaults if flag(md5) From b3e3d3ad0d751d0a8915fbe198f3125619fa55e0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 01:19:39 -0500 Subject: [PATCH 063/306] Add int4range to test --- test/Main.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index b3ed3ac..b8a6c77 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,6 +8,7 @@ import System.Exit (exitSuccess, exitFailure) import Database.TemplatePG import Database.TemplatePG.Types (OID) import Database.TemplatePG.SQL +import qualified Database.TemplatePG.Range as Range import Connect assert :: Bool -> IO () @@ -36,9 +37,10 @@ main = do d = Time.localDay t p = -34881559 l = [Just "a\\\"b,c", Nothing] - Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l') <- - $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[]") c - assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' + r = Range.normalRange (Just (-2)) Nothing + Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l', Just r') <- + $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[], {r}::int4range") c + assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' ["box"] <- simple c 603 [Just "box"] <- simpleApply c 603 From 754a9e2ab237cf31b53e7560c7ac3294dfa0e1e9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 02:29:53 -0500 Subject: [PATCH 064/306] Revert d42096fa7f373a45689bbe3f6cc91f76940cbefe Finalizing values that may be replaced is not so great. It wasn't doing what it was meant to anyway. --- Database/TemplatePG/Connection.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs index dca71ea..86810b9 100644 --- a/Database/TemplatePG/Connection.hs +++ b/Database/TemplatePG/Connection.hs @@ -12,7 +12,6 @@ import qualified Language.Haskell.TH as TH import Network (PortID(UnixSocket, PortNumber), PortNumber) import System.Environment (getEnv, lookupEnv) import System.IO.Unsafe (unsafePerformIO) -import System.Mem.Weak (addFinalizer) import Database.TemplatePG.Types import Database.TemplatePG.Protocol @@ -34,9 +33,7 @@ thConnection = unsafePerformIO $ newMVar $ Left $ do -- |Run an action using the TemplatePG connection. -- This is meant to be used from other TH code (though it will work during normal runtime if just want a simple PGConnection based on TPG environment variables). withTHConnection :: (PGConnection -> IO a) -> IO a -withTHConnection f = modifyMVar thConnection $ either (final =<<) return >=> (\c -> (,) (Right c) <$> f c) where - -- This doesn't work in most cases because thConnection is global, but there doesn't seem to be any way to do TH "cleanup": - final c = c <$ addFinalizer c (pgDisconnect c) +withTHConnection f = modifyMVar thConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) setTHConnection :: Either (IO PGConnection) PGConnection -> IO () setTHConnection = void . swapMVar thConnection From 204d37760dbe7404ad9ee0a205071b5a6a9168b2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 02:41:34 -0500 Subject: [PATCH 065/306] Automatic generation of enum types --- Database/TemplatePG/Connection.hs | 4 +-- Database/TemplatePG/Enum.hs | 49 +++++++++++++++++++++++++++++++ Database/TemplatePG/Protocol.hs | 8 ++--- Database/TemplatePG/Query.hs | 2 +- Database/TemplatePG/Range.hs | 16 ++++++---- Database/TemplatePG/Types.hs | 3 +- TODO | 1 - templatepg.cabal | 4 ++- test/Main.hs | 4 +-- 9 files changed, 73 insertions(+), 18 deletions(-) create mode 100644 Database/TemplatePG/Enum.hs diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs index 86810b9..83f4f6a 100644 --- a/Database/TemplatePG/Connection.hs +++ b/Database/TemplatePG/Connection.hs @@ -24,10 +24,10 @@ thConnection = unsafePerformIO $ newMVar $ Left $ do database <- getEnv "TPG_DB" hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" socket <- lookupEnv "TPG_SOCK" - portNum <- maybe (5432 :: PortNumber) (fromIntegral . read) <$> lookupEnv "TPG_PORT" + portNum <- maybe (5432 :: PortNumber) ((fromIntegral :: Int -> PortNumber) . read) <$> lookupEnv "TPG_PORT" username <- fromMaybe "postgres" <$> lookupEnv "TPG_USER" password <- fromMaybe "" <$> lookupEnv "TPG_PASS" - let portId = maybe (PortNumber $ fromIntegral portNum) UnixSocket socket + let portId = maybe (PortNumber portNum) UnixSocket socket pgConnect hostName portId database username password -- |Run an action using the TemplatePG connection. diff --git a/Database/TemplatePG/Enum.hs b/Database/TemplatePG/Enum.hs new file mode 100644 index 0000000..b185594 --- /dev/null +++ b/Database/TemplatePG/Enum.hs @@ -0,0 +1,49 @@ +-- | +-- Module: Database.TemplatePG.Enum +-- Copyright: 2015 Dylan Simon +-- +-- Support for PostgreSQL enums. + +module Database.TemplatePG.Enum + ( makePGEnum + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Data.Foldable (toList) +import qualified Data.Sequence as Seq +import qualified Language.Haskell.TH as TH + +import Database.TemplatePG.Protocol +import Database.TemplatePG.Connection +import Database.TemplatePG.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) +-- @ +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 valf = do + (_, vals) <- TH.runIO $ withTHConnection $ \c -> + pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgLiteral name ++ " ORDER BY enumsortorder" + when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" + let + valn = map (\[Just v] -> let s = pgDecodeBS v in (TH.StringL s, TH.mkName $ valf s)) $ toList vals + (++) + [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded] + , TH.InstanceD [] (TH.AppT (TH.ConT ''PGType) typt) + [ TH.FunD 'pgDecode $ map (\(l, n) -> TH.Clause [TH.LitP l] (TH.NormalB (TH.ConE n)) []) valn + , TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.ConP n []] (TH.NormalB (TH.LitE l)) []) valn + ] + ] <$> registerPGType name typt + where + typn = TH.mkName typs + typt = TH.ConT typn diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index e57d059..149f666 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -65,11 +65,11 @@ data PGConnection = PGConnection { connHandle :: Handle , connDebug :: !Bool , connLogMessage :: MessageFields -> IO () - , connPid :: !Word32 - , connKey :: !Word32 + , connPid :: !Word32 -- unused + , connKey :: !Word32 -- unused , connParameters :: Map.Map String String - , connTypes :: PGTypeMap - , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) + , connTypes :: PGTypeMap -- only used at TH compile time (move out?) + , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) -- only use at run-time , connState :: IORef PGState } diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 03dbcaf..1f7ed78 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -118,7 +118,7 @@ convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] -- 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 where +sqlPlaceholders = sph (1 :: Int) where sph n ('$':'$':'{':s) = first (('$':) . ('{':)) $ sph n s sph n ('$':'{':s) | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = diff --git a/Database/TemplatePG/Range.hs b/Database/TemplatePG/Range.hs index 6fed450..de79f2a 100644 --- a/Database/TemplatePG/Range.hs +++ b/Database/TemplatePG/Range.hs @@ -8,6 +8,8 @@ module Database.TemplatePG.Range where +import Control.Applicative ((<$)) +import Control.Monad (guard) import Data.Monoid ((<>)) data Bound a @@ -91,18 +93,22 @@ isFull :: Range a -> Bool isFull (Range (Lower Unbounded) (Upper Unbounded)) = True isFull _ = False -point :: a -> Range a +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) -normalRange :: Ord a => Maybe a -> Maybe a -> Range a -normalRange l u = range (mb True l) (mb False u) where +normal :: Ord a => Maybe a -> Maybe a -> Range a +normal l u = range (mb True l) (mb False u) where mb = maybe Unbounded . Bounded -boundedRange :: Ord a => a -> a -> Range a -boundedRange l u = range (Bounded True l) (Bounded False u) +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 diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 916cb68..ddda15b 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -266,7 +266,7 @@ instance PGType Rational where pgEncode r | denominator r == 0 = "NaN" -- this can't happen | otherwise = take 30 (showRational (r / (10 ^^ e))) ++ 'e' : show e where - e = floor $ logBase 10 $ fromRational $ abs r -- not great, and arbitrarily truncate somewhere + 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)" @@ -279,6 +279,7 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) -- |Arrays of any type, which may always contain NULLs. +-- This will work for any type using comma as a delimiter (i.e., anything but @box@). instance PGType a => PGType [Maybe a] where pgDecodeBS = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where pa = do diff --git a/TODO b/TODO index 6f500dd..ce7222c 100644 --- a/TODO +++ b/TODO @@ -2,7 +2,6 @@ * Add support for returning records (instead of tuples). * Make insertIgnore useable in transactions. * Figure out how to make withTransaction useable in other monads. -* Add support for enumerated types (look in pg_enum with unknown types). * Add explicit casts to all values going in: $(execute "UPDATE link_to_review \ diff --git a/templatepg.cabal b/templatepg.cabal index 90609d3..fb050af 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -47,9 +47,10 @@ Library Database.TemplatePG.Query Database.TemplatePG.SQL Database.TemplatePG.Types + Database.TemplatePG.Enum Database.TemplatePG.Range Extensions: TemplateHaskell - GHC-Options: -Wall -fno-warn-type-defaults + GHC-Options: -Wall if flag(md5) Build-Depends: cryptohash >= 0.5 CPP-options: -DUSE_MD5 @@ -61,3 +62,4 @@ test-suite test buildable: True hs-source-dirs: test Extensions: TemplateHaskell, QuasiQuotes + GHC-Options: -Wall diff --git a/test/Main.hs b/test/Main.hs index b8a6c77..13565d9 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,6 @@ module Main (main) where import qualified Data.Time as Time -import Data.Int (Int32) -import System.Environment (setEnv) import System.Exit (exitSuccess, exitFailure) import Database.TemplatePG @@ -37,7 +35,7 @@ main = do d = Time.localDay t p = -34881559 l = [Just "a\\\"b,c", Nothing] - r = Range.normalRange (Just (-2)) Nothing + r = Range.normal (Just (-2)) Nothing Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l', Just r') <- $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[], {r}::int4range") c assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' From 3c374465138a93b04efc5b3ce05f5ec52bcc5e67 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 14:02:14 -0500 Subject: [PATCH 066/306] Refactor TH connection/state management, PGDatabase --- Database/TemplatePG.hs | 14 +-- Database/TemplatePG/Connection.hs | 57 ------------ Database/TemplatePG/Enum.hs | 6 +- Database/TemplatePG/Protocol.hs | 139 +++++++++++++----------------- Database/TemplatePG/Query.hs | 14 ++- Database/TemplatePG/SQL.hs | 2 +- Database/TemplatePG/TH.hs | 137 +++++++++++++++++++++++++++++ Database/TemplatePG/Types.hs | 21 ++--- templatepg.cabal | 4 +- test/Connect.hs | 10 ++- test/Main.hs | 5 +- 11 files changed, 238 insertions(+), 171 deletions(-) delete mode 100644 Database/TemplatePG/Connection.hs create mode 100644 Database/TemplatePG/TH.hs diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index d5b9430..13387d9 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -14,10 +14,12 @@ module Database.TemplatePG -- **Connections -- $connect + , PGDatabase(..) + , defaultPGDatabase , PGConnection , pgConnect , pgDisconnect - , useTHConnection + , useTPGDatabase -- **Queries -- $query @@ -39,7 +41,7 @@ module Database.TemplatePG -- **Types -- $types - , registerPGType + , registerTPGType -- **A Note About NULL -- $nulls @@ -57,7 +59,7 @@ module Database.TemplatePG ) where import Database.TemplatePG.Protocol -import Database.TemplatePG.Connection +import Database.TemplatePG.TH import Database.TemplatePG.Query import Database.TemplatePG.SQL @@ -98,11 +100,11 @@ import Database.TemplatePG.SQL -- 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, TemplatePG needs to make its own connection to the database in order to describe queries. --- By default, it will use the following environment variables. You must set at least @TPG_DB@: +-- By default, it will use the following environment variables: -- --- [@TPG_DB@] the database name to use +-- [@TPG_DB@] the database name to use (default: same as user) -- --- [@TPG_USER@] the username to connect as (default: @postgres@) +-- [@TPG_USER@] the username to connect as (default: @$USER@ or @postgres@) -- -- [@TPG_PASS@] the password to use (default: /empty/) -- diff --git a/Database/TemplatePG/Connection.hs b/Database/TemplatePG/Connection.hs deleted file mode 100644 index 83f4f6a..0000000 --- a/Database/TemplatePG/Connection.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Database.TemplatePG.Connection - ( withTHConnection - , useTHConnection - , registerPGType - ) where - -import Control.Applicative ((<$>), (<$)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, swapMVar) -import Control.Monad ((>=>), when, void) -import Data.Maybe (fromMaybe) -import qualified Language.Haskell.TH as TH -import Network (PortID(UnixSocket, PortNumber), PortNumber) -import System.Environment (getEnv, lookupEnv) -import System.IO.Unsafe (unsafePerformIO) - -import Database.TemplatePG.Types -import Database.TemplatePG.Protocol - --- |Grab a PostgreSQL connection for compile time. We do so through the --- environment variables: @TPG_DB@, @TPG_HOST@, @TPG_PORT@, @TPG_USER@, and --- @TPG_PASS@. Only TPG_DB is required. -thConnection :: MVar (Either (IO PGConnection) PGConnection) -thConnection = unsafePerformIO $ newMVar $ Left $ do - database <- getEnv "TPG_DB" - hostName <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" - socket <- lookupEnv "TPG_SOCK" - portNum <- maybe (5432 :: PortNumber) ((fromIntegral :: Int -> PortNumber) . read) <$> lookupEnv "TPG_PORT" - username <- fromMaybe "postgres" <$> lookupEnv "TPG_USER" - password <- fromMaybe "" <$> lookupEnv "TPG_PASS" - let portId = maybe (PortNumber portNum) UnixSocket socket - pgConnect hostName portId database username password - --- |Run an action using the TemplatePG connection. --- This is meant to be used from other TH code (though it will work during normal runtime if just want a simple PGConnection based on TPG environment variables). -withTHConnection :: (PGConnection -> IO a) -> IO a -withTHConnection f = modifyMVar thConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) - -setTHConnection :: Either (IO PGConnection) PGConnection -> IO () -setTHConnection = void . swapMVar thConnection - --- |Specify an alternative connection method to use during TemplatePG 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. -useTHConnection :: IO PGConnection -> TH.Q [TH.Dec] -useTHConnection c = [] <$ TH.runIO (setTHConnection (Left c)) - -modifyTHConnection :: (PGConnection -> PGConnection) -> IO () -modifyTHConnection f = modifyMVar_ thConnection $ return . either (Left . fmap f) (Right . f) - --- |Register a new handler for PostgreSQL type and a Haskell type, which should be an instance of 'PGType'. --- This should be called as a top-level declaration and produces no code. -registerPGType :: String -> TH.Type -> TH.Q [TH.Dec] -registerPGType name typ = [] <$ TH.runIO (do - (oid, loid) <- withTHConnection (\c -> getTypeOID c name) - modifyTHConnection (pgAddType oid (PGType name typ)) - when (loid /= 0) $ - modifyTHConnection (pgAddType loid (pgArrayType name typ))) diff --git a/Database/TemplatePG/Enum.hs b/Database/TemplatePG/Enum.hs index b185594..fdcb3e7 100644 --- a/Database/TemplatePG/Enum.hs +++ b/Database/TemplatePG/Enum.hs @@ -15,7 +15,7 @@ import qualified Data.Sequence as Seq import qualified Language.Haskell.TH as TH import Database.TemplatePG.Protocol -import Database.TemplatePG.Connection +import Database.TemplatePG.TH import Database.TemplatePG.Types -- |Create a new enum type corresponding to the given PostgreSQL enum type. @@ -32,7 +32,7 @@ makePGEnum :: String -- ^ PostgreSQL enum type name -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ -> TH.DecsQ makePGEnum name typs valf = do - (_, vals) <- TH.runIO $ withTHConnection $ \c -> + (_, vals) <- TH.runIO $ withTPGConnection $ \c -> pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgLiteral name ++ " ORDER BY enumsortorder" when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let @@ -43,7 +43,7 @@ makePGEnum name typs valf = do [ TH.FunD 'pgDecode $ map (\(l, n) -> TH.Clause [TH.LitP l] (TH.NormalB (TH.ConE n)) []) valn , TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.ConP n []] (TH.NormalB (TH.LitE l)) []) valn ] - ] <$> registerPGType name typt + ] <$> registerTPGType name typt where typn = TH.mkName typs typt = TH.ConT typn diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index 149f666..e331e1a 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -5,23 +5,21 @@ -- PostgreSQL server over TCP/IP. You probably don't want to use this module -- directly. -module Database.TemplatePG.Protocol ( PGConnection - , PGData - , PGError(..) - , messageCode - , pgConnect - , pgDisconnect - , pgDescribe - , pgSimpleQuery - , pgPreparedQuery - , pgPreparedLazyQuery - , pgCloseStatement - , pgAddType - , getTypeOID - , getPGType - ) where - -import Database.TemplatePG.Types +module Database.TemplatePG.Protocol ( + PGDatabase(..) + , defaultPGDatabase + , PGConnection + , PGData + , PGError(..) + , pgMessageCode + , pgConnect + , pgDisconnect + , pgDescribe + , pgSimpleQuery + , pgPreparedQuery + , pgPreparedLazyQuery + , pgCloseStatement + ) where import Control.Applicative ((<$>), (<$)) import Control.Arrow (second) @@ -38,19 +36,19 @@ import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (foldMap, forM_, toList) import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) -import Data.List (find) import qualified Data.Map as Map -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) import qualified Data.Sequence as Seq import Data.Typeable (Typeable) import Data.Word (Word8, Word32) -import Network (HostName, PortID, connectTo) -import System.Environment (lookupEnv) +import Network (HostName, PortID(..), connectTo) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) +import Database.TemplatePG.Types + data PGState = StateUnknown | StateIdle @@ -59,17 +57,25 @@ data PGState | 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@) + } + -- |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 - , connDebug :: !Bool - , connLogMessage :: MessageFields -> IO () + , connDatabase :: !PGDatabase , connPid :: !Word32 -- unused , connKey :: !Word32 -- unused , connParameters :: Map.Map String String - , connTypes :: PGTypeMap -- only used at TH compile time (move out?) - , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) -- only use at run-time + , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) , connState :: IORef PGState } @@ -165,12 +171,23 @@ displayMessage m = "PG" ++ f 'S' ++ " [" ++ f 'C' ++ "]: " ++ f 'M' ++ '\n' : f -- |Message SQLState code. -- See . -messageCode :: MessageFields -> String -messageCode = maybe "" LC.unpack . Map.lookup (c2w 'C') +pgMessageCode :: MessageFields -> String +pgMessageCode = maybe "" LC.unpack . Map.lookup (c2w '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 + #ifdef USE_MD5 md5 :: L.ByteString -> L.ByteString md5 = L.fromStrict . Hash.digestToHexByteString . (Hash.hashlazy :: L.ByteString -> Hash.Digest Hash.MD5) @@ -216,9 +233,9 @@ messageBody Terminate = (Just 'X', mempty) -- |Send a message to PostgreSQL (low-level). pgSend :: PGConnection -> PGFrontendMessage -> IO () -pgSend PGConnection{ connHandle = h, connDebug = d, connState = sr } msg = do +pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do writeIORef sr StateUnknown - when d $ putStrLn $ "> " ++ show msg + when (connDebug c) $ putStrLn $ "> " ++ show msg B.hPutBuilder h $ foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + L.length b) L.hPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length where (t, b) = second B.toLazyByteString $ messageBody msg @@ -291,10 +308,10 @@ runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOr -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. pgReceive :: PGConnection -> IO PGBackendMessage -pgReceive c@PGConnection{ connHandle = h, connDebug = d } = do +pgReceive c@PGConnection{ connHandle = h } = do (typ, len) <- runGet (liftM2 (,) G.getWord8 G.getWord32be) =<< L.hGet h 5 msg <- runGet (getMessageBody $ w2c typ) =<< L.hGet h (fromIntegral len - 4) - when d $ putStrLn $ "< " ++ show msg + when (connDebug c) $ putStrLn $ "< " ++ show msg case msg of ReadyForQuery s -> msg <$ writeIORef (connState c) s NoticeResponse{ messageFields = m } -> @@ -307,31 +324,23 @@ pgHandle :: PGConnection -> (PGBackendMessage -> IO a) -> IO a pgHandle c = (pgReceive c >>=) -- |Connect to a PostgreSQL server. -pgConnect :: HostName -- ^ the host to connect to - -> PortID -- ^ the port to connect on - -> String -- ^ the database to connect to - -> String -- ^ the username to connect as - -> String -- ^ the password to connect with - -> IO PGConnection -- ^ a handle to communicate with the PostgreSQL server on -pgConnect host port db user pass = do - debug <- isJust <$> lookupEnv "TPG_DEBUG" +pgConnect :: PGDatabase -> IO PGConnection +pgConnect db = do state <- newIORef StateUnknown prep <- newIORef (0, Map.empty) - h <- connectTo host port + h <- connectTo (pgDBHost db) (pgDBPort db) let c = PGConnection { connHandle = h - , connDebug = debug - , connLogMessage = defaultLogMessage + , connDatabase = db , connPid = 0 , connKey = 0 , connParameters = Map.empty - , connTypes = defaultTypeMap , connPreparedStatements = prep , connState = state } pgSend c $ StartupMessage - [ ("user", user) - , ("database", db) + [ ("user", pgDBUser db) + , ("database", pgDBName db) , ("client_encoding", "UTF8") , ("standard_conforming_strings", "on") , ("bytea_output", "hex") @@ -347,12 +356,12 @@ pgConnect host port db user pass = do 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 $ U.fromString pass + pgSend c $ PasswordMessage $ U.fromString $ pgDBPass db pgFlush c conn c #ifdef USE_MD5 msg c (AuthenticationMD5Password salt) = do - pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pass ++ user)) `L.append` salt) + pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pgDBPass db ++ pgDBUser db)) `L.append` salt) pgFlush c conn c #endif @@ -376,35 +385,6 @@ pgSync c@PGConnection{ connState = sr } = do _ <- pgReceive c `catch` \(PGError m) -> ErrorResponse m <$ connLogMessage c m pgSync c --- |Add a new type handler for the given type OID. -pgAddType :: OID -> PGTypeHandler -> PGConnection -> PGConnection -pgAddType oid th p = p{ connTypes = Map.insert oid th $ connTypes p } - --- |Lookup the OID of a database type by internal or formatted name (case sensitive). --- Fail if not found. -getTypeOID :: PGConnection -> String -> IO (OID, OID) -getTypeOID c@PGConnection{ connTypes = types } t - | Just oid <- readMaybe t = return (oid, 0) - | Just oid <- findType t = return (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of - | otherwise = do - (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) - case toList r of - [] -> fail $ "Unknown PostgreSQL type: " ++ t - [[Just o, Just lo]] -> return (pgDecodeBS o, pgDecodeBS lo) - _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r - where - findType n = fmap fst $ find ((==) n . pgTypeName . snd) $ Map.toList types - --- |Lookup the type handler for a given type OID. -getPGType :: PGConnection -> OID -> IO PGTypeHandler -getPGType c@PGConnection{ connTypes = types } oid = - maybe notype return $ Map.lookup oid types where - notype = do - (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) - case toList r of - [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ U.toString s - _ -> fail $ "Unknown PostgreSQL type: " ++ show oid - -- |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 @@ -412,7 +392,7 @@ getPGType c@PGConnection{ connTypes = types } oid = pgDescribe :: PGConnection -> String -- ^ SQL string -> [OID] -- ^ Optional type specifications -> Bool -- ^ Guess nullability, otherwise assume everything is - -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. + -> 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 } @@ -422,15 +402,14 @@ pgDescribe h sql types nulls = do ParseComplete <- pgReceive h ParameterDescription ps <- pgReceive h m <- pgReceive h - liftM2 (,) (mapM (getPGType h) ps) $ case m of + (,) ps <$> case m of NoData -> return [] RowDescription r -> mapM desc r _ -> fail $ "describeStatement: unexpected response: " ++ show m where desc (ColDescription name tab col typ) = do - t <- getPGType h typ n <- nullable tab col - return (name, t, n) + 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. diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 1f7ed78..7c24d78 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -31,7 +31,7 @@ import Numeric (readDec) import Database.TemplatePG.Types import Database.TemplatePG.Protocol -import Database.TemplatePG.Connection +import Database.TemplatePG.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. @@ -174,10 +174,8 @@ simpleFlags = QueryFlags False Nothing -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do - (at, pt, rt) <- TH.runIO $ withTHConnection $ \c -> do - at <- mapM (fmap fst . getTypeOID c) $ fromMaybe [] prep - (pt, rt) <- pgDescribe c sqlp at (not nulls) - return (at, pt, rt) + (pt, rt) <- TH.runIO $ withTPGState $ \c -> + tpgDescribe c 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 '$${'" (vars, vals) <- mapAndUnzipM (\t -> do @@ -186,7 +184,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do conv <- convertRow 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) at) `TH.AppE` TH.ListE vals + | otherwise = TH.ConE 'PreparedQuery `TH.AppE` stringL sqlp `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . pgTypeOID) pt) `TH.AppE` TH.ListE vals foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle @@ -206,8 +204,8 @@ qqQuery f@QueryFlags{ flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = qqQuery f q = makePGQuery f q qqType :: String -> TH.TypeQ -qqType t = fmap pgTypeType $ TH.runIO $ withTHConnection $ \c -> - getPGType c . fst =<< getTypeOID c t +qqType t = fmap pgTypeType $ TH.runIO $ withTPGState $ \c -> + getTPGType c . fst =<< getTPGTypeOID c t -- |A quasi-quoter for PGSQL queries. -- diff --git a/Database/TemplatePG/SQL.hs b/Database/TemplatePG/SQL.hs index 88713c9..04203e7 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/TemplatePG/SQL.hs @@ -88,4 +88,4 @@ rollback h = void $ 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 (PGError m) = guard (messageCode m == "24505") + uniquenessError (PGError m) = guard (pgMessageCode m == "24505") diff --git a/Database/TemplatePG/TH.hs b/Database/TemplatePG/TH.hs new file mode 100644 index 0000000..d084e6c --- /dev/null +++ b/Database/TemplatePG/TH.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE PatternGuards #-} +-- | +-- Module: Database.TemplatePG.TH +-- Copyright: 2015 Dylan Simon +-- +-- Support functions for compile-time PostgreSQL connection and state management. +-- Although this is meant to be used from other TH code, it will work during normal runtime if just want simple PGConnection management. + +module Database.TemplatePG.TH + ( getTPGDatabase + , withTPGState + , withTPGConnection + , useTPGDatabase + , registerTPGType + , getTPGTypeOID + , getTPGType + , tpgDescribe + ) where + +import Control.Applicative ((<$>), (<$), (<|>)) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, swapMVar) +import Control.Monad ((>=>), void, liftM2) +import Data.Foldable (toList) +import Data.List (find) +import qualified Data.Map as Map +import Data.Maybe (isJust, fromMaybe) +import qualified Language.Haskell.TH as TH +import Network (PortID(UnixSocket, PortNumber), PortNumber) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) +import Text.Read (readMaybe) + +import Database.TemplatePG.Types +import Database.TemplatePG.Protocol + +data TPGState = TPGState + { tpgConnection :: PGConnection + , tpgTypes :: PGTypeMap + } + +-- |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 + } + +tpgConnect :: PGDatabase -> IO TPGState +tpgConnect db = do + c <- pgConnect db + return $ TPGState c defaultPGTypeMap + +tpgState :: MVar (Either (IO TPGState) TPGState) +tpgState = unsafePerformIO $ newMVar $ Left $ tpgConnect =<< getTPGDatabase + +withTPGState :: (TPGState -> IO a) -> IO a +withTPGState f = modifyMVar tpgState $ either id return >=> (\c -> (,) (Right c) <$> f c) + +-- |Run an action using the TemplatePG connection. +withTPGConnection :: (PGConnection -> IO a) -> IO a +withTPGConnection f = withTPGState (f . tpgConnection) + +setTPGState :: Either (IO TPGState) TPGState -> IO () +setTPGState = void . swapMVar tpgState + +-- |Specify an alternative database to use during TemplatePG 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 will also clear all types registered with 'registerTPGType'. +useTPGDatabase :: PGDatabase -> TH.Q [TH.Dec] +useTPGDatabase db = [] <$ TH.runIO (setTPGState $ Left $ tpgConnect db) + +modifyTPGState :: (TPGState -> TPGState) -> IO () +modifyTPGState f = modifyMVar_ tpgState $ return . either (Left . fmap f) (Right . f) + +-- |Add a new type handler for the given type OID. +tpgAddType :: PGTypeHandler -> TPGState -> TPGState +tpgAddType h tpg = tpg{ tpgTypes = Map.insert (pgTypeOID h) h $ tpgTypes tpg } + +-- |Lookup the OID of a database type by internal or formatted name (case sensitive). +-- Fail if not found. +getTPGTypeOID :: TPGState -> String -> IO (OID, OID) +getTPGTypeOID TPGState{ tpgConnection = c, tpgTypes = types } t + | Just oid <- readMaybe t = return (oid, 0) + | Just oid <- findType t = return (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of + | otherwise = do + (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) + case toList r of + [] -> fail $ "Unknown PostgreSQL type: " ++ t + [[Just o, Just lo]] -> return (pgDecodeBS o, pgDecodeBS lo) + _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r + where + findType n = fmap fst $ find ((==) n . pgTypeName . snd) $ Map.toList types + +-- |Lookup the type handler for a given type OID. +getTPGType :: TPGState -> OID -> IO PGTypeHandler +getTPGType TPGState{ tpgConnection = c, tpgTypes = types } oid = + maybe notype return $ Map.lookup oid types where + notype = do + (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) + case toList r of + [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ show s + _ -> fail $ "Unknown PostgreSQL type: " ++ show oid + +-- |Register a new handler for PostgreSQL type and a Haskell type, which should be an instance of 'PGType'. +-- This should be called as a top-level declaration and produces no code. +registerTPGType :: String -> TH.Type -> TH.Q [TH.Dec] +registerTPGType name typ = TH.runIO $ do + (oid, loid) <- withTPGState (\c -> getTPGTypeOID c name) + modifyTPGState ( + (if loid == 0 then id else tpgAddType (pgArrayType loid name typ)) + . tpgAddType (PGType oid name typ)) + return [] + +-- |A type-aware wrapper to 'pgDescribe' +tpgDescribe :: TPGState -> String -> [String] -> Bool -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) +tpgDescribe tpg sql types nulls = do + at <- mapM (fmap fst . getTPGTypeOID tpg) types + (pt, rt) <- pgDescribe (tpgConnection tpg) sql at nulls + pth <- mapM (getTPGType tpg) pt + rth <- mapM (\(c, t, n) -> do + th <- getTPGType tpg t + return (c, th, n)) rt + return (pth, rth) diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index ddda15b..9f1c2ed 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -12,7 +12,7 @@ module Database.TemplatePG.Types , pgTypeEncoder , pgTypeEscaper , PGTypeMap - , defaultTypeMap + , defaultPGTypeMap , pgArrayType ) where @@ -351,7 +351,8 @@ instance PGType a => PossiblyMaybe (Maybe a) a where maybePossibly = id data PGTypeHandler = PGType - { pgTypeName :: String -- ^ The internal PostgreSQL name of the type + { pgTypeOID :: OID + , pgTypeName :: String -- ^ The internal PostgreSQL name of the type , pgTypeType :: TH.Type -- ^ The equivalent Haskell type to which it is marshalled (must be an instance of 'PGType' } deriving (Show) @@ -375,8 +376,8 @@ type PGTypeMap = Map.Map OID PGTypeHandler arrayType :: TH.Type -> TH.Type arrayType = TH.AppT TH.ListT . TH.AppT (TH.ConT ''Maybe) -pgArrayType :: String -> TH.Type -> PGTypeHandler -pgArrayType n t = PGType ('_':n) (arrayType t) +pgArrayType :: OID -> String -> TH.Type -> PGTypeHandler +pgArrayType o n t = PGType o ('_':n) (arrayType t) pgTypes :: [(OID, OID, String, TH.Name)] pgTypes = @@ -425,11 +426,11 @@ rangeTypes = , (3926, 3927, "int8range", ''Int32) ] -defaultTypeMap :: PGTypeMap -defaultTypeMap = +defaultPGTypeMap :: PGTypeMap +defaultPGTypeMap = Map.fromAscList - ([(o, PGType n (TH.ConT t)) | (o, _, n, t) <- pgTypes] - ++ [(o, PGType n (rangeType (TH.ConT t))) | (o, _, n, t) <- rangeTypes]) + ([(o, PGType o n (TH.ConT t)) | (o, _, n, t) <- pgTypes] + ++ [(o, PGType o n (rangeType (TH.ConT t))) | (o, _, n, t) <- rangeTypes]) `Map.union` Map.fromList - ([(o, pgArrayType n (TH.ConT t)) | (_, o, n, t) <- pgTypes] - ++ [(o, pgArrayType n (rangeType (TH.ConT t))) | (_, o, n, t) <- rangeTypes]) + ([(o, pgArrayType o n (TH.ConT t)) | (_, o, n, t) <- pgTypes] + ++ [(o, pgArrayType o n (rangeType (TH.ConT t))) | (_, o, n, t) <- rangeTypes]) diff --git a/templatepg.cabal b/templatepg.cabal index fb050af..7b4f17c 100644 --- a/templatepg.cabal +++ b/templatepg.cabal @@ -42,11 +42,11 @@ Library utf8-string Exposed-Modules: Database.TemplatePG - Database.TemplatePG.Connection Database.TemplatePG.Protocol + Database.TemplatePG.Types + Database.TemplatePG.TH Database.TemplatePG.Query Database.TemplatePG.SQL - Database.TemplatePG.Types Database.TemplatePG.Enum Database.TemplatePG.Range Extensions: TemplateHaskell diff --git a/test/Connect.hs b/test/Connect.hs index 314cc83..a9e4e58 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -1,6 +1,12 @@ module Connect where -import Database.TemplatePG (pgConnect) +import Database.TemplatePG (PGDatabase(..), defaultPGDatabase) import Network (PortID(UnixSocket)) -connect = pgConnect "localhost" (UnixSocket "/tmp/.s.PGSQL.5432") "templatepg" "templatepg" "" +db :: PGDatabase +db = defaultPGDatabase + { pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432" + , pgDBName = "templatepg" + , pgDBUser = "templatepg" + } + diff --git a/test/Main.hs b/test/Main.hs index 13565d9..bee166a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -7,13 +7,14 @@ import Database.TemplatePG import Database.TemplatePG.Types (OID) import Database.TemplatePG.SQL import qualified Database.TemplatePG.Range as Range + import Connect assert :: Bool -> IO () assert False = exitFailure assert True = return () -useTHConnection connect +useTPGDatabase db simple :: PGConnection -> OID -> IO [String] simple c t = pgQuery c [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] @@ -26,7 +27,7 @@ preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg main :: IO () main = do - c <- connect + c <- pgConnect db z <- Time.getZonedTime let i = 1 b = True From 8584687f23c728e4cedbb378980cd6442d2262a8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 15:53:57 -0500 Subject: [PATCH 067/306] Add new snaplet package This should perhaps be in a different repository, but seems small enough to be reasonable for now. Based on snaplet-postgresql-simple. --- snaplet/.gitignore | 1 + snaplet/LICENSE | 28 ++++++ snaplet/Setup.hs | 3 + snaplet/Snap/Snaplet/TemplatePG.hs | 136 +++++++++++++++++++++++++++++ snaplet/resources/db/devel.cfg | 18 ++++ snaplet/snaplet-templatepg.cabal | 46 ++++++++++ 6 files changed, 232 insertions(+) create mode 100644 snaplet/.gitignore create mode 100644 snaplet/LICENSE create mode 100644 snaplet/Setup.hs create mode 100644 snaplet/Snap/Snaplet/TemplatePG.hs create mode 100644 snaplet/resources/db/devel.cfg create mode 100644 snaplet/snaplet-templatepg.cabal diff --git a/snaplet/.gitignore b/snaplet/.gitignore new file mode 100644 index 0000000..178135c --- /dev/null +++ b/snaplet/.gitignore @@ -0,0 +1 @@ +/dist/ diff --git a/snaplet/LICENSE b/snaplet/LICENSE new file mode 100644 index 0000000..d958f92 --- /dev/null +++ b/snaplet/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2012, Doug Beardsley +Copyright (c) 2015, Dylan Simon +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 the authors nor the names of its contributors may be used +to endorse or promote products derived from this software without specific +prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/snaplet/Setup.hs b/snaplet/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/snaplet/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/snaplet/Snap/Snaplet/TemplatePG.hs b/snaplet/Snap/Snaplet/TemplatePG.hs new file mode 100644 index 0000000..b1fedf6 --- /dev/null +++ b/snaplet/Snap/Snaplet/TemplatePG.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverloadedStrings #-} +module Snap.Snaplet.TemplatePG ( + -- * The Snaplet + PG(..) + , HasPG(..) + , PGConfig(..) + , pgDefaultConfig + + , pgInit + , pgInit' + + , getPGConfig + , getPGDatabase + , withPG + , liftPG + + , pgRunQuery + , pgExecute + , pgQuery + ) where + +import Control.Applicative +import Control.Lens (set) +import Control.Monad.CatchIO (MonadCatchIO) +import Control.Monad.IO.Class +import Control.Monad.State +import Control.Monad.Reader +import qualified Data.Configurator as C +import qualified Data.Configurator.Types as C +import Data.Pool +import Data.Sequence (Seq) +import Network (PortID(..)) +import Snap + +import qualified Database.TemplatePG as PG +import qualified Database.TemplatePG.Query as PG +import Paths_snaplet_templatepg + + +data PG + = PGPool (Pool PG.PGConnection) + | PGConn PG.PGConnection + +class (MonadCatchIO m) => HasPG m where + getPGState :: m PG + setLocalPGState :: PG -> m a -> m a + +instance HasPG (Handler b PG) where + getPGState = get + setLocalPGState s = local (const s) + +instance (MonadCatchIO m) => HasPG (ReaderT (Snaplet PG) m) where + getPGState = asks (^# snapletValue) + setLocalPGState s = local (set snapletValue s) + +instance (MonadCatchIO m) => HasPG (ReaderT PG m) where + getPGState = ask + setLocalPGState s = local (const s) + +withPG :: HasPG m => m b -> m b +withPG f = do + s <- getPGState + case s of + PGPool p -> withResource p (\c -> setLocalPGState (PGConn c) f) + PGConn _ -> f + +liftPG :: HasPG m => (PG.PGConnection -> IO a) -> m a +liftPG f = do + s <- getPGState + liftPG' s f + +liftPG' :: MonadIO m => PG -> (PG.PGConnection -> IO a) -> m a +liftPG' (PGPool p) f = liftIO (withResource p f) +liftPG' (PGConn c) f = liftIO (f c) + +data PGConfig = PGConfig + { pgConfigDatabase :: PG.PGDatabase + , pgConfigNumStripes :: Int + , pgConfigIdleTime :: Double + , pgConfigResources :: Int + } + +pgDefaultConfig :: PG.PGDatabase -> PGConfig +pgDefaultConfig db = PGConfig db 1 60 16 + +getPGDatabase :: C.Config -> IO PG.PGDatabase +getPGDatabase config = do + host <- C.lookupDefault "localhost" config "host" + port <- C.lookupDefault (5432 :: Int) config "port" + sock <- C.lookup config "sock" + user <- C.require config "user" + db <- C.lookupDefault user config "db" + passwd <- C.lookupDefault "" config "pass" + debug <- C.lookupDefault False config "debug" + return $ PG.PGDatabase + { PG.pgDBHost = host + , PG.pgDBPort = maybe (PortNumber (fromIntegral port)) UnixSocket sock + , PG.pgDBName = db + , PG.pgDBUser = user + , PG.pgDBPass = passwd + , PG.pgDBDebug = debug + , PG.pgDBLogMessage = \_ -> return () -- something better? + } + +getPGConfig :: C.Config -> IO PGConfig +getPGConfig config = do + db <- getPGDatabase config + let def = pgDefaultConfig db + stripes <- C.lookupDefault (pgConfigNumStripes def) config "numStripes" + idle <- C.lookupDefault (pgConfigIdleTime def) config "idleTime" + resources <- C.lookupDefault (pgConfigResources def) config "maxResourcesPerStripe" + return $ PGConfig db stripes idle resources + +pgMake :: Initializer b PG PGConfig -> SnapletInit b PG +pgMake config = makeSnaplet "templatepg" "TemplatePG interface" datadir $ do + c <- config + liftIO $ PGPool <$> createPool (PG.pgConnect (pgConfigDatabase c)) PG.pgDisconnect + (pgConfigNumStripes c) (realToFrac $ pgConfigIdleTime c) (pgConfigResources c) + where + datadir = Just $ (++ "/resources/db") <$> getDataDir + +pgInit :: SnapletInit b PG +pgInit = pgMake (liftIO . getPGConfig =<< getSnapletUserConfig) + +pgInit' :: PGConfig -> SnapletInit b PG +pgInit' config = pgMake (return config) + + +pgRunQuery :: (HasPG m, PG.PGQuery q a) => q -> m (Int, Seq a) +pgRunQuery q = liftPG $ \c -> PG.pgRunQuery c q + +pgExecute :: (HasPG m, PG.PGQuery q ()) => q -> m Int +pgExecute q = liftPG $ \c -> PG.pgExecute c q + +pgQuery :: (HasPG m, PG.PGQuery q a) => q -> m [a] +pgQuery q = liftPG $ \c -> PG.pgQuery c q diff --git a/snaplet/resources/db/devel.cfg b/snaplet/resources/db/devel.cfg new file mode 100644 index 0000000..cc1a1af --- /dev/null +++ b/snaplet/resources/db/devel.cfg @@ -0,0 +1,18 @@ +host = "localhost" +port = 5432 +#sock = "/tmp/.s.PGSQL.5432" +user = "postgres" +pass = "" +db = "testdb" + +# Nmuber of distinct connection pools to maintain. The smallest acceptable +# value is 1. +numStripes = 1 + +# Number of seconds an unused resource is kept open. The smallest acceptable +# value is 0.5 seconds. +idleTime = 60 + +# Maximum number of resources to keep open per stripe. The smallest +# acceptable value is 1. +maxResourcesPerStripe = 16 diff --git a/snaplet/snaplet-templatepg.cabal b/snaplet/snaplet-templatepg.cabal new file mode 100644 index 0000000..9c30eb7 --- /dev/null +++ b/snaplet/snaplet-templatepg.cabal @@ -0,0 +1,46 @@ +name: snaplet-templatepg +version: 0 +synopsis: templatepg snaplet for the Snap Framework +description: This snaplet contains support for using the Postgresql + database with a Snap Framework application via the + templatepg package. Based on snaplet-postgresql-simple. +license: BSD3 +license-file: LICENSE +author: Dylan simon +maintainer: dylan@dylex.net +build-type: Simple +cabal-version: >= 1.6 +homepage: https://github.com/dylex/snaplet-templatepg +category: Snap + +data-files: + resources/db/devel.cfg + +source-repository head + type: git + location: https://github.com/dylex/snaplet-templatepg.git + +Library + exposed-modules: + Snap.Snaplet.TemplatePG + + other-modules: + Paths_snaplet_templatepg + + build-depends: + base >= 4 && < 4.8, + bytestring >= 0.9.1 && < 0.11, + configurator >= 0.2 && < 0.4, + lens, + MonadCatchIO-transformers >= 0.3 && < 0.4, + mtl >= 2 && < 2.3, + templatepg >= 0.3 && < 0.4, + resource-pool-catchio >= 0.2 && < 0.3, + snap >= 0.10 && < 0.14, + transformers >= 0.2 && < 0.5, + containers, + time, + network + + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-orphans -fno-warn-unused-do-bind From 67053ac630c3a25d280568fc553f1b65a2d3d346 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 16:01:06 -0500 Subject: [PATCH 068/306] Add some re-exports from snaplet --- snaplet/Snap/Snaplet/TemplatePG.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/snaplet/Snap/Snaplet/TemplatePG.hs b/snaplet/Snap/Snaplet/TemplatePG.hs index b1fedf6..4842c95 100644 --- a/snaplet/Snap/Snaplet/TemplatePG.hs +++ b/snaplet/Snap/Snaplet/TemplatePG.hs @@ -14,9 +14,11 @@ module Snap.Snaplet.TemplatePG ( , withPG , liftPG + , PG.pgSQL , pgRunQuery , pgExecute , pgQuery + , PG.registerTPGType ) where import Control.Applicative @@ -102,6 +104,8 @@ getPGDatabase config = do , PG.pgDBLogMessage = \_ -> return () -- something better? } +-- TODO: figure out some way to useTPGDatabase + getPGConfig :: C.Config -> IO PGConfig getPGConfig config = do db <- getPGDatabase config From d1b8bdae2a0870692d7429ce5d17195be2e499fd Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 23:24:02 -0500 Subject: [PATCH 069/306] Some support for useTPGDatabase in snaplet --- Database/TemplatePG/Protocol.hs | 4 ++++ snaplet/Snap/Snaplet/TemplatePG.hs | 9 +++++---- snaplet/{resources/db/devel.cfg => db.cfg} | 0 snaplet/snaplet-templatepg.cabal | 2 +- test/Main.hs | 9 +++++---- 5 files changed, 15 insertions(+), 9 deletions(-) rename snaplet/{resources/db/devel.cfg => db.cfg} (100%) diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index e331e1a..e1d8d84 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -67,6 +67,10 @@ data PGDatabase = PGDatabase , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) } +instance Eq PGDatabase where + PGDatabase h1 s1 n1 u1 p1 d1 _ == PGDatabase h2 s2 n2 u2 p2 d2 _ = + h1 == h2 && s1 == s2 && n1 == n2 && u1 == u2 && p1 == p2 && d1 == d2 + -- |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 diff --git a/snaplet/Snap/Snaplet/TemplatePG.hs b/snaplet/Snap/Snaplet/TemplatePG.hs index 4842c95..9774b96 100644 --- a/snaplet/Snap/Snaplet/TemplatePG.hs +++ b/snaplet/Snap/Snaplet/TemplatePG.hs @@ -11,6 +11,7 @@ module Snap.Snaplet.TemplatePG ( , getPGConfig , getPGDatabase + , loadPGDatabase , withPG , liftPG @@ -104,7 +105,9 @@ getPGDatabase config = do , PG.pgDBLogMessage = \_ -> return () -- something better? } --- TODO: figure out some way to useTPGDatabase +-- |Suitable for use with 'useTPGDatabase' +loadPGDatabase :: FilePath -> IO PG.PGDatabase +loadPGDatabase f = getPGDatabase =<< C.load [C.Required f] getPGConfig :: C.Config -> IO PGConfig getPGConfig config = do @@ -116,12 +119,10 @@ getPGConfig config = do return $ PGConfig db stripes idle resources pgMake :: Initializer b PG PGConfig -> SnapletInit b PG -pgMake config = makeSnaplet "templatepg" "TemplatePG interface" datadir $ do +pgMake config = makeSnaplet "templatepg" "TemplatePG interface" (Just getDataDir) $ do c <- config liftIO $ PGPool <$> createPool (PG.pgConnect (pgConfigDatabase c)) PG.pgDisconnect (pgConfigNumStripes c) (realToFrac $ pgConfigIdleTime c) (pgConfigResources c) - where - datadir = Just $ (++ "/resources/db") <$> getDataDir pgInit :: SnapletInit b PG pgInit = pgMake (liftIO . getPGConfig =<< getSnapletUserConfig) diff --git a/snaplet/resources/db/devel.cfg b/snaplet/db.cfg similarity index 100% rename from snaplet/resources/db/devel.cfg rename to snaplet/db.cfg diff --git a/snaplet/snaplet-templatepg.cabal b/snaplet/snaplet-templatepg.cabal index 9c30eb7..b0240d9 100644 --- a/snaplet/snaplet-templatepg.cabal +++ b/snaplet/snaplet-templatepg.cabal @@ -14,7 +14,7 @@ homepage: https://github.com/dylex/snaplet-templatepg category: Snap data-files: - resources/db/devel.cfg + db.cfg source-repository head type: git diff --git a/test/Main.hs b/test/Main.hs index bee166a..73d1223 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,6 @@ module Main (main) where +import Data.Int (Int32) import qualified Data.Time as Time import System.Exit (exitSuccess, exitFailure) @@ -29,14 +30,14 @@ main :: IO () main = do c <- pgConnect db z <- Time.getZonedTime - let i = 1 + let i = 1 :: Int32 b = True - f = 3.14 + f = 3.14 :: Float t = Time.zonedTimeToLocalTime z d = Time.localDay t - p = -34881559 + p = -34881559 :: Time.DiffTime l = [Just "a\\\"b,c", Nothing] - r = Range.normal (Just (-2)) Nothing + r = Range.normal (Just (-2 :: Int32)) Nothing Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l', Just r') <- $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[], {r}::int4range") c assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' From da7ef28e024013ed38882a9fb24475c36cd5c49c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 1 Jan 2015 23:33:59 -0500 Subject: [PATCH 070/306] Rename db.cfg back to devel.cfg But leave it top level... --- snaplet/{db.cfg => devel.cfg} | 0 snaplet/snaplet-templatepg.cabal | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename snaplet/{db.cfg => devel.cfg} (100%) diff --git a/snaplet/db.cfg b/snaplet/devel.cfg similarity index 100% rename from snaplet/db.cfg rename to snaplet/devel.cfg diff --git a/snaplet/snaplet-templatepg.cabal b/snaplet/snaplet-templatepg.cabal index b0240d9..fb044a4 100644 --- a/snaplet/snaplet-templatepg.cabal +++ b/snaplet/snaplet-templatepg.cabal @@ -14,7 +14,7 @@ homepage: https://github.com/dylex/snaplet-templatepg category: Snap data-files: - db.cfg + devel.cfg source-repository head type: git From 7d45fb1d907fbcd86999ffc70cf7fa301f853035 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 16:50:17 -0500 Subject: [PATCH 071/306] Radical change from PGType class to type literals Should now be able to get rid of the type map. Enum is broken. --- Database/TemplatePG/Enum.hs | 8 +- Database/TemplatePG/Protocol.hs | 25 +- Database/TemplatePG/Query.hs | 39 +-- Database/TemplatePG/TH.hs | 40 ++- Database/TemplatePG/Types.hs | 558 +++++++++++++++++++------------- test/Main.hs | 7 +- 6 files changed, 406 insertions(+), 271 deletions(-) diff --git a/Database/TemplatePG/Enum.hs b/Database/TemplatePG/Enum.hs index fdcb3e7..8900dc4 100644 --- a/Database/TemplatePG/Enum.hs +++ b/Database/TemplatePG/Enum.hs @@ -10,6 +10,7 @@ module Database.TemplatePG.Enum import Control.Applicative ((<$>)) import Control.Monad (when) +import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (toList) import qualified Data.Sequence as Seq import qualified Language.Haskell.TH as TH @@ -33,13 +34,14 @@ makePGEnum :: String -- ^ PostgreSQL enum type name -> TH.DecsQ makePGEnum name typs valf = do (_, vals) <- TH.runIO $ withTPGConnection $ \c -> - pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgLiteral name ++ " ORDER BY enumsortorder" + pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgQuote name ++ " ORDER BY enumsortorder" when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let - valn = map (\[Just v] -> let s = pgDecodeBS v in (TH.StringL s, TH.mkName $ valf s)) $ toList vals + valn = map (\[Just v] -> let s = U.toString v in (TH.StringL s, TH.mkName $ valf s)) $ toList vals (++) [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded] - , TH.InstanceD [] (TH.AppT (TH.ConT ''PGType) typt) + -- FIXME + , TH.InstanceD [] (TH.AppT (TH.ConT ''PGParameter) typt) [ TH.FunD 'pgDecode $ map (\(l, n) -> TH.Clause [TH.LitP l] (TH.NormalB (TH.ConE n)) []) valn , TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.ConP n []] (TH.NormalB (TH.LitE l)) []) valn ] diff --git a/Database/TemplatePG/Protocol.hs b/Database/TemplatePG/Protocol.hs index e1d8d84..bc5cf20 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/TemplatePG/Protocol.hs @@ -9,7 +9,7 @@ module Database.TemplatePG.Protocol ( PGDatabase(..) , defaultPGDatabase , PGConnection - , PGData + , PGValues , PGError(..) , pgMessageCode , pgConnect @@ -90,9 +90,6 @@ data ColDescription = ColDescription , colType :: !OID } deriving (Show) --- |A list of (nullable) data values, e.g. a single row or query parameters. -type PGData = [Maybe L.ByteString] - type MessageFields = Map.Map Word8 L.ByteString -- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. @@ -100,7 +97,7 @@ type MessageFields = Map.Map Word8 L.ByteString data PGFrontendMessage = StartupMessage [(String, String)] -- only sent first | CancelRequest !Word32 !Word32 -- sent first on separate connection - | Bind { statementName :: String, bindParameters :: PGData } + | Bind { statementName :: String, bindParameters :: PGValues } | Close { statementName :: String } -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). @@ -135,7 +132,7 @@ data PGBackendMessage -- (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 PGData + | DataRow PGValues | EmptyQueryResponse -- |An ErrorResponse contains the severity, "SQLSTATE", and -- message of an error. See @@ -421,9 +418,9 @@ pgDescribe h sql types nulls = do | 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 = " ++ pgLiteral oid ++ " AND attnum = " ++ pgLiteral col) + (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ show oid ++ " AND attnum = " ++ show col) case toList r of - [[Just s]] -> return $ not $ pgDecodeBS s + [[Just s]] -> return $ not $ pgDecode pgBoolType s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col | otherwise = return True @@ -438,7 +435,7 @@ rowsAffected = ra . LC.words where -- cannot bind parameters. Note that queries can return 0 results (an empty -- list). pgSimpleQuery :: PGConnection -> String -- ^ SQL string - -> IO (Int, Seq.Seq PGData) -- ^ The number of rows affected and a list of result rows + -> 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 @@ -456,7 +453,7 @@ pgSimpleQuery h sql = do end EmptyQueryResponse = go end end m = fail $ "pgSimpleQuery: unexpected message: " ++ show m -pgPreparedBind :: PGConnection -> String -> [OID] -> PGData -> IO (IO ()) +pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> IO (IO ()) pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = do pgSync c (p, n) <- atomicModifyIORef' psr $ \(i, m) -> @@ -480,8 +477,8 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = d -- 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) - -> PGData -- ^ Paremeters to bind to placeholders - -> IO (Int, Seq.Seq PGData) + -> PGValues -- ^ Paremeters to bind to placeholders + -> IO (Int, Seq.Seq PGValues) pgPreparedQuery c sql types bind = do start <- pgPreparedBind c sql types bind pgSend c $ Execute 0 @@ -497,8 +494,8 @@ pgPreparedQuery c sql types bind = do -- |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] -> PGData -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) - -> IO [PGData] +pgPreparedLazyQuery :: PGConnection -> String -> [OID] -> PGValues -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) + -> IO [PGValues] pgPreparedLazyQuery c sql types bind count = do start <- pgPreparedBind c sql types bind unsafeInterleaveIO $ do diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 7c24d78..780c20a 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -36,7 +36,7 @@ import Database.TemplatePG.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 PGData => PGRawQuery q +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). @@ -49,25 +49,25 @@ pgQuery c q = toList . snd <$> pgRunQuery c q data SimpleQuery = SimpleQuery String -instance PGQuery SimpleQuery PGData where +instance PGQuery SimpleQuery PGValues where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql instance PGRawQuery SimpleQuery where -data PreparedQuery = PreparedQuery String [OID] PGData -instance PGQuery PreparedQuery PGData where +data PreparedQuery = PreparedQuery String [OID] PGValues +instance PGQuery PreparedQuery PGValues where pgRunQuery c (PreparedQuery sql types bind) = pgPreparedQuery c sql types bind instance PGRawQuery PreparedQuery where -data QueryParser q a = QueryParser q (PGData -> a) +data QueryParser q a = QueryParser q (PGValues -> a) instance PGRawQuery q => PGQuery (QueryParser q a) a where pgRunQuery c (QueryParser q p) = second (fmap p) <$> pgRunQuery c q instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (f . p) -rawParser :: q -> QueryParser q PGData +rawParser :: q -> QueryParser q PGValues rawParser q = QueryParser q id -- |A simple one-shot query that simply substitutes literal representations of parameters for placeholders. @@ -76,11 +76,11 @@ type PGSimpleQuery = QueryParser SimpleQuery type PGPreparedQuery = QueryParser PreparedQuery -- |Make a simple query directly from a query string, with no type inference -rawPGSimpleQuery :: String -> PGSimpleQuery PGData +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 -> PGData -> PGPreparedQuery PGData +rawPGPreparedQuery :: String -> PGValues -> PGPreparedQuery PGValues rawPGPreparedQuery sql = rawParser . PreparedQuery sql [] -- |Run a prepared query in lazy mode, where only chunk size rows are requested at a time. @@ -94,12 +94,12 @@ pgLazyQuery c (QueryParser (PreparedQuery sql types bind) p) count = -- |Given a result description, create a function to convert a result to a -- tuple. convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description - -> TH.Q TH.Exp -- ^ A function for converting a row of the given result description + -> TH.ExpQ -- ^ A function for converting a row of the given result description convertRow types = do (pats, conv) <- mapAndUnzipM (\t@(n, _, _) -> do v <- TH.newName n - return (TH.varP v, convertColumn (TH.varE v) t)) types - TH.lamE [TH.listP pats] $ TH.tupE conv + return (TH.VarP v, convertColumn (TH.VarE v) t)) types + return $ TH.LamE [TH.ListP pats] $ TH.TupE conv -- |Given a raw PostgreSQL result and a result field type, convert the -- field to a Haskell value. @@ -108,11 +108,12 @@ convertRow types = do -- and we can use 'fromJust' to keep the code simple. If it's 'True', then we -- don't know if the value is nullable and must return a 'Maybe' value in case -- it is. -convertColumn :: TH.ExpQ -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') +convertColumn :: TH.Exp -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') -> (String, PGTypeHandler, Bool) -- ^ the result field type - -> TH.ExpQ -convertColumn v (n, t, False) = [| $(pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] -convertColumn v (_, t, True) = [| fmap $(pgTypeDecoder t) $(v) |] + -> TH.Exp +-- convertColumn v (n, t, False) = [| $(return $ pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] +-- convertColumn v (_, t, True) = [| fmap $(return $ pgTypeDecoder t) $(v) |] +convertColumn v (_, t, nullable) = (if nullable then pgTypeDecoder else pgTypeDecoderNotNull) (pgTypeName' t) `TH.AppE` v -- |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 @$${@. @@ -164,8 +165,8 @@ trim :: String -> String trim = dropWhileEnd isSpace . dropWhile isSpace 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) + { 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). } simpleFlags :: QueryFlags @@ -180,7 +181,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do (vars, vals) <- mapAndUnzipM (\t -> do v <- TH.newName "p" - (,) (TH.VarP v) . (`TH.AppE` TH.VarE v) <$> encf t) pt + return (TH.VarP v, encf (pgTypeName' t) `TH.AppE` TH.VarE v)) pt conv <- convertRow rt let pgq | isNothing prep = TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals @@ -191,7 +192,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e encf | isNothing prep = pgTypeEscaper - | otherwise = pgTypeEncoder + | otherwise = pgTypeEncoder qqQuery :: QueryFlags -> String -> TH.ExpQ qqQuery f@QueryFlags{ flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q diff --git a/Database/TemplatePG/TH.hs b/Database/TemplatePG/TH.hs index d084e6c..5f444b2 100644 --- a/Database/TemplatePG/TH.hs +++ b/Database/TemplatePG/TH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables, FlexibleContexts #-} -- | -- Module: Database.TemplatePG.TH -- Copyright: 2015 Dylan Simon @@ -15,6 +15,10 @@ module Database.TemplatePG.TH , getTPGTypeOID , getTPGType , tpgDescribe + , pgTypeDecoder + , pgTypeDecoderNotNull + , pgTypeEncoder + , pgTypeEscaper ) where import Control.Applicative ((<$>), (<$), (<|>)) @@ -97,20 +101,21 @@ getTPGTypeOID TPGState{ tpgConnection = c, tpgTypes = types } t | Just oid <- readMaybe t = return (oid, 0) | Just oid <- findType t = return (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of | otherwise = do - (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgLiteral t ++ " OR format_type(oid, -1) = " ++ pgLiteral t) + (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgQuote t ++ " OR format_type(oid, -1) = " ++ pgQuote t) case toList r of [] -> fail $ "Unknown PostgreSQL type: " ++ t - [[Just o, Just lo]] -> return (pgDecodeBS o, pgDecodeBS lo) + [[Just o, Just lo]] -> return (decodeOID o, decodeOID lo) _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r where - findType n = fmap fst $ find ((==) n . pgTypeName . snd) $ Map.toList types + findType n = fmap fst $ find ((==) n . pgTypeName' . snd) $ Map.toList types + decodeOID = pgDecode pgOIDType -- |Lookup the type handler for a given type OID. getTPGType :: TPGState -> OID -> IO PGTypeHandler getTPGType TPGState{ tpgConnection = c, tpgTypes = types } oid = maybe notype return $ Map.lookup oid types where notype = do - (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral oid) + (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral pgOIDType oid) case toList r of [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ show s _ -> fail $ "Unknown PostgreSQL type: " ++ show oid @@ -122,7 +127,7 @@ registerTPGType name typ = TH.runIO $ do (oid, loid) <- withTPGState (\c -> getTPGTypeOID c name) modifyTPGState ( (if loid == 0 then id else tpgAddType (pgArrayType loid name typ)) - . tpgAddType (PGType oid name typ)) + . tpgAddType (PGTypeHandler oid name typ)) return [] -- |A type-aware wrapper to 'pgDescribe' @@ -135,3 +140,26 @@ tpgDescribe tpg sql types nulls = do th <- getTPGType tpg t return (c, th, n)) rt return (pth, rth) + + +typeApply :: TH.Name -> String -> TH.Exp +typeApply f s = TH.AppE (TH.VarE f) $ + TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit s)) + + +-- |TH expression to decode a 'Maybe' 'L.ByteString' to a 'Maybe' 'PGColumn' value. +pgTypeDecoder :: String -> TH.Exp +pgTypeDecoder = typeApply 'pgDecodeColumn + +-- |TH expression to decode a 'Maybe' 'L.ByteString' to a 'PGColumn' value. +pgTypeDecoderNotNull :: String -> TH.Exp +pgTypeDecoderNotNull = typeApply 'pgDecodeColumnNotNull + +-- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. +pgTypeEncoder :: String -> TH.Exp +pgTypeEncoder = typeApply 'pgEncodeParameter + +-- |TH expression to escape a 'PGParameter' value to a SQL literal. +pgTypeEscaper :: String -> TH.Exp +pgTypeEscaper = typeApply 'pgEscapeParameter + diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 9f1c2ed..081c9d9 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -1,16 +1,34 @@ -{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} --- Copyright 2010, 2011, 2013 Chris Forno --- Copyright 2014 Dylan Simon +{-# LANGUAGE FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} +-- | +-- Module: Database.TemplatePG.Type +-- Copyright: 2010, 2011, 2013 Chris Forno +-- Copyright: 2015 Dylan Simon +-- +-- Classes to support type inference, value encoding/decoding, and instances to support built-in PostgreSQL types. module Database.TemplatePG.Types - ( pgQuote - , PGType(..) + ( + -- * Classes and internal TH functions + PGValue + , PGValues + , PGTypeName(..) + , PGParameter(..) + , PGColumn(..) + , PGStringType + , PGArrayType + , PGRangeType + , pgEncodeParameter + , pgEscapeParameter + , pgDecodeColumn + , pgDecodeColumnNotNull + + , pgBoolType + , pgOIDType + + -- * Conversion utilities + , pgQuote , OID - , PossiblyMaybe(..) , PGTypeHandler(..) - , pgTypeDecoder - , pgTypeEncoder - , pgTypeEscaper , PGTypeMap , defaultPGTypeMap , pgArrayType @@ -27,10 +45,10 @@ import Data.Char (isDigit, digitToInt, intToDigit, toLower) import Data.Int import Data.List (intercalate) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) +import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) import qualified Language.Haskell.TH as TH import Numeric (readFloat) import System.Locale (defaultTimeLocale) @@ -39,6 +57,65 @@ import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) import qualified Database.TemplatePG.Range as Range +type PGValue = L.ByteString +-- |A list of (nullable) data values, e.g. a single row or query parameters. +type PGValues = [Maybe 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 + +pgTypeName :: KnownSymbol t => PGTypeName (t :: Symbol) -> String +pgTypeName = symbolVal + +-- |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 -> PGValue + -- |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 . U.toString . pgEncode t + +-- |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 -> PGValue -> a + +-- |Support encoding of 'Maybe' values into NULL. +class PGParameterNull t a where + pgEncodeNull :: PGTypeName t -> a -> Maybe PGValue + pgLiteralNull :: PGTypeName t -> a -> String + +-- |Support decoding of assumed non-null columns but also still allow decoding into 'Maybe'. +class PGColumnNotNull t a where + pgDecodeNotNull :: PGTypeName t -> Maybe PGValue -> a + + +instance PGParameter t a => PGParameterNull t a where + pgEncodeNull t = Just . pgEncode t + pgLiteralNull = pgLiteral +instance PGParameter t a => PGParameterNull t (Maybe a) where + pgEncodeNull = fmap . pgEncode + pgLiteralNull = maybe "NULL" . pgLiteral + +instance PGColumn t a => PGColumnNotNull t a where + pgDecodeNotNull t = maybe (error $ "Unexpected NULL in " ++ pgTypeName t ++ " column") (pgDecode t) +instance PGColumn t a => PGColumnNotNull t (Maybe a) where + pgDecodeNotNull = fmap . pgDecode + +pgEncodeParameter :: PGParameterNull t a => PGTypeName t -> a -> Maybe PGValue +pgEncodeParameter = pgEncodeNull + +pgEscapeParameter :: PGParameterNull t a => PGTypeName t -> a -> String +pgEscapeParameter = pgLiteralNull + +pgDecodeColumn :: PGColumn t a => PGTypeName t -> Maybe PGValue -> Maybe a +pgDecodeColumn = fmap . pgDecode + +pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeName t -> Maybe PGValue -> a +pgDecodeColumnNotNull = pgDecodeNotNull + + pgQuoteUnsafe :: String -> String pgQuoteUnsafe s = '\'' : s ++ "'" @@ -65,103 +142,73 @@ parseDQuote unsafe = (q P.<|> uq) where P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" uq = P.many1 (P.noneOf unsafe) --- |Any type which can be marshalled to and from PostgreSQL. --- Minimal definition: 'pgDecodeBS' (or 'pgDecode') and 'pgEncode' (or 'pgEncodeBS') --- The default implementations do UTF-8 conversion. -class PGType a where - -- |Decode a postgres raw text representation into a value. - pgDecodeBS :: L.ByteString -> a - pgDecodeBS = pgDecode . U.toString - -- |Decode a postgres unicode string representation into a value. - pgDecode :: String -> a - pgDecode = pgDecodeBS . U.fromString - -- |Encode a value to a postgres raw text representation. - pgEncodeBS :: a -> L.ByteString - pgEncodeBS = U.fromString . pgEncode - -- |Encode a value to a postgres unicode representation. - pgEncode :: a -> String - pgEncode = U.toString . pgEncodeBS - -- |Encode a value to a quoted literal value for use in statements. - pgLiteral :: a -> String - pgLiteral = pgQuote . pgEncode - -instance PGType Bool where - pgDecode "f" = False - pgDecode "t" = True - pgDecode s = error $ "pgDecode bool: " ++ s - pgEncode False = "f" - pgEncode True = "t" - pgLiteral False = "false" - pgLiteral True = "true" + +class (Show a, Read a, KnownSymbol t) => PGLiteralType t a + +instance PGLiteralType t a => PGParameter t a where + pgEncode _ = LC.pack . show + pgLiteral _ = show +instance PGLiteralType t a => PGColumn t a where + pgDecode _ = read . LC.unpack + +instance PGParameter "bool" Bool where + pgEncode _ False = LC.singleton 'f' + pgEncode _ True = LC.singleton 't' + pgLiteral _ False = "false" + pgLiteral _ True = "true" +instance PGColumn "bool" Bool where + pgDecode _ s = case LC.head s of + 'f' -> False + 't' -> True + c -> error $ "pgDecode bool: " ++ [c] +pgBoolType :: PGTypeName "bool" +pgBoolType = PGTypeProxy type OID = Word32 -instance PGType OID where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType Int where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType Int16 where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType Int32 where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType Int64 where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType Char where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode [c] = c - pgDecode s = error $ "pgDecode char: " ++ s - pgEncode c - | fromEnum c < 256 = [c] - | otherwise = error "pgEncode: Char out of range" - -instance PGType Float where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType Double where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = read - pgEncode = show - pgLiteral = show - -instance PGType String where - pgDecode = id - pgEncode = id +instance PGLiteralType "oid" OID +pgOIDType :: PGTypeName "oid" +pgOIDType = PGTypeProxy + +instance PGLiteralType "int2" Int16 +instance PGLiteralType "int4" Int32 +instance PGLiteralType "int8" Int64 +instance PGLiteralType "float4" Float +instance PGLiteralType "float8" Double + + +instance PGParameter "char" Char where + pgEncode _ = LC.singleton +instance PGColumn "char" Char where + pgDecode _ = LC.head + + +class KnownSymbol t => PGStringType t + +instance PGStringType t => PGParameter t String where + pgEncode _ = U.fromString +instance PGStringType t => PGColumn t String where + pgDecode _ = U.toString + +instance PGStringType t => PGParameter t L.ByteString where + pgEncode _ = id +instance PGStringType t => PGColumn t L.ByteString where + pgDecode _ = id + +instance PGStringType "text" +instance PGStringType "varchar" +instance PGStringType "name" -- limit 63 characters +instance PGStringType "bpchar" -- blank padded + type Bytea = L.ByteString -instance PGType Bytea where - pgDecode = pgDecodeBS . LC.pack - pgEncodeBS = LC.pack . pgEncode - pgDecodeBS s +instance PGParameter "bytea" Bytea where + pgEncode _ = LC.pack . (++) "'\\x" . ed . L.unpack where + ed [] = "\'" + ed (x:d) = hex (shiftR x 4) : hex (x .&. 0xF) : ed d + hex = intToDigit . fromIntegral + pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGColumn "bytea" Bytea where + pgDecode _ s | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm | otherwise = L.pack $ pd $ L.unpack d where (m, d) = L.splitAt 2 s @@ -170,39 +217,24 @@ instance PGType Bytea where pd (h:l:r) = (shiftL (unhex h) 4 .|. unhex l) : pd r pd [x] = error $ "pgDecode bytea: " ++ show x unhex = fromIntegral . digitToInt . w2c - pgEncode = (++) "'\\x" . ed . L.unpack where - ed [] = "\'" - ed (x:d) = hex (shiftR x 4) : hex (x .&. 0xF) : ed d - hex = intToDigit . fromIntegral - pgLiteral = pgQuoteUnsafe . pgEncode - -instance PGType Time.Day where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.readTime defaultTimeLocale "%F" - pgEncode = Time.showGregorian - pgLiteral = pgQuoteUnsafe . pgEncode - -instance PGType Time.TimeOfDay where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.readTime defaultTimeLocale "%T%Q" - pgEncode = Time.formatTime defaultTimeLocale "%T%Q" - pgLiteral = pgQuoteUnsafe . pgEncode - -instance PGType Time.LocalTime where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.readTime defaultTimeLocale "%F %T%Q" - pgEncode = Time.formatTime defaultTimeLocale "%F %T%Q" - pgLiteral = pgQuoteUnsafe . pgEncode - -instance PGType Time.UTCTime where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ - pgEncode = fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" - pgLiteral = pgQuoteUnsafe . pgEncode + +instance PGParameter "date" Time.Day where + pgEncode _ = LC.pack . Time.showGregorian + pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGColumn "date" Time.Day where + pgDecode _ = Time.readTime defaultTimeLocale "%F" . LC.unpack + +instance PGParameter "time" Time.TimeOfDay where + pgEncode _ = LC.pack . Time.formatTime defaultTimeLocale "%T%Q" + pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGColumn "time" Time.TimeOfDay where + pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . LC.unpack + +instance PGParameter "timestamp" Time.LocalTime where + pgEncode _ = LC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" + pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGColumn "timestamp" Time.LocalTime where + pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . LC.unpack -- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. -- readTime can successfully parse both formats, but PostgreSQL needs the colon. @@ -214,13 +246,20 @@ fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit 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 "timestamptz" Time.UTCTime where + pgEncode _ = LC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" + -- pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGColumn "timestamptz" Time.UTCTime where + pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . LC.unpack + +instance PGParameter "interval" Time.DiffTime where + pgEncode _ = LC.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 PGType Time.DiffTime where - pgDecode = pgDecodeBS . LC.pack - pgEncodeBS = LC.pack . pgEncode - pgDecodeBS = either (error . ("pgDecode interval: " ++) . show) id . P.parse ps "interval" where +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)] @@ -250,26 +289,25 @@ instance PGType Time.DiffTime where , reservedNames = [] , caseSensitive = True } - pgEncode = show - pgLiteral = pgQuoteUnsafe . pgEncode -- could be more efficient +instance PGParameter "numeric" Rational where + pgEncode _ r + | denominator r == 0 = LC.pack "NaN" -- this can't happen + | otherwise = LC.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 thus produce exceptions. -instance PGType Rational where - pgDecodeBS = pgDecode . LC.unpack - pgEncodeBS = LC.pack . pgEncode - pgDecode "NaN" = 0 % 0 -- this won't work - pgDecode s = ur $ readFloat s where +-- 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 - pgEncode r - | denominator r == 0 = "NaN" -- this can't happen - | otherwise = 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)" + s = LC.unpack bs -- This will produce infinite(-precision) strings showRational :: Rational -> String @@ -278,27 +316,128 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where frac 0 = "" frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) --- |Arrays of any type, which may always contain NULLs. --- This will work for any type using comma as a delimiter (i.e., anything but @box@). -instance PGType a => PGType [Maybe a] where - pgDecodeBS = either (error . ("pgDecode array: " ++) . show) id . P.parse pa "array" where +-- |The cannonical representation of a PostgreSQL array of any type, which may always contain NULLs. +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@). +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 + -- TODO: rewrite to use BS + pgEncode ta l = U.fromString $ '{' : intercalate [pgArrayDelim ta] (map el l) ++ "}" where + el Nothing = "null" + el (Just e) = dQuote (pgArrayDelim ta : "\"\\{}") $ U.toString $ 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 ',') + P.sepBy nel (P.char (pgArrayDelim ta)) _ <- P.eof return l nel = Nothing <$ nul P.<|> Just <$> el nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll" - el = pgDecodeBS . LC.pack <$> parseDQuote "\",{}" - pgEncode l = '{' : intercalate "," (map el l) ++ "}" where - el Nothing = "null" - el (Just e) = dQuote "\",\\{}" $ pgEncode e - -instance PGType a => PGType (Range.Range a) where - pgDecodeBS = either (error . ("pgDecode range: " ++) . show) id . P.parse per "array" where + el = pgDecode (pgArrayElementType ta) . LC.pack <$> parseDQuote (pgArrayDelim ta : "\"{}") + +-- Just a dump of pg_type: +instance PGArrayType "_bool" "bool" +instance PGArrayType "_bytea" "bytea" +instance PGArrayType "_char" "char" +instance PGArrayType "_name" "name" +instance PGArrayType "_int8" "int8" +instance PGArrayType "_int2" "int2" +instance PGArrayType "_int2vector" "int2vector" +instance PGArrayType "_int4" "int4" +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 "_float4" "float4" +instance PGArrayType "_float8" "float8" +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 "_varchar" "varchar" +instance PGArrayType "_date" "date" +instance PGArrayType "_time" "time" +instance PGArrayType "_timestamp" "timestamp" +instance PGArrayType "_timestamptz" "timestamptz" +instance PGArrayType "_interval" "interval" +instance PGArrayType "_timetz" "timetz" +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 = LC.pack "empty" + -- TODO: rewrite to use BS + pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = U.fromString $ + pc '[' '(' l + : pb (Range.bound l) + ++ ',' + : pb (Range.bound u) + ++ [pc ']' ')' u] + where + pb Nothing = "" + pb (Just b) = dQuote "\"(),[\\]" $ U.toString $ pgEncode (pgRangeElementType tr) b + pc c o b = 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 "array" where per = Range.Empty <$ pe P.<|> pr pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy" - pp = pgDecodeBS . LC.pack <$> parseDQuote "\"(),[\\]" + pp = pgDecode (pgRangeElementType tr) . LC.pack <$> parseDQuote "\"(),[\\]" pc c o = True <$ P.char c P.<|> False <$ P.char o pb = P.optionMaybe pp mb = maybe Range.Unbounded . Range.Bounded @@ -309,75 +448,42 @@ instance PGType a => PGType (Range.Range a) where ub <- pb uc <- pc ']' ')' return $ Range.Range (Range.Lower (mb lc lb)) (Range.Upper (mb uc ub)) - pgEncode Range.Empty = "empty" - pgEncode (Range.Range (Range.Lower l) (Range.Upper u)) = - pc '[' '(' l - : pb (Range.bound l) - ++ ',' - : pb (Range.bound u) - ++ [pc ']' ')' u] - where - pb Nothing = "" - pb (Just b) = dQuote "\"(),[\\]" $ pgEncode b - pc c o b = if Range.boundClosed b then c else o -{- --- Since PG values cannot contain '\0', we use it as a special flag for NULL values (which will later be encoded with length -1) -pgNull :: String -pgNull = "\0" -pgNullBS :: L.ByteString -pgNullBS = L.singleton 0 - --- This is a nice idea, but isn't actually useful because these types will never be resolved -instance PGType a => PGType (Maybe a) where - pgDecodeBS s = pgDecodeBS s <$ guard (s /= pgNullBS) - pgDecode s = pgDecode s <$ guard (s /= pgNull) - pgEncodeBS = maybe pgNullBS pgEncodeBS - pgEncode = maybe pgNull pgEncode - pgLiteral = maybe "NULL" pgLiteral --} +instance PGRangeType "int4range" "int4" +instance PGRangeType "numrange" "numeric" +instance PGRangeType "tsrange" "timestamp" +instance PGRangeType "tstzrange" "timestamptz" +instance PGRangeType "daterange" "date" +instance PGRangeType "int8range" "int8" --- |A special class inhabited only by @a@ and @Maybe a@. --- This is used to provide added flexibility in parameter types. -class PGType a => PossiblyMaybe m a {- ideally should have fundep: | m -> a -} where - possiblyMaybe :: m -> Maybe a - maybePossibly :: Maybe a -> m -instance PGType a => PossiblyMaybe a a where - possiblyMaybe = Just - maybePossibly = fromMaybe (error "Unexpected NULL value") -instance PGType a => PossiblyMaybe (Maybe a) a where - possiblyMaybe = id - maybePossibly = id +{- +--, ( 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", ?) +--, (2950, 2951, "uuid", ?) +-} -data PGTypeHandler = PGType +data PGTypeHandler = PGTypeHandler { pgTypeOID :: OID - , pgTypeName :: String -- ^ The internal PostgreSQL name of the type - , pgTypeType :: TH.Type -- ^ The equivalent Haskell type to which it is marshalled (must be an instance of 'PGType' + , pgTypeName' :: String -- ^ The internal PostgreSQL name of the type + , pgTypeType :: TH.Type -- ^ The equivalent Haskell type to which it is marshalled (must be an instance of 'PGType') } deriving (Show) --- |TH expression to decode a 'L.ByteString' to a value. -pgTypeDecoder :: PGTypeHandler -> TH.ExpQ -pgTypeDecoder PGType{ pgTypeType = t } = - [| pgDecodeBS :: L.ByteString -> $(return t) |] - --- |TH expression to encode a ('PossiblyMayble') value to an 'Maybe' 'L.ByteString'. -pgTypeEncoder :: PGTypeHandler -> TH.ExpQ -pgTypeEncoder PGType{ pgTypeType = t } = - [| fmap (pgEncodeBS :: $(return t) -> L.ByteString) . possiblyMaybe |] - --- |TH expression to escape a ('PossiblyMaybe') value to a SQL literal. -pgTypeEscaper :: PGTypeHandler -> TH.ExpQ -pgTypeEscaper PGType{ pgTypeType = t } = - [| maybe "NULL" (pgLiteral :: $(return t) -> String) . possiblyMaybe |] - type PGTypeMap = Map.Map OID PGTypeHandler arrayType :: TH.Type -> TH.Type arrayType = TH.AppT TH.ListT . TH.AppT (TH.ConT ''Maybe) pgArrayType :: OID -> String -> TH.Type -> PGTypeHandler -pgArrayType o n t = PGType o ('_':n) (arrayType t) +pgArrayType o n t = PGTypeHandler o ('_':n) (arrayType t) pgTypes :: [(OID, OID, String, TH.Name)] pgTypes = @@ -429,8 +535,8 @@ rangeTypes = defaultPGTypeMap :: PGTypeMap defaultPGTypeMap = Map.fromAscList - ([(o, PGType o n (TH.ConT t)) | (o, _, n, t) <- pgTypes] - ++ [(o, PGType o n (rangeType (TH.ConT t))) | (o, _, n, t) <- rangeTypes]) + ([(o, PGTypeHandler o n (TH.ConT t)) | (o, _, n, t) <- pgTypes] + ++ [(o, PGTypeHandler o n (rangeType (TH.ConT t))) | (o, _, n, t) <- rangeTypes]) `Map.union` Map.fromList ([(o, pgArrayType o n (TH.ConT t)) | (_, o, n, t) <- pgTypes] ++ [(o, pgArrayType o n (rangeType (TH.ConT t))) | (_, o, n, t) <- rangeTypes]) diff --git a/test/Main.hs b/test/Main.hs index 73d1223..d02b1db 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -36,11 +36,12 @@ main = do 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 - Just (Just i', Just b', Just f', Just d', Just t', Just z', Just p', Just l', Just r') <- - $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[], {r}::int4range") c - assert $ i == i' && b == b' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' + Just (Just i', Just b', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r') <- + $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {s}::text, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[], {r}::int4range") c + assert $ i == i' && b == b' && s == s' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' ["box"] <- simple c 603 [Just "box"] <- simpleApply c 603 From 773a7bc193ef61b9e7875ed3a559df39f994cf94 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 17:41:34 -0500 Subject: [PATCH 072/306] Eliminate type map and thus TPGState --- Database/TemplatePG.hs | 63 +++++++------------ Database/TemplatePG/Enum.hs | 14 ++--- Database/TemplatePG/Query.hs | 20 +++--- Database/TemplatePG/TH.hs | 116 +++++++++++------------------------ Database/TemplatePG/Types.hs | 98 +++++------------------------ test/Main.hs | 2 +- 6 files changed, 87 insertions(+), 226 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 13387d9..3eaac78 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -41,8 +41,6 @@ module Database.TemplatePG -- **Types -- $types - , registerTPGType - -- **A Note About NULL -- $nulls @@ -89,12 +87,10 @@ import Database.TemplatePG.SQL -- 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 --- @ +-- > 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. @@ -114,10 +110,8 @@ import Database.TemplatePG.SQL -- -- If you'd like to specify what connection to use directly, use 'useTHConnection' at the top level: -- --- @ --- myConnect = pgConnect ... --- useTHConnection myConnect --- @ +-- > 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. -- @@ -129,13 +123,13 @@ import Database.TemplatePG.SQL -- $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)]@ +-- > 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]@ +-- > [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'. @@ -160,50 +154,39 @@ import Database.TemplatePG.SQL -- 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 --- @ +-- > 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 --- @ +-- > let owner = 33 :: Int32 +-- > tuples <- $(queryTuples "SELECT * FROM pg_database WHERE datdba = {owner} LIMIT {2 * 3 :: Int64}") h -- $types --- All supported types have instances of the 'PGType' class. +-- Most builtin types are already supported. -- For the most part, only exactly equivalent types are used (e.g., 'Int32' for int4). --- (You can also use @[pgSQL|int4|]@ to substitute the equivalent Haskell type.) --- However, you can add support for your own types or replace the existing types just by making a new instance of 'PGType' and calling 'registerPGType' at the top level: -- --- @ --- instance PGType MyType where ... --- registerPGType \"mytype\" (Language.Haskell.TH.ConT ''MyType) --- @ +-- 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" -- --- This will cause the PostgreSQL type @mytype@ to be converted to/from @MyType@. --- Only one 'PGType' may be registered per PostgreSQL type, but the same 'PGType' may serve multiple PostgreSQL types. --- This also automatically registers a handler for @_mytype@ (the PostgreSQL name for a vector or array of @mytype@) to @[Maybe MyType]@. --- Like 'useTHConnection', this must be evaluated before any use of the type. +-- You must enable the DataKinds language extension. -- $nulls -- Sometimes TemplatePG cannot determine whether or not a result field can -- potentially be @NULL@. In those cases it will assume that it can. Basically, -- any time a result field is not immediately 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. +-- 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'. -- --- Nullability is indicated incorrectly in the case of outer joins. TemplatePG --- incorrectly infers that a field cannot be @NULL@ when it's able to trace the --- result field back to a non-@NULL@ table column. You can disable nullability inference by prepending your query with '?' to assume all columns are nullable. --- -- Because TemplatePG has to prepare statements at compile time and -- placeholders can't be used in place of lists in PostgreSQL (such as @IN -- (?)@), you must replace such cases with equivalent arrays (@= ANY (?)@). diff --git a/Database/TemplatePG/Enum.hs b/Database/TemplatePG/Enum.hs index 8900dc4..3d4b9ca 100644 --- a/Database/TemplatePG/Enum.hs +++ b/Database/TemplatePG/Enum.hs @@ -8,7 +8,6 @@ module Database.TemplatePG.Enum ( makePGEnum ) where -import Control.Applicative ((<$>)) import Control.Monad (when) import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (toList) @@ -38,14 +37,13 @@ makePGEnum name typs valf = do when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let valn = map (\[Just v] -> let s = U.toString v in (TH.StringL s, TH.mkName $ valf s)) $ toList vals - (++) + return [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded] - -- FIXME - , TH.InstanceD [] (TH.AppT (TH.ConT ''PGParameter) typt) - [ TH.FunD 'pgDecode $ map (\(l, n) -> TH.Clause [TH.LitP l] (TH.NormalB (TH.ConE n)) []) valn - , TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.ConP n []] (TH.NormalB (TH.LitE l)) []) valn - ] - ] <$> registerTPGType name typt + , 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.LitE l)) []) valn ] + , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` TH.LitT (TH.StrTyLit name) `TH.AppT` typt) + [ TH.FunD 'pgDecode $ map (\(l, n) -> TH.Clause [TH.WildP, TH.LitP l] (TH.NormalB (TH.ConE n)) []) valn ] + ] where typn = TH.mkName typs typt = TH.ConT typn diff --git a/Database/TemplatePG/Query.hs b/Database/TemplatePG/Query.hs index 780c20a..58bb5bd 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/TemplatePG/Query.hs @@ -93,7 +93,7 @@ pgLazyQuery c (QueryParser (PreparedQuery sql types bind) p) count = -- |Given a result description, create a function to convert a result to a -- tuple. -convertRow :: [(String, PGTypeHandler, Bool)] -- ^ result description +convertRow :: [(String, PGTypeInfo, Bool)] -- ^ result description -> TH.ExpQ -- ^ A function for converting a row of the given result description convertRow types = do (pats, conv) <- mapAndUnzipM (\t@(n, _, _) -> do @@ -109,11 +109,11 @@ convertRow types = do -- don't know if the value is nullable and must return a 'Maybe' value in case -- it is. convertColumn :: TH.Exp -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') - -> (String, PGTypeHandler, Bool) -- ^ the result field type + -> (String, PGTypeInfo, Bool) -- ^ the result field type -> TH.Exp -- convertColumn v (n, t, False) = [| $(return $ pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] -- convertColumn v (_, t, True) = [| fmap $(return $ pgTypeDecoder t) $(v) |] -convertColumn v (_, t, nullable) = (if nullable then pgTypeDecoder else pgTypeDecoderNotNull) (pgTypeName' t) `TH.AppE` v +convertColumn v (_, t, nullable) = (if nullable then pgTypeDecoder else pgTypeDecoderNotNull) t `TH.AppE` v -- |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 @$${@. @@ -175,13 +175,13 @@ 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) <- TH.runIO $ withTPGState $ \c -> + (pt, rt) <- TH.runIO $ withTPGConnection $ \c -> tpgDescribe c 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 '$${'" (vars, vals) <- mapAndUnzipM (\t -> do v <- TH.newName "p" - return (TH.VarP v, encf (pgTypeName' t) `TH.AppE` TH.VarE v)) pt + return (TH.VarP v, encf t `TH.AppE` TH.VarE v)) pt conv <- convertRow rt let pgq | isNothing prep = TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals @@ -204,10 +204,6 @@ qqQuery f@QueryFlags{ flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = sql _ = fail "pgSQL: unterminated argument list" qqQuery f q = makePGQuery f q -qqType :: String -> TH.TypeQ -qqType t = fmap pgTypeType $ TH.runIO $ withTPGState $ \c -> - getTPGType c . fst =<< getTPGTypeOID c t - -- |A quasi-quoter for PGSQL queries. -- -- Used in expression context, it may contain any SQL statement @[pgSQL|SELECT ...|]@. @@ -219,15 +215,13 @@ qqType t = fmap pgTypeType $ TH.runIO $ withTPGState $ \c -> -- -- The statement may start with one of more special flags affecting the interpretation: -- --- [@?@] To treat all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. +-- [@?@] 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). --- --- In type context, [pgSQL|typname|] will be replaced with the Haskell type that corresponds to PostgreSQL type @typname@. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter { quoteExp = qqQuery simpleFlags - , quoteType = qqType + , quoteType = const $ fail "pgSQL not supported in types" , quotePat = const $ fail "pgSQL not supported in patterns" , quoteDec = const $ fail "pgSQL not supported at top level" } diff --git a/Database/TemplatePG/TH.hs b/Database/TemplatePG/TH.hs index 5f444b2..ffec06f 100644 --- a/Database/TemplatePG/TH.hs +++ b/Database/TemplatePG/TH.hs @@ -8,12 +8,10 @@ module Database.TemplatePG.TH ( getTPGDatabase - , withTPGState , withTPGConnection , useTPGDatabase - , registerTPGType - , getTPGTypeOID - , getTPGType + , PGTypeInfo(..) + , getPGTypeInfo , tpgDescribe , pgTypeDecoder , pgTypeDecoderNotNull @@ -22,26 +20,18 @@ module Database.TemplatePG.TH ) where import Control.Applicative ((<$>), (<$), (<|>)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, swapMVar) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, swapMVar) import Control.Monad ((>=>), void, liftM2) import Data.Foldable (toList) -import Data.List (find) -import qualified Data.Map as Map import Data.Maybe (isJust, fromMaybe) import qualified Language.Haskell.TH as TH import Network (PortID(UnixSocket, PortNumber), PortNumber) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) -import Text.Read (readMaybe) import Database.TemplatePG.Types import Database.TemplatePG.Protocol -data TPGState = TPGState - { tpgConnection :: PGConnection - , tpgTypes :: PGTypeMap - } - -- |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 @@ -62,104 +52,70 @@ getTPGDatabase = do , pgDBDebug = debug } -tpgConnect :: PGDatabase -> IO TPGState -tpgConnect db = do - c <- pgConnect db - return $ TPGState c defaultPGTypeMap - -tpgState :: MVar (Either (IO TPGState) TPGState) -tpgState = unsafePerformIO $ newMVar $ Left $ tpgConnect =<< getTPGDatabase - -withTPGState :: (TPGState -> IO a) -> IO a -withTPGState f = modifyMVar tpgState $ either id return >=> (\c -> (,) (Right c) <$> f c) +tpgConnection :: MVar (Either (IO PGConnection) PGConnection) +tpgConnection = unsafePerformIO $ newMVar $ Left $ pgConnect =<< getTPGDatabase -- |Run an action using the TemplatePG connection. withTPGConnection :: (PGConnection -> IO a) -> IO a -withTPGConnection f = withTPGState (f . tpgConnection) +withTPGConnection f = modifyMVar tpgConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) -setTPGState :: Either (IO TPGState) TPGState -> IO () -setTPGState = void . swapMVar tpgState +setTPGConnection :: Either (IO PGConnection) PGConnection -> IO () +setTPGConnection = void . swapMVar tpgConnection -- |Specify an alternative database to use during TemplatePG 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 will also clear all types registered with 'registerTPGType'. useTPGDatabase :: PGDatabase -> TH.Q [TH.Dec] -useTPGDatabase db = [] <$ TH.runIO (setTPGState $ Left $ tpgConnect db) +useTPGDatabase db = [] <$ TH.runIO (setTPGConnection $ Left $ pgConnect db) -modifyTPGState :: (TPGState -> TPGState) -> IO () -modifyTPGState f = modifyMVar_ tpgState $ return . either (Left . fmap f) (Right . f) - --- |Add a new type handler for the given type OID. -tpgAddType :: PGTypeHandler -> TPGState -> TPGState -tpgAddType h tpg = tpg{ tpgTypes = Map.insert (pgTypeOID h) h $ tpgTypes tpg } +data PGTypeInfo = PGTypeInfo + { pgTypeOID :: OID + , pgTypeName :: String + } --- |Lookup the OID of a database type by internal or formatted name (case sensitive). +-- |Lookup a type by OID, internal or formatted name (case sensitive). -- Fail if not found. -getTPGTypeOID :: TPGState -> String -> IO (OID, OID) -getTPGTypeOID TPGState{ tpgConnection = c, tpgTypes = types } t - | Just oid <- readMaybe t = return (oid, 0) - | Just oid <- findType t = return (oid, fromMaybe 0 $ findType ('_':t)) -- optimization, sort of - | otherwise = do - (_, r) <- pgSimpleQuery c ("SELECT oid, typarray FROM pg_catalog.pg_type WHERE typname = " ++ pgQuote t ++ " OR format_type(oid, -1) = " ++ pgQuote t) - case toList r of - [] -> fail $ "Unknown PostgreSQL type: " ++ t - [[Just o, Just lo]] -> return (decodeOID o, decodeOID lo) - _ -> fail $ "Unexpected PostgreSQL type result for " ++ t ++ ": " ++ show r - where - findType n = fmap fst $ find ((==) n . pgTypeName' . snd) $ Map.toList types - decodeOID = pgDecode pgOIDType - --- |Lookup the type handler for a given type OID. -getTPGType :: TPGState -> OID -> IO PGTypeHandler -getTPGType TPGState{ tpgConnection = c, tpgTypes = types } oid = - maybe notype return $ Map.lookup oid types where - notype = do - (_, r) <- pgSimpleQuery c ("SELECT typname FROM pg_catalog.pg_type WHERE oid = " ++ pgLiteral pgOIDType oid) - case toList r of - [[Just s]] -> fail $ "Unsupported PostgreSQL type " ++ show oid ++ ": " ++ show s - _ -> fail $ "Unknown PostgreSQL type: " ++ show oid - --- |Register a new handler for PostgreSQL type and a Haskell type, which should be an instance of 'PGType'. --- This should be called as a top-level declaration and produces no code. -registerTPGType :: String -> TH.Type -> TH.Q [TH.Dec] -registerTPGType name typ = TH.runIO $ do - (oid, loid) <- withTPGState (\c -> getTPGTypeOID c name) - modifyTPGState ( - (if loid == 0 then id else tpgAddType (pgArrayType loid name typ)) - . tpgAddType (PGTypeHandler oid name typ)) - return [] +getPGTypeInfo :: PGConnection -> Either OID String -> IO PGTypeInfo +getPGTypeInfo c t = do + (_, r) <- pgSimpleQuery c $ "SELECT oid, typname FROM pg_catalog.pg_type WHERE " ++ either + (\o -> "oid = " ++ pgLiteral pgOIDType o) + (\n -> "typname = " ++ pgQuote n ++ " OR format_type(oid, -1) = " ++ pgQuote n) + t + case toList r of + [[Just o, Just n]] -> return $ PGTypeInfo (pgDecode pgOIDType o) (pgDecode pgNameType n) + _ -> fail $ "Unknown PostgreSQL type: " ++ either show id t -- |A type-aware wrapper to 'pgDescribe' -tpgDescribe :: TPGState -> String -> [String] -> Bool -> IO ([PGTypeHandler], [(String, PGTypeHandler, Bool)]) -tpgDescribe tpg sql types nulls = do - at <- mapM (fmap fst . getTPGTypeOID tpg) types - (pt, rt) <- pgDescribe (tpgConnection tpg) sql at nulls - pth <- mapM (getTPGType tpg) pt +tpgDescribe :: PGConnection -> String -> [String] -> Bool -> IO ([PGTypeInfo], [(String, PGTypeInfo, Bool)]) +tpgDescribe conn sql types nulls = do + at <- mapM (fmap pgTypeOID . getPGTypeInfo conn . Right) types + (pt, rt) <- pgDescribe conn sql at nulls + pth <- mapM (getPGTypeInfo conn . Left) pt rth <- mapM (\(c, t, n) -> do - th <- getTPGType tpg t + th <- getPGTypeInfo conn (Left t) return (c, th, n)) rt return (pth, rth) -typeApply :: TH.Name -> String -> TH.Exp -typeApply f s = TH.AppE (TH.VarE f) $ - TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit s)) +typeApply :: TH.Name -> PGTypeInfo -> TH.Exp +typeApply f PGTypeInfo{ pgTypeName = n } = TH.AppE (TH.VarE f) $ + TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit n)) -- |TH expression to decode a 'Maybe' 'L.ByteString' to a 'Maybe' 'PGColumn' value. -pgTypeDecoder :: String -> TH.Exp +pgTypeDecoder :: PGTypeInfo -> TH.Exp pgTypeDecoder = typeApply 'pgDecodeColumn -- |TH expression to decode a 'Maybe' 'L.ByteString' to a 'PGColumn' value. -pgTypeDecoderNotNull :: String -> TH.Exp +pgTypeDecoderNotNull :: PGTypeInfo -> TH.Exp pgTypeDecoderNotNull = typeApply 'pgDecodeColumnNotNull -- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. -pgTypeEncoder :: String -> TH.Exp +pgTypeEncoder :: PGTypeInfo -> TH.Exp pgTypeEncoder = typeApply 'pgEncodeParameter -- |TH expression to escape a 'PGParameter' value to a SQL literal. -pgTypeEscaper :: String -> TH.Exp +pgTypeEscaper :: PGTypeInfo -> TH.Exp pgTypeEscaper = typeApply 'pgEscapeParameter diff --git a/Database/TemplatePG/Types.hs b/Database/TemplatePG/Types.hs index 081c9d9..600678c 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/TemplatePG/Types.hs @@ -8,30 +8,30 @@ module Database.TemplatePG.Types ( - -- * Classes and internal TH functions - PGValue + -- * Basic types + OID + , PGValue , PGValues + , pgQuote , PGTypeName(..) + + -- * Marshalling classes , PGParameter(..) , PGColumn(..) , PGStringType - , PGArrayType - , PGRangeType + + -- * Marshalling utilities , pgEncodeParameter , pgEscapeParameter , pgDecodeColumn , pgDecodeColumnNotNull + -- * Specific type support , pgBoolType , pgOIDType - - -- * Conversion utilities - , pgQuote - , OID - , PGTypeHandler(..) - , PGTypeMap - , defaultPGTypeMap - , pgArrayType + , pgNameType + , PGArrayType + , PGRangeType ) where import Control.Applicative ((<$>), (<$)) @@ -44,12 +44,10 @@ import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (isDigit, digitToInt, intToDigit, toLower) import Data.Int import Data.List (intercalate) -import qualified Data.Map as Map import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) -import qualified Language.Haskell.TH as TH import Numeric (readFloat) import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P @@ -197,6 +195,8 @@ instance PGStringType t => PGColumn t L.ByteString where instance PGStringType "text" instance PGStringType "varchar" instance PGStringType "name" -- limit 63 characters +pgNameType :: PGTypeName "name" +pgNameType = PGTypeProxy instance PGStringType "bpchar" -- blank padded @@ -470,73 +470,3 @@ instance PGRangeType "int8range" "int8" --, (1562, 1563, "varbit", ?) --, (2950, 2951, "uuid", ?) -} - -data PGTypeHandler = PGTypeHandler - { pgTypeOID :: OID - , pgTypeName' :: String -- ^ The internal PostgreSQL name of the type - , pgTypeType :: TH.Type -- ^ The equivalent Haskell type to which it is marshalled (must be an instance of 'PGType') - } deriving (Show) - -type PGTypeMap = Map.Map OID PGTypeHandler - -arrayType :: TH.Type -> TH.Type -arrayType = TH.AppT TH.ListT . TH.AppT (TH.ConT ''Maybe) - -pgArrayType :: OID -> String -> TH.Type -> PGTypeHandler -pgArrayType o n t = PGTypeHandler o ('_':n) (arrayType t) - -pgTypes :: [(OID, OID, String, TH.Name)] -pgTypes = - [ ( 16, 1000, "bool", ''Bool) - , ( 17, 1001, "bytea", ''L.ByteString) - , ( 18, 1002, "char", ''Char) - , ( 19, 1003, "name", ''String) -- limit 63 characters - , ( 20, 1016, "int8", ''Int64) - , ( 21, 1005, "int2", ''Int16) - , ( 23, 1007, "int4", ''Int32) - , ( 25, 1009, "text", ''String) - , ( 26, 1028, "oid", ''OID) ---, ( 114, 199, "json", ?) ---, ( 142, 143, "xml", ?) ---, ( 600, 1017, "point", ?) ---, ( 650, 651, "cidr", ?) - , ( 700, 1021, "float4", ''Float) - , ( 701, 1022, "float8", ''Double) ---, ( 790, 791, "money", Centi? Fixed?) ---, ( 829, 1040, "macaddr", ?) ---, ( 869, 1041, "inet", ?) - , (1042, 1014, "bpchar", ''String) - , (1043, 1015, "varchar", ''String) - , (1082, 1182, "date", ''Time.Day) - , (1083, 1183, "time", ''Time.TimeOfDay) - , (1114, 1115, "timestamp", ''Time.LocalTime) - , (1184, 1185, "timestamptz", ''Time.UTCTime) - , (1186, 1187, "interval", ''Time.DiffTime) ---, (1266, 1270, "timetz", ?) ---, (1560, 1561, "bit", Bool?) ---, (1562, 1563, "varbit", ?) - , (1700, 1231, "numeric", ''Rational) ---, (2950, 2951, "uuid", ?) - ] - -rangeType :: TH.Type -> TH.Type -rangeType = TH.AppT (TH.ConT ''Range.Range) - -rangeTypes :: [(OID, OID, String, TH.Name)] -rangeTypes = - [ (3904, 3905, "int4range", ''Int32) - , (3906, 3907, "numrange", ''Rational) - , (3908, 3909, "tsrange", ''Time.LocalTime) - , (3910, 3911, "tstzrange", ''Time.UTCTime) - , (3912, 3913, "daterange", ''Time.Day) - , (3926, 3927, "int8range", ''Int32) - ] - -defaultPGTypeMap :: PGTypeMap -defaultPGTypeMap = - Map.fromAscList - ([(o, PGTypeHandler o n (TH.ConT t)) | (o, _, n, t) <- pgTypes] - ++ [(o, PGTypeHandler o n (rangeType (TH.ConT t))) | (o, _, n, t) <- rangeTypes]) - `Map.union` Map.fromList - ([(o, pgArrayType o n (TH.ConT t)) | (_, o, n, t) <- pgTypes] - ++ [(o, pgArrayType o n (rangeType (TH.ConT t))) | (_, o, n, t) <- rangeTypes]) diff --git a/test/Main.hs b/test/Main.hs index d02b1db..ea095df 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -23,7 +23,7 @@ simpleApply :: PGConnection -> OID -> IO [Maybe String] simpleApply c = pgQuery c . [pgSQL|?SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] prepared :: PGConnection -> OID -> IO [Maybe String] prepared c t = pgQuery c [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] -preparedApply :: PGConnection -> [pgSQL|int4|] -> IO [String] +preparedApply :: PGConnection -> Int32 -> IO [String] preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] main :: IO () From e1880456a2504b28bdbfc4c4e1de174d4aa3f47b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 17:48:44 -0500 Subject: [PATCH 073/306] Docs update: clarify new caveat about type ambiguity --- Database/TemplatePG.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/Database/TemplatePG.hs b/Database/TemplatePG.hs index 3eaac78..cd195e2 100644 --- a/Database/TemplatePG.hs +++ b/Database/TemplatePG.hs @@ -165,7 +165,8 @@ import Database.TemplatePG.SQL -- $types -- Most builtin types are already supported. --- For the most part, only exactly equivalent types are used (e.g., 'Int32' for int4). +-- For the most part, exactly equivalent types are all supported (e.g., 'Int32' for int4) as well as other safe equivalents, but you cannot, for example, pass an 'Integer' as a @smallint@. +-- To achieve this flexibility, the exact types of all parameters and results must be fully known (e.g., numeric literals will not work). -- -- However you can add support for your own types or add flexibility to existing types by creating new instances of '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): @@ -195,7 +196,7 @@ import Database.TemplatePG.SQL -- I've included 'withTransaction', 'rollback', and 'insertIgnore', but they've -- not been thoroughly tested, so use them at your own risk. -- --- The types of any parameter expressions must be fully known. This may +-- 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 @@ -206,10 +207,6 @@ import Database.TemplatePG.SQL -- 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\") --- @ +-- > (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\") From 57543104b6821acf720858a396e7e5da31d3103a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 18:24:52 -0500 Subject: [PATCH 074/306] Rename package to postgresql-typed Rename SQL to TemeplatePG and add more backwards compatibility support --- .../{TemplatePG.hs => PostgreSQL/Typed.hs} | 34 ++++------ .../{TemplatePG => PostgreSQL/Typed}/Enum.hs | 11 +-- .../Typed}/Protocol.hs | 4 +- .../{TemplatePG => PostgreSQL/Typed}/Query.hs | 10 +-- .../{TemplatePG => PostgreSQL/Typed}/Range.hs | 4 +- .../{TemplatePG => PostgreSQL/Typed}/TH.hs | 14 ++-- .../SQL.hs => PostgreSQL/Typed/TemplatePG.hs} | 68 +++++++++++++------ .../{TemplatePG => PostgreSQL/Typed}/Types.hs | 6 +- postgresql-typed.cabal | 61 +++++++++++++++++ templatepg.cabal | 65 ------------------ 10 files changed, 147 insertions(+), 130 deletions(-) rename Database/{TemplatePG.hs => PostgreSQL/Typed.hs} (89%) rename Database/{TemplatePG => PostgreSQL/Typed}/Enum.hs (89%) rename Database/{TemplatePG => PostgreSQL/Typed}/Protocol.hs (99%) rename Database/{TemplatePG => PostgreSQL/Typed}/Query.hs (98%) rename Database/{TemplatePG => PostgreSQL/Typed}/Range.hs (97%) rename Database/{TemplatePG => PostgreSQL/Typed}/TH.hs (93%) rename Database/{TemplatePG/SQL.hs => PostgreSQL/Typed/TemplatePG.hs} (61%) rename Database/{TemplatePG => PostgreSQL/Typed}/Types.hs (99%) create mode 100644 postgresql-typed.cabal delete mode 100644 templatepg.cabal diff --git a/Database/TemplatePG.hs b/Database/PostgreSQL/Typed.hs similarity index 89% rename from Database/TemplatePG.hs rename to Database/PostgreSQL/Typed.hs index cd195e2..abe9321 100644 --- a/Database/TemplatePG.hs +++ b/Database/PostgreSQL/Typed.hs @@ -1,7 +1,7 @@ -- Copyright 2010, 2011, 2012, 2013 Chris Forno --- Copyright 2014 Dylan Simon +-- Copyright 2014-2015 Dylan Simon -module Database.TemplatePG +module Database.PostgreSQL.Typed ( -- *Introduction -- $intro @@ -33,8 +33,8 @@ module Database.TemplatePG , pgQuery , pgExecute - -- **Basic queries - -- $basic + -- **TemplatePG compatibility + -- $templatepg -- *Advanced usage @@ -47,22 +47,17 @@ module Database.TemplatePG -- *Caveats -- $caveats - , withTransaction - , rollback - , insertIgnore - -- **Tips -- $tips ) where -import Database.TemplatePG.Protocol -import Database.TemplatePG.TH -import Database.TemplatePG.Query -import Database.TemplatePG.SQL +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.Query -- $intro --- TemplatePG is designed with 2 goals in mind: safety and performance. The +-- 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 @@ -77,11 +72,10 @@ import Database.TemplatePG.SQL -- 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 specially. +-- detected and need to be handled explicitly. -- --- Use the software at your own risk. Note however that TemplatePG is currently powering --- with no problems yet. (For usage examples, you --- can see the Vocabulink source code at ). +-- 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': @@ -145,9 +139,9 @@ import Database.TemplatePG.SQL -- 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'.) --- $basic --- There is also an older, simpler interface that combines both the compile and runtime steps. --- 'queryTuples' does all the work ('queryTuple' and 'execute' are convenience +-- $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 diff --git a/Database/TemplatePG/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs similarity index 89% rename from Database/TemplatePG/Enum.hs rename to Database/PostgreSQL/Typed/Enum.hs index 3d4b9ca..16aa655 100644 --- a/Database/TemplatePG/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} -- | --- Module: Database.TemplatePG.Enum +-- Module: Database.PostgreSQL.Typed.Enum -- Copyright: 2015 Dylan Simon -- -- Support for PostgreSQL enums. -module Database.TemplatePG.Enum +module Database.PostgreSQL.Typed.Enum ( makePGEnum ) where @@ -14,9 +15,9 @@ import Data.Foldable (toList) import qualified Data.Sequence as Seq import qualified Language.Haskell.TH as TH -import Database.TemplatePG.Protocol -import Database.TemplatePG.TH -import Database.TemplatePG.Types +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 diff --git a/Database/TemplatePG/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs similarity index 99% rename from Database/TemplatePG/Protocol.hs rename to Database/PostgreSQL/Typed/Protocol.hs index bc5cf20..f0f2b33 100644 --- a/Database/TemplatePG/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -5,7 +5,7 @@ -- PostgreSQL server over TCP/IP. You probably don't want to use this module -- directly. -module Database.TemplatePG.Protocol ( +module Database.PostgreSQL.Typed.Protocol ( PGDatabase(..) , defaultPGDatabase , PGConnection @@ -47,7 +47,7 @@ import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) -import Database.TemplatePG.Types +import Database.PostgreSQL.Typed.Types data PGState = StateUnknown diff --git a/Database/TemplatePG/Query.hs b/Database/PostgreSQL/Typed/Query.hs similarity index 98% rename from Database/TemplatePG/Query.hs rename to Database/PostgreSQL/Typed/Query.hs index 58bb5bd..a01c106 100644 --- a/Database/TemplatePG/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} -module Database.TemplatePG.Query +{-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-} +module Database.PostgreSQL.Typed.Query ( PGQuery(..) , PGSimpleQuery , PGPreparedQuery @@ -29,9 +29,9 @@ import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Numeric (readDec) -import Database.TemplatePG.Types -import Database.TemplatePG.Protocol -import Database.TemplatePG.TH +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. diff --git a/Database/TemplatePG/Range.hs b/Database/PostgreSQL/Typed/Range.hs similarity index 97% rename from Database/TemplatePG/Range.hs rename to Database/PostgreSQL/Typed/Range.hs index de79f2a..7def048 100644 --- a/Database/TemplatePG/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,12 +1,12 @@ -- | --- Module: Database.TemplatePG.Range +-- 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.TemplatePG.Range where +module Database.PostgreSQL.Typed.Range where import Control.Applicative ((<$)) import Control.Monad (guard) diff --git a/Database/TemplatePG/TH.hs b/Database/PostgreSQL/Typed/TH.hs similarity index 93% rename from Database/TemplatePG/TH.hs rename to Database/PostgreSQL/Typed/TH.hs index ffec06f..7a43fe1 100644 --- a/Database/TemplatePG/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE PatternGuards, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables, FlexibleContexts, TemplateHaskell #-} -- | --- Module: Database.TemplatePG.TH +-- Module: Database.PostgreSQL.Typed.TH -- Copyright: 2015 Dylan Simon -- -- Support functions for compile-time PostgreSQL connection and state management. -- Although this is meant to be used from other TH code, it will work during normal runtime if just want simple PGConnection management. -module Database.TemplatePG.TH +module Database.PostgreSQL.Typed.TH ( getTPGDatabase , withTPGConnection , useTPGDatabase @@ -29,8 +29,8 @@ import Network (PortID(UnixSocket, PortNumber), PortNumber) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) -import Database.TemplatePG.Types -import Database.TemplatePG.Protocol +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol -- |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@ () @@ -55,14 +55,14 @@ getTPGDatabase = do tpgConnection :: MVar (Either (IO PGConnection) PGConnection) tpgConnection = unsafePerformIO $ newMVar $ Left $ pgConnect =<< getTPGDatabase --- |Run an action using the TemplatePG connection. +-- |Run an action using the Template Haskell PostgreSQL connection. withTPGConnection :: (PGConnection -> IO a) -> IO a withTPGConnection f = modifyMVar tpgConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) setTPGConnection :: Either (IO PGConnection) PGConnection -> IO () setTPGConnection = void . swapMVar tpgConnection --- |Specify an alternative database to use during TemplatePG compilation. +-- |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 will also clear all types registered with 'registerTPGType'. diff --git a/Database/TemplatePG/SQL.hs b/Database/PostgreSQL/Typed/TemplatePG.hs similarity index 61% rename from Database/TemplatePG/SQL.hs rename to Database/PostgreSQL/Typed/TemplatePG.hs index 04203e7..b45d732 100644 --- a/Database/TemplatePG/SQL.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- |This module exposes the high-level Template Haskell interface for querying @@ -9,21 +10,27 @@ -- Note that transactions are messy and untested. Attempt to use them at your -- own risk. -module Database.TemplatePG.SQL ( queryTuples - , queryTuple - , execute - , insertIgnore - , withTransaction - , rollback - ) where +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) -import Language.Haskell.TH +import Data.Maybe (listToMaybe, isJust) +import qualified Language.Haskell.TH as TH +import Network (HostName, PortID(..)) +import System.Environment (lookupEnv) -import Database.TemplatePG.Protocol -import Database.TemplatePG.Query +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 @@ -39,7 +46,7 @@ querySQL "" = "" -- -- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h :: IO [(Maybe String, Maybe Integer)] -- @ -queryTuples :: String -> Q Exp +queryTuples :: String -> TH.ExpQ queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleFlags $ querySQL sql) |] -- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ @@ -53,7 +60,7 @@ queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleFlags $ querySQL sql) | -- -- $(queryTuple \"SELECT usesysid, usename FROM pg_user WHERE usesysid = {sysid}\") h :: IO (Maybe (Maybe String, Maybe Integer)) -- @ -queryTuple :: String -> Q Exp +queryTuple :: String -> TH.ExpQ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- |@execute :: String -> (PGConnection -> IO ())@ @@ -66,26 +73,45 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- -- $(execute \"CREATE ROLE {rolename}\") h -- @ -execute :: String -> Q Exp +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 :: PGConnection -> IO a -> IO a +withTransaction :: PG.PGConnection -> IO a -> IO a withTransaction h a = - onException (do void $ pgSimpleQuery h "BEGIN" + onException (do void $ PG.pgSimpleQuery h "BEGIN" c <- a - void $ pgSimpleQuery h "COMMIT" + void $ PG.pgSimpleQuery h "COMMIT" return c) - (void $ pgSimpleQuery h "ROLLBACK") + (void $ PG.pgSimpleQuery h "ROLLBACK") -- |Roll back a transaction. -rollback :: PGConnection -> IO () -rollback h = void $ pgSimpleQuery h "ROLLBACK" +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 (PGError m) = guard (pgMessageCode m == "24505") + 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/TemplatePG/Types.hs b/Database/PostgreSQL/Typed/Types.hs similarity index 99% rename from Database/TemplatePG/Types.hs rename to Database/PostgreSQL/Typed/Types.hs index 600678c..606ab46 100644 --- a/Database/TemplatePG/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} -- | --- Module: Database.TemplatePG.Type +-- Module: Database.PostgreSQL.Typed.Type -- Copyright: 2010, 2011, 2013 Chris Forno -- Copyright: 2015 Dylan Simon -- -- Classes to support type inference, value encoding/decoding, and instances to support built-in PostgreSQL types. -module Database.TemplatePG.Types +module Database.PostgreSQL.Typed.Types ( -- * Basic types OID @@ -53,7 +53,7 @@ import System.Locale (defaultTimeLocale) import qualified Text.Parsec as P import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) -import qualified Database.TemplatePG.Range as Range +import qualified Database.PostgreSQL.Typed.Range as Range type PGValue = L.ByteString -- |A list of (nullable) data values, e.g. a single row or query parameters. diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal new file mode 100644 index 0000000..64f8492 --- /dev/null +++ b/postgresql-typed.cabal @@ -0,0 +1,61 @@ +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 + +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 + +test-suite test + build-depends: base, network, time, templatepg + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: True + hs-source-dirs: test + Extensions: TemplateHaskell, QuasiQuotes + GHC-Options: -Wall diff --git a/templatepg.cabal b/templatepg.cabal deleted file mode 100644 index 7b4f17c..0000000 --- a/templatepg.cabal +++ /dev/null @@ -1,65 +0,0 @@ -Name: templatepg -Version: 0.3.0 -Cabal-Version: >= 1.8 -License: BSD3 -License-File: COPYING -Copyright: 2010, 2011, 2012, 2013 Chris Forno -Author: Chris Forno (jekor), Dylan Simon -Maintainer: jekor@jekor.com -Stability: alpha -Bug-Reports: https://github.com/jekor/templatepg/issues -Homepage: https://github.com/jekor/templatepg -Package-URL: https://github.com/jekor/templatepg/archive/master.tar.gz -Category: Database -Synopsis: A PostgreSQL access library with compile-time SQL type inference -Description: TemplatePG provides PostgreSQL access from Haskell via the - PostgreSQL protocol. It also provides a higher-level Template - Haskell interface. It eliminates a class of runtime errors by - checking queries against a PostgreSQL database at compile-time. - This also reduces boilerplate code for dealing with query - results, as the type and number of result columns are known at - compile-time. -Tested-With: GHC == 7.8.4 -Build-Type: Simple - -source-repository head - type: git - location: git://github.com/jekor/templatepg.git - -Flag md5 - Description: Enable md5 password authentication method - 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.TemplatePG - Database.TemplatePG.Protocol - Database.TemplatePG.Types - Database.TemplatePG.TH - Database.TemplatePG.Query - Database.TemplatePG.SQL - Database.TemplatePG.Enum - Database.TemplatePG.Range - Extensions: TemplateHaskell - GHC-Options: -Wall - if flag(md5) - Build-Depends: cryptohash >= 0.5 - CPP-options: -DUSE_MD5 - -test-suite test - build-depends: base, network, time, templatepg - type: exitcode-stdio-1.0 - main-is: Main.hs - buildable: True - hs-source-dirs: test - Extensions: TemplateHaskell, QuasiQuotes - GHC-Options: -Wall From 94a40d1fc10e880e1f9e3379267680bf60739ed9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 18:27:36 -0500 Subject: [PATCH 075/306] Slim down README --- README | 27 +++------------------------ 1 file changed, 3 insertions(+), 24 deletions(-) diff --git a/README b/README index 42639f3..a9ab781 100644 --- a/README +++ b/README @@ -1,24 +1,3 @@ -TemplatePG is designed with 2 goals in mind: safety and performance. The -primary focus is on safety. - -To help ensure safety, it uses the PostgreSQL server to parse every query and -statement in your code to infer types at compile-time. This means that in -theory you cannot get a syntax error at runtime. Getting proper types at -compile time has the nice side-effect that it eliminates run-time type casting -and usually results in less code. This approach was inspired by MetaHDBC -(http://haskell.org/haskellwiki/MetaHDBC) and PG'OCaml -(http://pgocaml.berlios.de/). - -While compile-time query analysis eliminates many errors, it doesn't eliminate -all of them. If you modify the database without recompilation or have an error -in a trigger or function, for example, you can still trigger a 'PGException' or -other failure (if types change). Also, nullable result fields resulting from -outer joins are not detected and need to be handled specially. - -Use the software at your own risk. Note however that TemplatePG is currently -powering http://www.vocabulink.com/ with no problems yet. (For usage -examples, you can see the Vocabulink source code at -https://github.com/jekor/vocabulink). - -See the Haddock documentation at http://hackage.haskell.org/package/templatepg -for how to use TemplatePG. +A PostgreSQL interface that provides type-safety through compile-time database +access. See the Haddock documentation in Database.PostgreSQL.Typed or the test +cases for simple examples. From 9bda350d3414913784602aaf9d37bf750cf7cfa4 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 18:32:35 -0500 Subject: [PATCH 076/306] Update testcase for package rename --- postgresql-typed.cabal | 2 +- test/Connect.hs | 2 +- test/Main.hs | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 64f8492..65c9551 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -52,7 +52,7 @@ Library CPP-options: -DUSE_MD5 test-suite test - build-depends: base, network, time, templatepg + build-depends: base, network, time, postgresql-typed type: exitcode-stdio-1.0 main-is: Main.hs buildable: True diff --git a/test/Connect.hs b/test/Connect.hs index a9e4e58..210d253 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -1,6 +1,6 @@ module Connect where -import Database.TemplatePG (PGDatabase(..), defaultPGDatabase) +import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase) import Network (PortID(UnixSocket)) db :: PGDatabase diff --git a/test/Main.hs b/test/Main.hs index ea095df..bbb20a2 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -4,10 +4,10 @@ import Data.Int (Int32) import qualified Data.Time as Time import System.Exit (exitSuccess, exitFailure) -import Database.TemplatePG -import Database.TemplatePG.Types (OID) -import Database.TemplatePG.SQL -import qualified Database.TemplatePG.Range as Range +import Database.PostgreSQL.Typed +import Database.PostgreSQL.Typed.Types (OID) +import Database.PostgreSQL.Typed.TemplatePG (queryTuple) +import qualified Database.PostgreSQL.Typed.Range as Range import Connect From d761acf911af64a2ab928d5449f9ea1586694e0c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 20:44:01 -0500 Subject: [PATCH 077/306] Optimize array and range encoders; fix makePGEnum --- Database/PostgreSQL/Typed/Enum.hs | 22 +++++++++++---- Database/PostgreSQL/Typed/Types.hs | 44 +++++++++++++++--------------- test/Connect.hs | 1 + test/Main.hs | 2 ++ 4 files changed, 42 insertions(+), 27 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 16aa655..ae32c02 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} -- | -- Module: Database.PostgreSQL.Typed.Enum -- Copyright: 2015 Dylan Simon @@ -10,6 +10,7 @@ module Database.PostgreSQL.Typed.Enum ) where import Control.Monad (when) +import qualified Data.ByteString.Lazy.Char8 as BSC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Foldable (toList) import qualified Data.Sequence as Seq @@ -28,22 +29,33 @@ import Database.PostgreSQL.Typed.Types -- 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 valf = do +makePGEnum name typs valnf = do (_, vals) <- TH.runIO $ withTPGConnection $ \c -> pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgQuote name ++ " ORDER BY enumsortorder" when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let - valn = map (\[Just v] -> let s = U.toString v in (TH.StringL s, TH.mkName $ valf s)) $ toList vals + valn = map (\[Just 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.LitE l)) []) valn ] + [ 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 $ map (\(l, n) -> TH.Clause [TH.WildP, TH.LitP l] (TH.NormalB (TH.ConE n)) []) valn ] + [ 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 diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 606ab46..1a2f720 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -38,12 +38,16 @@ import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero) import Data.Bits (shiftL, shiftR, (.|.), (.&.)) import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (isDigit, digitToInt, intToDigit, toLower) import Data.Int -import Data.List (intercalate) +import Data.List (intersperse) +import Data.Monoid ((<>), mconcat, mempty) import Data.Ratio ((%), numerator, denominator) import qualified Data.Time as Time import Data.Word (Word32) @@ -124,15 +128,13 @@ pgQuote = ('\'':) . es where es (c@'\'':r) = c:c:es r es (c:r) = c:es r -dQuote :: String -> String -> String -dQuote _ "" = "\"\"" +dQuote :: String -> L.ByteString -> B.Builder dQuote unsafe s - | all (`notElem` unsafe) s && map toLower s /= "null" = s - | otherwise = '"':es s where - es "" = "\"" - es (c@'"':r) = '\\':c:es r - es (c@'\\':r) = '\\':c:es r - es (c:r) = c:es r + | not (L.null s) && all (`LC.notElem` s) unsafe && LC.map toLower s /= LC.pack "null" = B.lazyByteString s + | otherwise = dq <> BP.primMapLazyByteStringBounded ec s <> dq where + dq = B.char7 '"' + ec = BP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BP.liftFixedToBounded BP.word8) + bs = BP.liftFixedToBounded $ ((,) '\\') BP.>$< (BP.char7 BP.>*< BP.word8) parseDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String parseDQuote unsafe = (q P.<|> uq) where @@ -329,10 +331,9 @@ class (KnownSymbol ta, KnownSymbol t) => PGArrayType ta t | ta -> t, t -> ta whe pgArrayDelim _ = ',' instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where - -- TODO: rewrite to use BS - pgEncode ta l = U.fromString $ '{' : intercalate [pgArrayDelim ta] (map el l) ++ "}" where - el Nothing = "null" - el (Just e) = dQuote (pgArrayDelim ta : "\"\\{}") $ U.toString $ pgEncode (pgArrayElementType ta) e + pgEncode ta l = B.toLazyByteString $ B.char7 '{' <> mconcat (intersperse (B.char7 $ pgArrayDelim ta) $ map el l) <> B.char7 '}' where + el Nothing = B.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 @@ -422,17 +423,16 @@ class (KnownSymbol tr, KnownSymbol t) => PGRangeType tr t | tr -> t where instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range.Range a) where pgEncode _ Range.Empty = LC.pack "empty" - -- TODO: rewrite to use BS - pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = U.fromString $ + pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = B.toLazyByteString $ pc '[' '(' l - : pb (Range.bound l) - ++ ',' - : pb (Range.bound u) - ++ [pc ']' ')' u] + <> pb (Range.bound l) + <> B.char7 ',' + <> pb (Range.bound u) + <> pc ']' ')' u where - pb Nothing = "" - pb (Just b) = dQuote "\"(),[\\]" $ U.toString $ pgEncode (pgRangeElementType tr) b - pc c o b = if Range.boundClosed b then c else o + pb Nothing = mempty + pb (Just b) = dQuote "\"(),[\\]" $ pgEncode (pgRangeElementType tr) b + pc c o b = B.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 "array" where per = Range.Empty <$ pe P.<|> pr diff --git a/test/Connect.hs b/test/Connect.hs index 210d253..aeb0ff6 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -8,5 +8,6 @@ db = defaultPGDatabase { pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432" , pgDBName = "templatepg" , pgDBUser = "templatepg" + , pgDBDebug = True } diff --git a/test/Main.hs b/test/Main.hs index bbb20a2..c005159 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds #-} module Main (main) where import Data.Int (Int32) @@ -7,6 +8,7 @@ import System.Exit (exitSuccess, exitFailure) import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types (OID) import Database.PostgreSQL.Typed.TemplatePG (queryTuple) +import Database.PostgreSQL.Typed.Enum import qualified Database.PostgreSQL.Typed.Range as Range import Connect From c8b9d618bdcd804d371cd522c088817ae8ce0be0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 21:13:05 -0500 Subject: [PATCH 078/306] Add (optional) support for uuid and scientific Add binary flag, unused --- Database/PostgreSQL/Typed/Types.hs | 22 ++++++++++++++++++++-- postgresql-typed.cabal | 21 +++++++++++++++++++++ test/Main.hs | 1 - 3 files changed, 41 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 1a2f720..748f740 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} -- | -- Module: Database.PostgreSQL.Typed.Type -- Copyright: 2010, 2011, 2013 Chris Forno @@ -47,9 +47,16 @@ import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (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 import qualified Data.Time as Time +#ifdef USE_UUID +import qualified Data.UUID as UUID +#endif import Data.Word (Word32) import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) import Numeric (readFloat) @@ -318,6 +325,10 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where 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. type PGArray a = [Maybe a] @@ -456,6 +467,14 @@ instance PGRangeType "tstzrange" "timestamptz" instance PGRangeType "daterange" "date" instance PGRangeType "int8range" "int8" +#ifdef USE_UUID +instance PGParameter "uuid" UUID.UUID where + pgEncode _ = UUID.toLazyASCIIBytes + pgLiteral _ = pgQuoteUnsafe . UUID.toString +instance PGColumn "uuid" UUID.UUID where + pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ LC.unpack u) $ UUID.fromLazyASCIIBytes u +#endif + {- --, ( 114, 199, "json", ?) @@ -468,5 +487,4 @@ instance PGRangeType "int8range" "int8" --, (1266, 1270, "timetz", ?) --, (1560, 1561, "bit", Bool?) --, (1562, 1563, "varbit", ?) ---, (2950, 2951, "uuid", ?) -} diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 65c9551..1de0111 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -27,6 +27,18 @@ Flag md5 Description: Enable md5 password authentication method Default: True +Flag uuid + Description: Support the UUID type via uuid + Default: True + +Flag scientific + Description: Support decoding numeric via scientific + Default: True + +Flag binary + Description: Use binary protocol encoding via postgresql-binary + Default: True + Library Build-Depends: base >= 4.7 && < 5, @@ -50,6 +62,15 @@ Library if flag(md5) Build-Depends: cryptohash >= 0.5 CPP-options: -DUSE_MD5 + if flag(uuid) + Build-Depends: uuid >= 1.3 + CPP-options: -DUSE_UUID + if flag(scientific) + Build-Depends: scientific >= 0.3 + CPP-options: -DUSE_SCIENTIFIC + if flag(binary) + Build-Depends: postgresql-binary >= 0.5.0 + CPP-options: -DUSE_BINARY test-suite test build-depends: base, network, time, postgresql-typed diff --git a/test/Main.hs b/test/Main.hs index c005159..1f89716 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,6 @@ import System.Exit (exitSuccess, exitFailure) import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types (OID) import Database.PostgreSQL.Typed.TemplatePG (queryTuple) -import Database.PostgreSQL.Typed.Enum import qualified Database.PostgreSQL.Typed.Range as Range import Connect From 2212cba4c2d61a58f6418227219feda61ebe924d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 2 Jan 2015 21:26:12 -0500 Subject: [PATCH 079/306] Add protocol support for binary format indicators (unused) --- Database/PostgreSQL/Typed/Protocol.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index f0f2b33..bc13b5e 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -88,6 +88,7 @@ data ColDescription = ColDescription , colTable :: !OID , colNumber :: !Int , colType :: !OID + , colBinary :: !Bool } deriving (Show) type MessageFields = Map.Map Word8 L.ByteString @@ -97,7 +98,7 @@ type MessageFields = Map.Map Word8 L.ByteString data PGFrontendMessage = StartupMessage [(String, String)] -- only sent first | CancelRequest !Word32 !Word32 -- sent first on separate connection - | Bind { statementName :: String, bindParameters :: PGValues } + | Bind { statementName :: String, binaryParameters :: [Bool], bindParameters :: PGValues, binaryColumns :: [Bool] } | Close { statementName :: String } -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). @@ -209,11 +210,11 @@ messageBody (StartupMessage kv) = (Nothing, B.word32BE 0x30000 <> 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 } = (Just 'B', +messageBody Bind{ statementName = n, binaryParameters = bp, bindParameters = p, binaryColumns = bc } = (Just 'B', nul <> pgString n - <> B.word16BE 0 + <> B.word16BE (fromIntegral $ length bp) <> foldMap (B.word16LE . fromIntegral . fromEnum) bp <> B.word16BE (fromIntegral $ length p) <> foldMap (maybe (B.word32BE 0xFFFFFFFF) val) p - <> B.word16BE 0) + <> B.word16BE (fromIntegral $ length bc) <> foldMap (B.word16LE . fromIntegral . fromEnum) bc) where val v = B.word32BE (fromIntegral $ L.length v) <> B.lazyByteString v messageBody Close{ statementName = n } = (Just 'C', B.char7 'S' <> pgString n) @@ -273,12 +274,13 @@ getMessageBody 'T' = do typ' <- G.getWord32be -- type _ <- G.getWord16be -- type size _ <- G.getWord32be -- type modifier - 0 <- G.getWord16be -- format code + fmt <- G.getWord16be -- format code return $ ColDescription { colName = name , colTable = oid , colNumber = fromIntegral col , colType = typ' + , colBinary = toEnum (fromIntegral fmt) } getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where rs 'I' = return StateIdle @@ -408,7 +410,7 @@ pgDescribe h sql types nulls = do RowDescription r -> mapM desc r _ -> fail $ "describeStatement: unexpected response: " ++ show m where - desc (ColDescription name tab col typ) = do + 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. @@ -461,7 +463,7 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = d let sn = show n unless p $ pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = types } - pgSend c $ Bind{ statementName = sn, bindParameters = bind } + pgSend c $ Bind{ statementName = sn, binaryParameters = [], bindParameters = bind, binaryColumns = [] } let go = pgHandle c start start ParseComplete = do From c0f970b51c001e7f2362f16588746e5a13340884 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 01:14:47 -0500 Subject: [PATCH 080/306] Complete infrastructure to support binary types (unused) --- Database/PostgreSQL/Typed/Enum.hs | 2 +- Database/PostgreSQL/Typed/Protocol.hs | 80 ++++++++++++++++----------- Database/PostgreSQL/Typed/Query.hs | 45 +++++++-------- Database/PostgreSQL/Typed/TH.hs | 50 ++++++++++------- Database/PostgreSQL/Typed/Types.hs | 68 ++++++++++++++++++----- 5 files changed, 151 insertions(+), 94 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index ae32c02..49c5048 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -40,7 +40,7 @@ makePGEnum name typs valnf = do pgSimpleQuery c $ "SELECT enumlabel FROM pg_catalog.pg_enum JOIN pg_catalog.pg_type ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgQuote name ++ " ORDER BY enumsortorder" when (Seq.null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let - valn = map (\[Just v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) $ toList vals + 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 diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index bc13b5e..6efdb49 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -9,7 +9,6 @@ module Database.PostgreSQL.Typed.Protocol ( PGDatabase(..) , defaultPGDatabase , PGConnection - , PGValues , PGError(..) , pgMessageCode , pgConnect @@ -29,12 +28,13 @@ import Control.Monad (liftM2, replicateM, when, unless) 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 Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U -import Data.Foldable (foldMap, forM_, toList) +import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -98,7 +98,7 @@ type MessageFields = Map.Map Word8 L.ByteString data PGFrontendMessage = StartupMessage [(String, String)] -- only sent first | CancelRequest !Word32 !Word32 -- sent first on separate connection - | Bind { statementName :: String, binaryParameters :: [Bool], bindParameters :: PGValues, binaryColumns :: [Bool] } + | Bind { statementName :: String, bindParameters :: PGValues, binaryColumns :: [Bool] } | Close { statementName :: String } -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). @@ -207,15 +207,22 @@ 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 - <> foldMap (\(k, v) -> pgString k <> pgString v) kv <> nul) + <> 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, binaryParameters = bp, bindParameters = p, binaryColumns = bc } = (Just 'B', +messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = (Just 'B', nul <> pgString n - <> B.word16BE (fromIntegral $ length bp) <> foldMap (B.word16LE . fromIntegral . fromEnum) bp - <> B.word16BE (fromIntegral $ length p) <> foldMap (maybe (B.word32BE 0xFFFFFFFF) val) p - <> B.word16BE (fromIntegral $ length bc) <> foldMap (B.word16LE . fromIntegral . fromEnum) bc) - where val v = B.word32BE (fromIntegral $ L.length v) <> B.lazyByteString v + <> (if any fmt p + then B.word16BE (fromIntegral $ length p) <> Fold.foldMap (B.word16LE . fromIntegral . fromEnum . fmt) p + else B.word16BE 0) + <> B.word16BE (fromIntegral $ length p) <> Fold.foldMap val p + <> B.word16BE (fromIntegral $ length bc) <> Fold.foldMap (B.word16LE . fromIntegral . fromEnum) bc) + where + fmt (PGBinaryValue _) = True + fmt _ = False + val PGNullValue = B.int32BE (-1) + val (PGTextValue v) = B.word32BE (fromIntegral $ L.length v) <> B.lazyByteString 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', @@ -225,7 +232,7 @@ messageBody (Execute r) = (Just 'E', messageBody Flush = (Just 'H', mempty) messageBody Parse{ statementName = n, queryString = s, parseTypes = t } = (Just 'P', pgString n <> pgString s - <> B.word16BE (fromIntegral $ length t) <> foldMap B.word32BE t) + <> B.word16BE (fromIntegral $ length t) <> Fold.foldMap B.word32BE t) messageBody (PasswordMessage s) = (Just 'p', B.lazyByteString s <> nul) messageBody SimpleQuery{ queryString = s } = (Just 'Q', @@ -238,7 +245,7 @@ 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 $ foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + L.length b) + B.hPutBuilder h $ Fold.foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + L.length b) L.hPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length where (t, b) = second B.toLazyByteString $ messageBody msg @@ -295,8 +302,9 @@ getMessageBody 'S' = liftM2 ParameterStatus getPGString getPGString getMessageBody 'D' = do numFields <- G.getWord16be DataRow <$> replicateM (fromIntegral numFields) (getField =<< G.getWord32be) where - getField 0xFFFFFFFF = return Nothing - getField len = Just <$> G.getLazyByteString (fromIntegral len) + getField 0xFFFFFFFF = return PGNullValue + getField len = PGTextValue <$> G.getLazyByteString (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 @@ -421,8 +429,8 @@ pgDescribe h sql types nulls = 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 toList r of - [[Just s]] -> return $ not $ pgDecode pgBoolType s + case Fold.toList r of + [[PGTextValue s]] -> return $ not $ pgDecode pgBoolType s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col | otherwise = return True @@ -432,6 +440,13 @@ rowsAffected = ra . LC.words where ra [] = -1 ra l = fromMaybe (-1) $ readMaybe $ LC.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 (L.fromStrict x) : fixBinary b r +fixBinary (True :b) (PGTextValue x:r) = PGBinaryValue (L.toStrict 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 @@ -445,25 +460,25 @@ pgSimpleQuery h sql = do go start where go = pgHandle h start (CommandComplete c) = got c Seq.empty - start (RowDescription _) = go (row Seq.empty) + start (RowDescription rd) = go $ row (map colBinary rd) Seq.empty start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m - row s (DataRow fs) = go $ row (s Seq.|> fs) - row s (CommandComplete c) = got c s - row _ m = fail $ "pgSimpleQuery: unexpected row: " ++ 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 = (rowsAffected c, s) <$ go end end (ReadyForQuery _) = return [] end EmptyQueryResponse = go end end m = fail $ "pgSimpleQuery: unexpected message: " ++ show m -pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> IO (IO ()) -pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = do +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, binaryParameters = [], bindParameters = bind, binaryColumns = [] } + pgSend c $ Bind{ statementName = sn, bindParameters = bind, binaryColumns = bc } let go = pgHandle c start start ParseComplete = do @@ -480,9 +495,10 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind = d 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 = do - start <- pgPreparedBind c sql types bind +pgPreparedQuery c sql types bind bc = do + start <- pgPreparedBind c sql types bind bc pgSend c $ Execute 0 pgSend c $ Flush pgFlush c @@ -490,16 +506,16 @@ pgPreparedQuery c sql types bind = do go Seq.empty where go = pgHandle c . row - row s (DataRow fs) = go (s Seq.|> fs) + row s (DataRow fs) = go (s Seq.|> fixBinary bc fs) row s (CommandComplete r) = return (rowsAffected r, 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 -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) +pgPreparedLazyQuery :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) -> IO [PGValues] -pgPreparedLazyQuery c sql types bind count = do - start <- pgPreparedBind c sql types bind +pgPreparedLazyQuery c sql types bind bc count = do + start <- pgPreparedBind c sql types bind bc unsafeInterleaveIO $ do execute start @@ -510,9 +526,9 @@ pgPreparedLazyQuery c sql types bind count = do pgSend c $ Flush pgFlush c go = pgHandle c . row - row s (DataRow fs) = go (s Seq.|> fs) - row s PortalSuspended = (toList s ++) <$> unsafeInterleaveIO (execute >> go Seq.empty) - row s (CommandComplete _) = return $ toList s + 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 _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m -- |Close a previously prepared query (if necessary). @@ -520,7 +536,7 @@ 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) - forM_ mn $ \n -> do + Fold.forM_ mn $ \n -> do pgSend c $ Close{ statementName = show n } pgFlush c CloseComplete <- pgReceive c diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index a01c106..9af022e 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -54,9 +54,9 @@ instance PGQuery SimpleQuery PGValues where instance PGRawQuery SimpleQuery where -data PreparedQuery = PreparedQuery String [OID] PGValues +data PreparedQuery = PreparedQuery String [OID] PGValues [Bool] instance PGQuery PreparedQuery PGValues where - pgRunQuery c (PreparedQuery sql types bind) = pgPreparedQuery c sql types bind + pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc instance PGRawQuery PreparedQuery where @@ -81,39 +81,31 @@ 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 = rawParser . PreparedQuery sql [] +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 (PreparedQuery sql types bind) p) count = - fmap p <$> pgPreparedLazyQuery c sql types bind count +pgLazyQuery c (QueryParser (PreparedQuery sql types bind bc) p) count = + fmap p <$> pgPreparedLazyQuery c sql types bind bc count -- |Given a result description, create a function to convert a result to a -- tuple. -convertRow :: [(String, PGTypeInfo, Bool)] -- ^ result description - -> TH.ExpQ -- ^ A function for converting a row of the given result description -convertRow types = do - (pats, conv) <- mapAndUnzipM (\t@(n, _, _) -> do - v <- TH.newName n - return (TH.VarP v, convertColumn (TH.VarE v) t)) types - return $ TH.LamE [TH.ListP pats] $ TH.TupE conv - --- |Given a raw PostgreSQL result and a result field type, convert the --- field to a Haskell value. -- If the boolean -- argument is 'False', that means that we know that the value is not nullable -- and we can use 'fromJust' to keep the code simple. If it's 'True', then we -- don't know if the value is nullable and must return a 'Maybe' value in case -- it is. -convertColumn :: TH.Exp -- ^ the name of the variable containing the column value (of 'Maybe' 'ByteString') - -> (String, PGTypeInfo, Bool) -- ^ the result field type - -> TH.Exp --- convertColumn v (n, t, False) = [| $(return $ pgTypeDecoder t) (fromMaybe (error $(TH.litE $ TH.stringL $ "Unexpected NULL value in " ++ n)) $(v)) |] --- convertColumn v (_, t, True) = [| fmap $(return $ pgTypeDecoder t) $(v) |] -convertColumn v (_, t, nullable) = (if nullable then pgTypeDecoder else pgTypeDecoderNotNull) t `TH.AppE` v +convertRow :: [(String, PGTypeInfo, Bool)] -- ^ result description + -> TH.ExpQ -- ^ A function for converting a row of the given result description +convertRow types = do + (pats, conv) <- mapAndUnzipM (\(c, t, n) -> do + v <- TH.newName c + b <- pgColumnIsBinary t + return (TH.VarP v, pgTypeDecoder n b t `TH.AppE` TH.VarE v)) types + return $ TH.LamE [TH.ListP pats] $ TH.TupE conv -- |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 @$${@. @@ -180,19 +172,20 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" (vars, vals) <- mapAndUnzipM (\t -> do + b <- pgParameterIsBinary t v <- TH.newName "p" - return (TH.VarP v, encf t `TH.AppE` TH.VarE v)) pt + return (TH.VarP v, pgTypeEncoder (isNothing prep) b t `TH.AppE` TH.VarE v)) pt conv <- convertRow rt + bc <- mapM (\(_, t, _) -> pgColumnIsBinary 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 . pgTypeOID) pt) `TH.AppE` TH.ListE vals + | otherwise = TH.ConE 'PreparedQuery `TH.AppE` stringL sqlp `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . pgTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE (map boolL bc) foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` conv) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e - encf - | isNothing prep = pgTypeEscaper - | otherwise = pgTypeEncoder + 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 diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 7a43fe1..c15ad00 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -13,10 +13,10 @@ module Database.PostgreSQL.Typed.TH , PGTypeInfo(..) , getPGTypeInfo , tpgDescribe - , pgTypeDecoder - , pgTypeDecoderNotNull + , pgParameterIsBinary + , pgColumnIsBinary , pgTypeEncoder - , pgTypeEscaper + , pgTypeDecoder ) where import Control.Applicative ((<$>), (<$), (<|>)) @@ -66,7 +66,7 @@ setTPGConnection = void . swapMVar tpgConnection -- 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 will also clear all types registered with 'registerTPGType'. -useTPGDatabase :: PGDatabase -> TH.Q [TH.Dec] +useTPGDatabase :: PGDatabase -> TH.DecsQ useTPGDatabase db = [] <$ TH.runIO (setTPGConnection $ Left $ pgConnect db) data PGTypeInfo = PGTypeInfo @@ -83,9 +83,10 @@ getPGTypeInfo c t = do (\n -> "typname = " ++ pgQuote n ++ " OR format_type(oid, -1) = " ++ pgQuote n) t case toList r of - [[Just o, Just n]] -> return $ PGTypeInfo (pgDecode pgOIDType o) (pgDecode pgNameType n) + [[PGTextValue o, PGTextValue n]] -> return $ PGTypeInfo (pgDecode pgOIDType o) (pgDecode pgNameType n) _ -> fail $ "Unknown PostgreSQL type: " ++ either show id t + -- |A type-aware wrapper to 'pgDescribe' tpgDescribe :: PGConnection -> String -> [String] -> Bool -> IO ([PGTypeInfo], [(String, PGTypeInfo, Bool)]) tpgDescribe conn sql types nulls = do @@ -97,25 +98,34 @@ tpgDescribe conn sql types nulls = do return (c, th, n)) rt return (pth, rth) +pgTypeInstanceExists :: TH.Name -> String -> TH.Q Bool +pgTypeInstanceExists cls t = do + TH.ClassI _ il <- TH.reify cls + return $ any match il + where + match (TH.InstanceD _ (TH.AppT (TH.AppT (TH.ConT ci) (TH.LitT (TH.StrTyLit ti))) _) _) = ci == cls && ti == t + match _ = False + +pgParameterIsBinary :: PGTypeInfo -> TH.Q Bool +pgParameterIsBinary = pgTypeInstanceExists ''PGBinaryParameter . pgTypeName + +pgColumnIsBinary :: PGTypeInfo -> TH.Q Bool +pgColumnIsBinary = pgTypeInstanceExists ''PGBinaryColumn . pgTypeName typeApply :: TH.Name -> PGTypeInfo -> TH.Exp typeApply f PGTypeInfo{ pgTypeName = n } = TH.AppE (TH.VarE f) $ TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit n)) --- |TH expression to decode a 'Maybe' 'L.ByteString' to a 'Maybe' 'PGColumn' value. -pgTypeDecoder :: PGTypeInfo -> TH.Exp -pgTypeDecoder = typeApply 'pgDecodeColumn - --- |TH expression to decode a 'Maybe' 'L.ByteString' to a 'PGColumn' value. -pgTypeDecoderNotNull :: PGTypeInfo -> TH.Exp -pgTypeDecoderNotNull = typeApply 'pgDecodeColumnNotNull - -- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. -pgTypeEncoder :: PGTypeInfo -> TH.Exp -pgTypeEncoder = typeApply 'pgEncodeParameter - --- |TH expression to escape a 'PGParameter' value to a SQL literal. -pgTypeEscaper :: PGTypeInfo -> TH.Exp -pgTypeEscaper = typeApply 'pgEscapeParameter - +pgTypeEncoder :: Bool -> Bool -> PGTypeInfo -> TH.Exp +pgTypeEncoder False False = typeApply 'pgEncodeParameter +pgTypeEncoder False True = typeApply 'pgEncodeBinaryParameter +pgTypeEncoder True _ = typeApply 'pgEscapeParameter + +-- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. +pgTypeDecoder :: Bool -> Bool -> PGTypeInfo -> TH.Exp +pgTypeDecoder True False = typeApply 'pgDecodeColumn +pgTypeDecoder True True = typeApply 'pgDecodeBinaryColumn +pgTypeDecoder False False = typeApply 'pgDecodeColumnNotNull +pgTypeDecoder False True = typeApply 'pgDecodeBinaryColumnNotNull diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 748f740..87f9bbc 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -10,21 +10,26 @@ module Database.PostgreSQL.Typed.Types ( -- * Basic types OID - , PGValue + , PGValue(..) , PGValues , pgQuote , PGTypeName(..) -- * Marshalling classes , PGParameter(..) + , PGBinaryParameter , PGColumn(..) + , PGBinaryColumn , PGStringType -- * Marshalling utilities , pgEncodeParameter + , pgEncodeBinaryParameter , pgEscapeParameter , pgDecodeColumn , pgDecodeColumnNotNull + , pgDecodeBinaryColumn + , pgDecodeBinaryColumnNotNull -- * Specific type support , pgBoolType @@ -38,6 +43,7 @@ import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero) import Data.Bits (shiftL, shiftR, (.|.), (.&.)) import Data.ByteString.Internal (w2c) +import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Prim as BP import Data.ByteString.Internal (c2w) @@ -66,9 +72,15 @@ import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) import qualified Database.PostgreSQL.Typed.Range as Range -type PGValue = L.ByteString +type PGTextValue = L.ByteString +type PGBinaryValue = BS.ByteString +data PGValue + = PGNullValue + | PGTextValue PGTextValue + | PGBinaryValue PGBinaryValue + deriving (Show, Eq) -- |A list of (nullable) data values, e.g. a single row or query parameters. -type PGValues = [Maybe PGValue] +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 @@ -79,51 +91,77 @@ pgTypeName = symbolVal -- |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 -> PGValue + 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 . U.toString . pgEncode t +class PGParameter t a => PGBinaryParameter t a where + pgEncodeBinary :: 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 -> PGValue -> a + pgDecode :: PGTypeName t -> PGTextValue -> a +class PGColumn t a => PGBinaryColumn t a where + pgDecodeBinary :: PGTypeName t -> PGBinaryValue -> a -- |Support encoding of 'Maybe' values into NULL. class PGParameterNull t a where - pgEncodeNull :: PGTypeName t -> a -> Maybe PGValue + pgEncodeNull :: PGTypeName t -> a -> PGValue pgLiteralNull :: PGTypeName t -> a -> String +class PGParameterNull t a => PGBinaryParameterNull t a where + pgEncodeBinaryNull :: 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 -> Maybe PGValue -> a + pgDecodeNotNull :: PGTypeName t -> PGValue -> a instance PGParameter t a => PGParameterNull t a where - pgEncodeNull t = Just . pgEncode t + pgEncodeNull t = PGTextValue . pgEncode t pgLiteralNull = pgLiteral instance PGParameter t a => PGParameterNull t (Maybe a) where - pgEncodeNull = fmap . pgEncode + pgEncodeNull t = maybe PGNullValue (PGTextValue . pgEncode t) pgLiteralNull = maybe "NULL" . pgLiteral +instance PGBinaryParameter t a => PGBinaryParameterNull t a where + pgEncodeBinaryNull t = PGBinaryValue . pgEncodeBinary t +instance PGBinaryParameter t a => PGBinaryParameterNull t (Maybe a) where + pgEncodeBinaryNull t = maybe PGNullValue (PGBinaryValue . pgEncodeBinary t) instance PGColumn t a => PGColumnNotNull t a where - pgDecodeNotNull t = maybe (error $ "Unexpected NULL in " ++ pgTypeName t ++ " column") (pgDecode t) + 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 = fmap . pgDecode + pgDecodeNotNull _ PGNullValue = Nothing + pgDecodeNotNull t (PGTextValue v) = Just $ pgDecode t v + pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t -pgEncodeParameter :: PGParameterNull t a => PGTypeName t -> a -> Maybe PGValue + +pgEncodeParameter :: PGParameterNull t a => PGTypeName t -> a -> PGValue pgEncodeParameter = pgEncodeNull +pgEncodeBinaryParameter :: PGBinaryParameterNull t a => PGTypeName t -> a -> PGValue +pgEncodeBinaryParameter = pgEncodeBinaryNull + pgEscapeParameter :: PGParameterNull t a => PGTypeName t -> a -> String pgEscapeParameter = pgLiteralNull -pgDecodeColumn :: PGColumn t a => PGTypeName t -> Maybe PGValue -> Maybe a -pgDecodeColumn = fmap . pgDecode +pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeName t -> PGValue -> Maybe a +pgDecodeColumn = pgDecodeNotNull -pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeName t -> Maybe PGValue -> a +pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeName t -> PGValue -> a pgDecodeColumnNotNull = pgDecodeNotNull +pgDecodeBinaryColumn :: PGBinaryColumn t a => PGTypeName t -> PGValue -> Maybe a +pgDecodeBinaryColumn t (PGBinaryValue v) = Just $ pgDecodeBinary t v +pgDecodeBinaryColumn t v = pgDecodeColumn t v + +pgDecodeBinaryColumnNotNull :: (PGColumnNotNull t a, PGBinaryColumn t a) => PGTypeName t -> PGValue -> a +pgDecodeBinaryColumnNotNull t (PGBinaryValue v) = pgDecodeBinary t v +pgDecodeBinaryColumnNotNull t v = pgDecodeNotNull t v + pgQuoteUnsafe :: String -> String pgQuoteUnsafe s = '\'' : s ++ "'" From 714ba434ab2d7ad864e75c98fb5749fbf06d8407 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 02:01:28 -0500 Subject: [PATCH 081/306] Start adding binary instances Encoding only, only some active --- Database/PostgreSQL/Typed/Protocol.hs | 4 +- Database/PostgreSQL/Typed/Types.hs | 91 +++++++++++++++++++++++++-- postgresql-typed.cabal | 36 ++++++----- test/Main.hs | 12 ++-- 4 files changed, 117 insertions(+), 26 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 6efdb49..12ad302 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -213,10 +213,10 @@ messageBody (CancelRequest pid key) = (Nothing, B.word32BE 80877102 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.word16LE . fromIntegral . fromEnum . 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 - <> B.word16BE (fromIntegral $ length bc) <> Fold.foldMap (B.word16LE . fromIntegral . fromEnum) bc) + <> B.word16BE (fromIntegral $ length bc) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum) bc) where fmt (PGBinaryValue _) = True fmt _ = False diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 87f9bbc..6912887 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -59,6 +59,12 @@ import Data.Ratio ((%), numerator, denominator) #ifdef USE_SCIENTIFIC import Data.Scientific (Scientific) #endif +#ifdef USE_TEXT +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextE +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextLE +#endif import qualified Data.Time as Time #ifdef USE_UUID import qualified Data.UUID as UUID @@ -66,6 +72,10 @@ import qualified Data.UUID as UUID import Data.Word (Word32) import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) import Numeric (readFloat) +#ifdef USE_BINARY +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(..)) @@ -239,6 +249,23 @@ instance PGStringType t => PGParameter t L.ByteString where instance PGStringType t => PGColumn t L.ByteString where pgDecode _ = id +instance PGStringType t => PGParameter t BS.ByteString where + pgEncode _ = L.fromStrict +instance PGStringType t => PGColumn t BS.ByteString where + pgDecode _ = L.toStrict + +#ifdef USE_TEXT +instance PGStringType t => PGParameter t TextL.Text where + pgEncode _ = TextLE.encodeUtf8 +instance PGStringType t => PGColumn t TextL.Text where + pgDecode _ = TextLE.decodeUtf8 + +instance PGStringType t => PGParameter t Text.Text where + pgEncode _ = L.fromStrict . TextE.encodeUtf8 +instance PGStringType t => PGColumn t Text.Text where + pgDecode _ = TextL.toStrict . TextLE.decodeUtf8 +#endif + instance PGStringType "text" instance PGStringType "varchar" instance PGStringType "name" -- limit 63 characters @@ -249,10 +276,10 @@ instance PGStringType "bpchar" -- blank padded type Bytea = L.ByteString instance PGParameter "bytea" Bytea where - pgEncode _ = LC.pack . (++) "'\\x" . ed . L.unpack where - ed [] = "\'" - ed (x:d) = hex (shiftR x 4) : hex (x .&. 0xF) : ed d - hex = intToDigit . fromIntegral + pgEncode _ s = B.toLazyByteString $ B.string7 "\\x" <> B.lazyByteStringHex s + pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGParameter "bytea" BS.ByteString where + pgEncode _ s = B.toLazyByteString $ B.string7 "\\x" <> B.byteStringHex s pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t instance PGColumn "bytea" Bytea where pgDecode _ s @@ -513,6 +540,62 @@ instance PGColumn "uuid" UUID.UUID where pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ LC.unpack u) $ UUID.fromLazyASCIIBytes 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 PGBinaryParameter "oid" OID where + pgEncodeBinary _ = BinE.int4 . Right +instance PGBinaryParameter "int2" Int16 where + pgEncodeBinary _ = BinE.int2 . Left +instance PGBinaryParameter "int4" Int32 where + pgEncodeBinary _ = BinE.int4 . Left +instance PGBinaryParameter "int8" Int64 where + pgEncodeBinary _ = BinE.int8 . Left +instance PGBinaryParameter "float4" Float where + pgEncodeBinary _ = BinE.float4 +instance PGBinaryParameter "float8" Double where + pgEncodeBinary _ = BinE.float8 +#ifdef USE_SCIENTIFIC +instance PGBinaryParameter "numeric" Scientific where + pgEncodeBinary _ = BinE.numeric +instance PGBinaryParameter "numeric" Rational where + pgEncodeBinary _ = BinE.numeric . realToFrac +#endif +instance PGBinaryParameter "char" Char where + pgEncodeBinary _ = BinE.char +-- These aren't working because of how isBinaryParameter works: +instance PGStringType t => PGBinaryParameter t Text.Text where + pgEncodeBinary _ = BinE.text . Left +instance PGStringType t => PGBinaryParameter t TextL.Text where + pgEncodeBinary _ = BinE.text . Right +instance PGStringType t => PGBinaryParameter t BS.ByteString where + pgEncodeBinary _ = BinE.text . Left . TextE.decodeUtf8 +instance PGStringType t => PGBinaryParameter t L.ByteString where + pgEncodeBinary _ = BinE.text . Right . TextLE.decodeUtf8 +instance PGBinaryParameter "bytea" BS.ByteString where + pgEncodeBinary _ = BinE.bytea . Left +instance PGBinaryParameter "bytea" L.ByteString where + pgEncodeBinary _ = BinE.bytea . Right +instance PGBinaryParameter "date" Time.Day where + pgEncodeBinary _ = BinE.date +{- Need to know PGConnection parameter "integer_datetimes" for these: +instance PGBinaryParameter "time" Time.TimeOfDay where + pgEncodeBinary _ = BinE.time +instance PGBinaryParameter "timestamp" Time.LocalTime where + pgEncodeBinary _ = BinE.timestamp +instance PGBinaryParameter "timestamptz" Time.UTCTime where + pgEncodeBinary _ = BinE.timestamptz +instance PGBinaryParameter "interval" Time.DiffTime where + pgEncodeBinary _ = BinE.interval +-} +instance PGBinaryParameter "bool" Bool where + pgEncodeBinary _ = BinE.bool +#ifdef USE_UUID +instance PGBinaryParameter "uuid" UUID.UUID where + pgEncodeBinary _ = BinE.uuid +#endif +#endif {- --, ( 114, 199, "json", ?) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 1de0111..da8fa94 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -27,16 +27,20 @@ Flag md5 Description: Enable md5 password authentication method Default: True -Flag uuid - Description: Support the UUID type via uuid +Flag binary + Description: Use binary protocol encoding via postgresql-binary Default: True -Flag scientific - Description: Support decoding numeric via scientific +Flag text + Description: Support Text string values via text (implied by binary) Default: True -Flag binary - Description: Use binary protocol encoding via postgresql-binary +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 @@ -62,15 +66,19 @@ Library if flag(md5) Build-Depends: cryptohash >= 0.5 CPP-options: -DUSE_MD5 - if flag(uuid) - Build-Depends: uuid >= 1.3 - CPP-options: -DUSE_UUID - if flag(scientific) - Build-Depends: scientific >= 0.3 - CPP-options: -DUSE_SCIENTIFIC if flag(binary) - Build-Depends: postgresql-binary >= 0.5.0 - CPP-options: -DUSE_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 diff --git a/test/Main.hs b/test/Main.hs index 1f89716..5caacd2 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -19,11 +19,11 @@ assert True = return () useTPGDatabase db simple :: PGConnection -> OID -> IO [String] -simple c t = pgQuery c [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] +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 -> IO [Maybe String] -prepared c t = pgQuery c [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] +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|] @@ -46,9 +46,9 @@ main = do ["box"] <- simple c 603 [Just "box"] <- simpleApply c 603 - [Just "box"] <- prepared c 603 + [Just "box"] <- prepared c 603 "box" ["box"] <- preparedApply c 603 - [Just "line"] <- prepared c 628 + [Just "line"] <- prepared c 628 "line" ["line"] <- preparedApply c 628 pgDisconnect c From 7872ff7464495d6b87cd4ac4d7254f4fc70191da Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 12:12:22 -0500 Subject: [PATCH 082/306] Complete binary support for basic types No datetimes or array, yet --- Database/PostgreSQL/Typed.hs | 28 +++-- Database/PostgreSQL/Typed/Protocol.hs | 4 +- Database/PostgreSQL/Typed/Query.hs | 26 ++--- Database/PostgreSQL/Typed/TH.hs | 18 +--- Database/PostgreSQL/Typed/Types.hs | 145 ++++++++++++++++++++------ postgresql-typed.cabal | 10 +- 6 files changed, 151 insertions(+), 80 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index abe9321..102567c 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -89,7 +89,7 @@ import Database.PostgreSQL.Typed.Query -- $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, TemplatePG needs to make its own connection to the database in order to describe queries. +-- 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) @@ -156,11 +156,15 @@ import Database.PostgreSQL.Typed.Query -- -- > 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): @@ -171,30 +175,32 @@ import Database.PostgreSQL.Typed.Query -- > pgDecode _ (s :: ByteString) = ... :: MyType -- > instance PGArrayType "_mytype" "mytype" -- --- You must enable the DataKinds language extension. +-- Required language extensions: FlexibleInstances, MultiParamTypeClasses, DataKinds -- $nulls --- Sometimes TemplatePG cannot determine whether or not a result field can +-- 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'. --- --- Because TemplatePG has to prepare statements at compile time and --- placeholders can't be used in place of lists in PostgreSQL (such as @IN --- (?)@), you must replace such cases with equivalent arrays (@= ANY (?)@). -- $caveats --- I've included 'withTransaction', 'rollback', and 'insertIgnore', but they've --- not been thoroughly tested, so use them at your own risk. --- -- 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 that call 'makePGQuery'). +-- 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. +-- +-- * The value of @integer_datetimes@ is determined at compile time. If you need to run against a server with a different value of this parameter (unlikely), you must disable the package @binary@ (or not use any date/time values). -- $tips -- If you find yourself pattern matching on result tuples just to pass them on diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 12ad302..e4b36cd 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -88,6 +88,7 @@ data ColDescription = ColDescription , colTable :: !OID , colNumber :: !Int , colType :: !OID + , colModifier :: !Word32 , colBinary :: !Bool } deriving (Show) @@ -280,13 +281,14 @@ getMessageBody 'T' = do col <- G.getWord16be -- column number typ' <- G.getWord32be -- type _ <- G.getWord16be -- type size - _ <- G.getWord32be -- type modifier + 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 diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 9af022e..9aa332b 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -91,22 +91,6 @@ pgLazyQuery :: PGConnection -> PGPreparedQuery a -> Word32 -- ^ Chunk size (1 is pgLazyQuery c (QueryParser (PreparedQuery sql types bind bc) p) count = fmap p <$> pgPreparedLazyQuery c sql types bind bc count --- |Given a result description, create a function to convert a result to a --- tuple. --- If the boolean --- argument is 'False', that means that we know that the value is not nullable --- and we can use 'fromJust' to keep the code simple. If it's 'True', then we --- don't know if the value is nullable and must return a 'Maybe' value in case --- it is. -convertRow :: [(String, PGTypeInfo, Bool)] -- ^ result description - -> TH.ExpQ -- ^ A function for converting a row of the given result description -convertRow types = do - (pats, conv) <- mapAndUnzipM (\(c, t, n) -> do - v <- TH.newName c - b <- pgColumnIsBinary t - return (TH.VarP v, pgTypeDecoder n b t `TH.AppE` TH.VarE v)) types - return $ TH.LamE [TH.ListP pats] $ TH.TupE conv - -- |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 @}@. @@ -172,15 +156,17 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" (vars, vals) <- mapAndUnzipM (\t -> do - b <- pgParameterIsBinary t + b <- pgTypeIsBinary t v <- TH.newName "p" return (TH.VarP v, pgTypeEncoder (isNothing prep) b t `TH.AppE` TH.VarE v)) pt - conv <- convertRow rt - bc <- mapM (\(_, t, _) -> pgColumnIsBinary t) rt + (pats, conv, bc) <- unzip3 <$> mapM (\(c, t, n) -> do + v <- TH.newName c + b <- pgTypeIsBinary t + return (TH.VarP v, pgTypeDecoder n b t `TH.AppE` TH.VarE v, b)) 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 . pgTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE (map boolL bc) - foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` conv) <$> mapM parse exprs + foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` TH.LamE [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 diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index c15ad00..1c7dbb3 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -13,8 +13,7 @@ module Database.PostgreSQL.Typed.TH , PGTypeInfo(..) , getPGTypeInfo , tpgDescribe - , pgParameterIsBinary - , pgColumnIsBinary + , pgTypeIsBinary , pgTypeEncoder , pgTypeDecoder ) where @@ -98,19 +97,10 @@ tpgDescribe conn sql types nulls = do return (c, th, n)) rt return (pth, rth) -pgTypeInstanceExists :: TH.Name -> String -> TH.Q Bool -pgTypeInstanceExists cls t = do - TH.ClassI _ il <- TH.reify cls - return $ any match il - where - match (TH.InstanceD _ (TH.AppT (TH.AppT (TH.ConT ci) (TH.LitT (TH.StrTyLit ti))) _) _) = ci == cls && ti == t - match _ = False +pgTypeIsBinary :: PGTypeInfo -> TH.Q Bool +pgTypeIsBinary PGTypeInfo{ pgTypeName = t } = + TH.isInstance ''PGBinaryType [TH.LitT (TH.StrTyLit t)] -pgParameterIsBinary :: PGTypeInfo -> TH.Q Bool -pgParameterIsBinary = pgTypeInstanceExists ''PGBinaryParameter . pgTypeName - -pgColumnIsBinary :: PGTypeInfo -> TH.Q Bool -pgColumnIsBinary = pgTypeInstanceExists ''PGBinaryColumn . pgTypeName typeApply :: TH.Name -> PGTypeInfo -> TH.Exp typeApply f PGTypeInfo{ pgTypeName = n } = TH.AppE (TH.VarE f) $ diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 6912887..3c32d05 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -19,8 +19,7 @@ module Database.PostgreSQL.Typed.Types , PGParameter(..) , PGBinaryParameter , PGColumn(..) - , PGBinaryColumn - , PGStringType + , PGBinaryType -- * Marshalling utilities , pgEncodeParameter @@ -41,7 +40,7 @@ module Database.PostgreSQL.Typed.Types import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero) -import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +import Data.Bits (shiftL, (.|.)) import Data.ByteString.Internal (w2c) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B @@ -69,10 +68,11 @@ import qualified Data.Time as Time #ifdef USE_UUID import qualified Data.UUID as UUID #endif -import Data.Word (Word32) +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 @@ -95,6 +95,8 @@ 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 @@ -106,14 +108,14 @@ class KnownSymbol t => PGParameter (t :: Symbol) a where -- Defaults to a quoted version of 'pgEncode' pgLiteral :: PGTypeName t -> a -> String pgLiteral t = pgQuote . U.toString . pgEncode t -class PGParameter t a => PGBinaryParameter t a where +class (PGParameter t a, PGBinaryType t) => PGBinaryParameter t a where pgEncodeBinary :: 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 => PGBinaryColumn t a where +class (PGColumn t a, PGBinaryType t) => PGBinaryColumn t a where pgDecodeBinary :: PGTypeName t -> PGBinaryValue -> a -- |Support encoding of 'Maybe' values into NULL. @@ -274,23 +276,30 @@ pgNameType = PGTypeProxy instance PGStringType "bpchar" -- blank padded -type Bytea = L.ByteString -instance PGParameter "bytea" Bytea where - pgEncode _ s = B.toLazyByteString $ B.string7 "\\x" <> B.lazyByteStringHex s +encodeBytea :: B.Builder -> PGTextValue +encodeBytea h = B.toLazyByteString $ B.string7 "\\x" <> h + +decodeBytea :: PGTextValue -> [Word8] +decodeBytea s + | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm + | otherwise = pd $ L.unpack d where + (m, d) = L.splitAt 2 s + sm = LC.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" L.ByteString where + pgEncode _ = encodeBytea . B.lazyByteStringHex pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t +instance PGColumn "bytea" L.ByteString where + pgDecode _ = L.pack . decodeBytea instance PGParameter "bytea" BS.ByteString where - pgEncode _ s = B.toLazyByteString $ B.string7 "\\x" <> B.byteStringHex s + pgEncode _ = encodeBytea . B.byteStringHex pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t -instance PGColumn "bytea" Bytea where - pgDecode _ s - | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm - | otherwise = L.pack $ pd $ L.unpack d where - (m, d) = L.splitAt 2 s - sm = LC.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 PGColumn "bytea" BS.ByteString where + pgDecode _ = BS.pack . decodeBytea instance PGParameter "date" Time.Day where pgEncode _ = LC.pack . Time.showGregorian @@ -399,6 +408,7 @@ 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 @@ -544,57 +554,134 @@ instance PGColumn "uuid" UUID.UUID where 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 "int2" instance PGBinaryParameter "int2" Int16 where pgEncodeBinary _ = BinE.int2 . Left +instance PGBinaryColumn "int2" Int16 where + pgDecodeBinary = binDec BinD.int + +instance PGBinaryType "int4" instance PGBinaryParameter "int4" Int32 where pgEncodeBinary _ = BinE.int4 . Left +instance PGBinaryColumn "int4" Int32 where + pgDecodeBinary = binDec BinD.int + +instance PGBinaryType "int8" instance PGBinaryParameter "int8" Int64 where pgEncodeBinary _ = BinE.int8 . Left +instance PGBinaryColumn "int8" Int64 where + pgDecodeBinary = binDec BinD.int + +instance PGBinaryType "float4" instance PGBinaryParameter "float4" Float where pgEncodeBinary _ = BinE.float4 +instance PGBinaryColumn "float4" Float where + pgDecodeBinary = binDec BinD.float4 + +instance PGBinaryType "float8" instance PGBinaryParameter "float8" Double where pgEncodeBinary _ = BinE.float8 -#ifdef USE_SCIENTIFIC +instance PGBinaryColumn "float8" 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 -#endif +instance PGBinaryColumn "numeric" Rational where + pgDecodeBinary t = realToFrac . binDec BinD.numeric t + +instance PGBinaryType "char" instance PGBinaryParameter "char" Char where pgEncodeBinary _ = BinE.char --- These aren't working because of how isBinaryParameter works: -instance PGStringType t => PGBinaryParameter t Text.Text where +instance PGBinaryColumn "char" Char where + pgDecodeBinary = binDec BinD.char + +instance PGBinaryType "text" +instance PGBinaryType "varchar" +instance PGBinaryType "bpchar" +instance PGBinaryType "name" -- not strictly textsend, but essentially the same +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t Text.Text where pgEncodeBinary _ = BinE.text . Left -instance PGStringType t => PGBinaryParameter t TextL.Text where +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t Text.Text where + pgDecodeBinary = binDec BinD.text +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t TextL.Text where pgEncodeBinary _ = BinE.text . Right -instance PGStringType t => PGBinaryParameter t BS.ByteString where +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t TextL.Text where + pgDecodeBinary t = TextL.fromStrict . binDec BinD.text t +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t BS.ByteString where pgEncodeBinary _ = BinE.text . Left . TextE.decodeUtf8 -instance PGStringType t => PGBinaryParameter t L.ByteString where +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BS.ByteString where + pgDecodeBinary t = TextE.encodeUtf8 . binDec BinD.text t +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t L.ByteString where pgEncodeBinary _ = BinE.text . Right . TextLE.decodeUtf8 +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t L.ByteString where + pgDecodeBinary t = L.fromStrict . TextE.encodeUtf8 . binDec BinD.text t +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t String where + pgEncodeBinary _ = BinE.text . Left . Text.pack +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t String where + pgDecodeBinary t = Text.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" L.ByteString where pgEncodeBinary _ = BinE.bytea . Right +instance PGBinaryColumn "bytea" L.ByteString where + pgDecodeBinary t = L.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 {- Need to know PGConnection parameter "integer_datetimes" for these: +instance PGBinaryType "time" instance PGBinaryParameter "time" Time.TimeOfDay where pgEncodeBinary _ = BinE.time +instance PGBinaryColumn "time" Time.TimeOfDay where + pgDecodeBinary = binDec BinD.time +instance PGBinaryType "timestamp" instance PGBinaryParameter "timestamp" Time.LocalTime where pgEncodeBinary _ = BinE.timestamp +instance PGBinaryColumn "timestamp" Time.LocalTime where + pgDecodeBinary = binDec BinD.timestamp +instance PGBinaryType "timestamptz" instance PGBinaryParameter "timestamptz" Time.UTCTime where pgEncodeBinary _ = BinE.timestamptz +instance PGBinaryColumn "timestamptz" Time.UTCTime where + pgDecodeBinary = binDec BinD.timestamptz +instance PGBinaryType "interval" instance PGBinaryParameter "interval" Time.DiffTime where pgEncodeBinary _ = BinE.interval +instance PGBinaryColumn "interval" Time.DiffTime where + pgDecodeBinary = binDec BinD.interval -} + +instance PGBinaryType "bool" instance PGBinaryParameter "bool" Bool where pgEncodeBinary _ = BinE.bool -#ifdef USE_UUID +instance PGBinaryColumn "bool" Bool where + pgDecodeBinary = binDec BinD.bool + +instance PGBinaryType "uuid" instance PGBinaryParameter "uuid" UUID.UUID where pgEncodeBinary _ = BinE.uuid -#endif +instance PGBinaryColumn "uuid" UUID.UUID where + pgDecodeBinary = binDec BinD.uuid + +-- TODO: arrays #endif {- diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index da8fa94..174ac94 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -24,23 +24,23 @@ source-repository head location: git://github.com/dylex/postgresql-typed Flag md5 - Description: Enable md5 password authentication method + Description: Enable md5 password authentication method. Default: True Flag binary - Description: Use binary protocol encoding via postgresql-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) + Description: Support Text string values via text (implied by binary). Default: True Flag uuid - Description: Support the UUID type via uuid (implied by binary) + Description: Support the UUID type via uuid (implied by binary). Default: True Flag scientific - Description: Support decoding numeric via scientific (implied by binary) + Description: Support decoding numeric via scientific (implied by binary). Default: True Library From f609e963166e64b0e92db5b1ac3f8d174a7e18fe Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 14:03:54 -0500 Subject: [PATCH 083/306] Add support for datetime binary types through PGTypeEnv --- Database/PostgreSQL/Typed.hs | 2 - Database/PostgreSQL/Typed/Protocol.hs | 30 +++++- Database/PostgreSQL/Typed/Query.hs | 24 +++-- Database/PostgreSQL/Typed/TH.hs | 12 ++- Database/PostgreSQL/Typed/Types.hs | 138 +++++++++++++------------- test/Main.hs | 6 +- 6 files changed, 122 insertions(+), 90 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index 102567c..d5b55fd 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -199,8 +199,6 @@ import Database.PostgreSQL.Typed.Query -- 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. --- --- * The value of @integer_datetimes@ is determined at compile time. If you need to run against a server with a different value of this parameter (unlikely), you must disable the package @binary@ (or not use any date/time values). -- $tips -- If you find yourself pattern matching on result tuples just to pass them on diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index e4b36cd..bccdb15 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -11,8 +11,10 @@ module Database.PostgreSQL.Typed.Protocol ( , PGConnection , PGError(..) , pgMessageCode + , pgTypeEnv , pgConnect , pgDisconnect + , pgReconnect , pgDescribe , pgSimpleQuery , pgPreparedQuery @@ -68,8 +70,8 @@ data PGDatabase = PGDatabase } instance Eq PGDatabase where - PGDatabase h1 s1 n1 u1 p1 d1 _ == PGDatabase h2 s2 n2 u2 p2 d2 _ = - h1 == h2 && s1 == s2 && n1 == n2 && u1 == u2 && p1 == p2 && d1 == d2 + 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. @@ -79,6 +81,7 @@ data PGConnection = PGConnection , connPid :: !Word32 -- unused , connKey :: !Word32 -- unused , connParameters :: Map.Map String String + , connTypeEnv :: PGTypeEnv , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) , connState :: IORef PGState } @@ -191,6 +194,9 @@ connDebug = pgDBDebug . connDatabase connLogMessage :: PGConnection -> MessageFields -> IO () connLogMessage = pgDBLogMessage . connDatabase +pgTypeEnv :: PGConnection -> PGTypeEnv +pgTypeEnv = connTypeEnv + #ifdef USE_MD5 md5 :: L.ByteString -> L.ByteString md5 = L.fromStrict . Hash.digestToHexByteString . (Hash.hashlazy :: L.ByteString -> Hash.Digest Hash.MD5) @@ -217,7 +223,9 @@ messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = 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 - <> B.word16BE (fromIntegral $ length bc) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum) bc) + <> (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 @@ -350,6 +358,7 @@ pgConnect db = do , connParameters = Map.empty , connPreparedStatements = prep , connState = state + , connTypeEnv = undefined } pgSend c $ StartupMessage [ ("user", pgDBUser db) @@ -365,6 +374,10 @@ pgConnect db = do where conn c = pgHandle 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 @@ -388,6 +401,17 @@ pgDisconnect c@PGConnection{ connHandle = h, connState = s } = do 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 diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 9aa332b..a354ee9 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -60,15 +60,15 @@ instance PGQuery PreparedQuery PGValues where instance PGRawQuery PreparedQuery where -data QueryParser q a = QueryParser q (PGValues -> a) +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) <$> pgRunQuery c q + 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 (f . p) + fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) rawParser :: q -> QueryParser q PGValues -rawParser q = QueryParser q id +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 @@ -88,8 +88,10 @@ rawPGPreparedQuery sql bind = rawParser $ PreparedQuery sql [] bind [] -- 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 (PreparedQuery sql types bind bc) p) count = - fmap p <$> pgPreparedLazyQuery c sql types bind bc count +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 @$${@. @@ -155,18 +157,22 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do tpgDescribe c 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 b <- pgTypeIsBinary t v <- TH.newName "p" - return (TH.VarP v, pgTypeEncoder (isNothing prep) b t `TH.AppE` TH.VarE v)) pt + return (TH.VarP v, pgTypeEncoder (isNothing prep) b e t v)) pt (pats, conv, bc) <- unzip3 <$> mapM (\(c, t, n) -> do v <- TH.newName c b <- pgTypeIsBinary t - return (TH.VarP v, pgTypeDecoder n b t `TH.AppE` TH.VarE v, b)) rt + return (TH.VarP v, pgTypeDecoder n b e t v, b)) 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 . pgTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE (map boolL bc) - foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser `TH.AppE` pgq `TH.AppE` TH.LamE [TH.ListP pats] (TH.TupE conv)) <$> mapM parse exprs + 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 diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 1c7dbb3..4260363 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -102,19 +102,21 @@ pgTypeIsBinary PGTypeInfo{ pgTypeName = t } = TH.isInstance ''PGBinaryType [TH.LitT (TH.StrTyLit t)] -typeApply :: TH.Name -> PGTypeInfo -> TH.Exp -typeApply f PGTypeInfo{ pgTypeName = n } = TH.AppE (TH.VarE f) $ - TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit n)) +typeApply :: TH.Name -> TH.Name -> PGTypeInfo -> TH.Name -> TH.Exp +typeApply f e PGTypeInfo{ pgTypeName = n } 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 n))) + `TH.AppE` TH.VarE v -- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. -pgTypeEncoder :: Bool -> Bool -> PGTypeInfo -> TH.Exp +pgTypeEncoder :: Bool -> Bool -> TH.Name -> PGTypeInfo -> TH.Name -> TH.Exp pgTypeEncoder False False = typeApply 'pgEncodeParameter pgTypeEncoder False True = typeApply 'pgEncodeBinaryParameter pgTypeEncoder True _ = typeApply 'pgEscapeParameter -- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. -pgTypeDecoder :: Bool -> Bool -> PGTypeInfo -> TH.Exp +pgTypeDecoder :: Bool -> Bool -> TH.Name -> PGTypeInfo -> TH.Name -> TH.Exp pgTypeDecoder True False = typeApply 'pgDecodeColumn pgTypeDecoder True True = typeApply 'pgDecodeBinaryColumn pgTypeDecoder False False = typeApply 'pgDecodeColumnNotNull diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 3c32d05..b9ec394 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -14,6 +14,7 @@ module Database.PostgreSQL.Typed.Types , PGValues , pgQuote , PGTypeName(..) + , PGTypeEnv(..) -- * Marshalling classes , PGParameter(..) @@ -100,6 +101,9 @@ class KnownSymbol t => PGBinaryType t pgTypeName :: KnownSymbol t => PGTypeName (t :: Symbol) -> String pgTypeName = symbolVal +data PGTypeEnv = PGTypeEnv + { pgIntegerDatetimes :: Bool } + -- |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. @@ -109,21 +113,21 @@ class KnownSymbol t => PGParameter (t :: Symbol) a where pgLiteral :: PGTypeName t -> a -> String pgLiteral t = pgQuote . U.toString . pgEncode t class (PGParameter t a, PGBinaryType t) => PGBinaryParameter t a where - pgEncodeBinary :: PGTypeName t -> a -> PGBinaryValue + 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 :: PGTypeName t -> PGBinaryValue -> a + 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 :: PGTypeName t -> a -> PGValue + 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 @@ -137,9 +141,9 @@ 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 t = PGBinaryValue . pgEncodeBinary t + pgEncodeBinaryNull e t = PGBinaryValue . pgEncodeBinary e t instance PGBinaryParameter t a => PGBinaryParameterNull t (Maybe a) where - pgEncodeBinaryNull t = maybe PGNullValue (PGBinaryValue . pgEncodeBinary t) + 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)" @@ -151,28 +155,28 @@ instance PGColumn t a => PGColumnNotNull t (Maybe a) where pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t -pgEncodeParameter :: PGParameterNull t a => PGTypeName t -> a -> PGValue -pgEncodeParameter = pgEncodeNull +pgEncodeParameter :: PGParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> PGValue +pgEncodeParameter _ = pgEncodeNull -pgEncodeBinaryParameter :: PGBinaryParameterNull t a => PGTypeName t -> a -> PGValue +pgEncodeBinaryParameter :: PGBinaryParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> PGValue pgEncodeBinaryParameter = pgEncodeBinaryNull -pgEscapeParameter :: PGParameterNull t a => PGTypeName t -> a -> String -pgEscapeParameter = pgLiteralNull +pgEscapeParameter :: PGParameterNull t a => PGTypeEnv -> PGTypeName t -> a -> String +pgEscapeParameter _ = pgLiteralNull -pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeName t -> PGValue -> Maybe a -pgDecodeColumn = pgDecodeNotNull +pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a +pgDecodeColumn _ = pgDecodeNotNull -pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeName t -> PGValue -> a -pgDecodeColumnNotNull = pgDecodeNotNull +pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGValue -> a +pgDecodeColumnNotNull _ = pgDecodeNotNull -pgDecodeBinaryColumn :: PGBinaryColumn t a => PGTypeName t -> PGValue -> Maybe a -pgDecodeBinaryColumn t (PGBinaryValue v) = Just $ pgDecodeBinary t v -pgDecodeBinaryColumn t v = pgDecodeColumn t v +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 -pgDecodeBinaryColumnNotNull :: (PGColumnNotNull t a, PGBinaryColumn t a) => PGTypeName t -> PGValue -> a -pgDecodeBinaryColumnNotNull t (PGBinaryValue v) = pgDecodeBinary t v -pgDecodeBinaryColumnNotNull t v = pgDecodeNotNull t v +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 @@ -556,130 +560,128 @@ binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ instance PGBinaryType "oid" instance PGBinaryParameter "oid" OID where - pgEncodeBinary _ = BinE.int4 . Right + pgEncodeBinary _ _ = BinE.int4 . Right instance PGBinaryColumn "oid" OID where - pgDecodeBinary = binDec BinD.int + pgDecodeBinary _ = binDec BinD.int instance PGBinaryType "int2" instance PGBinaryParameter "int2" Int16 where - pgEncodeBinary _ = BinE.int2 . Left + pgEncodeBinary _ _ = BinE.int2 . Left instance PGBinaryColumn "int2" Int16 where - pgDecodeBinary = binDec BinD.int + pgDecodeBinary _ = binDec BinD.int instance PGBinaryType "int4" instance PGBinaryParameter "int4" Int32 where - pgEncodeBinary _ = BinE.int4 . Left + pgEncodeBinary _ _ = BinE.int4 . Left instance PGBinaryColumn "int4" Int32 where - pgDecodeBinary = binDec BinD.int + pgDecodeBinary _ = binDec BinD.int instance PGBinaryType "int8" instance PGBinaryParameter "int8" Int64 where - pgEncodeBinary _ = BinE.int8 . Left + pgEncodeBinary _ _ = BinE.int8 . Left instance PGBinaryColumn "int8" Int64 where - pgDecodeBinary = binDec BinD.int + pgDecodeBinary _ = binDec BinD.int instance PGBinaryType "float4" instance PGBinaryParameter "float4" Float where - pgEncodeBinary _ = BinE.float4 + pgEncodeBinary _ _ = BinE.float4 instance PGBinaryColumn "float4" Float where - pgDecodeBinary = binDec BinD.float4 + pgDecodeBinary _ = binDec BinD.float4 instance PGBinaryType "float8" instance PGBinaryParameter "float8" Double where - pgEncodeBinary _ = BinE.float8 + pgEncodeBinary _ _ = BinE.float8 instance PGBinaryColumn "float8" Double where - pgDecodeBinary = binDec BinD.float8 + pgDecodeBinary _ = binDec BinD.float8 instance PGBinaryType "numeric" instance PGBinaryParameter "numeric" Scientific where - pgEncodeBinary _ = BinE.numeric + pgEncodeBinary _ _ = BinE.numeric instance PGBinaryColumn "numeric" Scientific where - pgDecodeBinary = binDec BinD.numeric + pgDecodeBinary _ = binDec BinD.numeric instance PGBinaryParameter "numeric" Rational where - pgEncodeBinary _ = BinE.numeric . realToFrac + pgEncodeBinary _ _ = BinE.numeric . realToFrac instance PGBinaryColumn "numeric" Rational where - pgDecodeBinary t = realToFrac . binDec BinD.numeric t + pgDecodeBinary _ t = realToFrac . binDec BinD.numeric t instance PGBinaryType "char" instance PGBinaryParameter "char" Char where - pgEncodeBinary _ = BinE.char + pgEncodeBinary _ _ = BinE.char instance PGBinaryColumn "char" Char where - pgDecodeBinary = binDec BinD.char + pgDecodeBinary _ = binDec BinD.char instance PGBinaryType "text" instance PGBinaryType "varchar" instance PGBinaryType "bpchar" instance PGBinaryType "name" -- not strictly textsend, but essentially the same instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t Text.Text where - pgEncodeBinary _ = BinE.text . Left + pgEncodeBinary _ _ = BinE.text . Left instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t Text.Text where - pgDecodeBinary = binDec BinD.text + pgDecodeBinary _ = binDec BinD.text instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t TextL.Text where - pgEncodeBinary _ = BinE.text . Right + pgEncodeBinary _ _ = BinE.text . Right instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t TextL.Text where - pgDecodeBinary t = TextL.fromStrict . binDec BinD.text t + pgDecodeBinary _ t = TextL.fromStrict . binDec BinD.text t instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t BS.ByteString where - pgEncodeBinary _ = BinE.text . Left . TextE.decodeUtf8 + pgEncodeBinary _ _ = BinE.text . Left . TextE.decodeUtf8 instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BS.ByteString where - pgDecodeBinary t = TextE.encodeUtf8 . binDec BinD.text t + pgDecodeBinary _ t = TextE.encodeUtf8 . binDec BinD.text t instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t L.ByteString where - pgEncodeBinary _ = BinE.text . Right . TextLE.decodeUtf8 + pgEncodeBinary _ _ = BinE.text . Right . TextLE.decodeUtf8 instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t L.ByteString where - pgDecodeBinary t = L.fromStrict . TextE.encodeUtf8 . binDec BinD.text t + pgDecodeBinary _ t = L.fromStrict . TextE.encodeUtf8 . binDec BinD.text t instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t String where - pgEncodeBinary _ = BinE.text . Left . Text.pack + pgEncodeBinary _ _ = BinE.text . Left . Text.pack instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t String where - pgDecodeBinary t = Text.unpack . binDec BinD.text t + pgDecodeBinary _ t = Text.unpack . binDec BinD.text t instance PGBinaryType "bytea" instance PGBinaryParameter "bytea" BS.ByteString where - pgEncodeBinary _ = BinE.bytea . Left + pgEncodeBinary _ _ = BinE.bytea . Left instance PGBinaryColumn "bytea" BS.ByteString where - pgDecodeBinary = binDec BinD.bytea + pgDecodeBinary _ = binDec BinD.bytea instance PGBinaryParameter "bytea" L.ByteString where - pgEncodeBinary _ = BinE.bytea . Right + pgEncodeBinary _ _ = BinE.bytea . Right instance PGBinaryColumn "bytea" L.ByteString where - pgDecodeBinary t = L.fromStrict . binDec BinD.bytea t + pgDecodeBinary _ t = L.fromStrict . binDec BinD.bytea t instance PGBinaryType "date" instance PGBinaryParameter "date" Time.Day where - pgEncodeBinary _ = BinE.date + pgEncodeBinary _ _ = BinE.date instance PGBinaryColumn "date" Time.Day where - pgDecodeBinary = binDec BinD.date -{- Need to know PGConnection parameter "integer_datetimes" for these: + pgDecodeBinary _ = binDec BinD.date instance PGBinaryType "time" instance PGBinaryParameter "time" Time.TimeOfDay where - pgEncodeBinary _ = BinE.time + pgEncodeBinary e _ = BinE.time (pgIntegerDatetimes e) instance PGBinaryColumn "time" Time.TimeOfDay where - pgDecodeBinary = binDec BinD.time + pgDecodeBinary e = binDec $ BinD.time (pgIntegerDatetimes e) instance PGBinaryType "timestamp" instance PGBinaryParameter "timestamp" Time.LocalTime where - pgEncodeBinary _ = BinE.timestamp + pgEncodeBinary e _ = BinE.timestamp (pgIntegerDatetimes e) instance PGBinaryColumn "timestamp" Time.LocalTime where - pgDecodeBinary = binDec BinD.timestamp + pgDecodeBinary e = binDec $ BinD.timestamp (pgIntegerDatetimes e) instance PGBinaryType "timestamptz" instance PGBinaryParameter "timestamptz" Time.UTCTime where - pgEncodeBinary _ = BinE.timestamptz + pgEncodeBinary e _ = BinE.timestamptz (pgIntegerDatetimes e) instance PGBinaryColumn "timestamptz" Time.UTCTime where - pgDecodeBinary = binDec BinD.timestamptz + pgDecodeBinary e = binDec $ BinD.timestamptz (pgIntegerDatetimes e) instance PGBinaryType "interval" instance PGBinaryParameter "interval" Time.DiffTime where - pgEncodeBinary _ = BinE.interval + pgEncodeBinary e _ = BinE.interval (pgIntegerDatetimes e) instance PGBinaryColumn "interval" Time.DiffTime where - pgDecodeBinary = binDec BinD.interval --} + pgDecodeBinary e = binDec $ BinD.interval (pgIntegerDatetimes e) instance PGBinaryType "bool" instance PGBinaryParameter "bool" Bool where - pgEncodeBinary _ = BinE.bool + pgEncodeBinary _ _ = BinE.bool instance PGBinaryColumn "bool" Bool where - pgDecodeBinary = binDec BinD.bool + pgDecodeBinary _ = binDec BinD.bool instance PGBinaryType "uuid" instance PGBinaryParameter "uuid" UUID.UUID where - pgEncodeBinary _ = BinE.uuid + pgEncodeBinary _ _ = BinE.uuid instance PGBinaryColumn "uuid" UUID.UUID where - pgDecodeBinary = binDec BinD.uuid + pgDecodeBinary _ = binDec BinD.uuid -- TODO: arrays #endif diff --git a/test/Main.hs b/test/Main.hs index 5caacd2..c740030 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +-- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where import Data.Int (Int32) @@ -7,7 +8,6 @@ import System.Exit (exitSuccess, exitFailure) import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types (OID) -import Database.PostgreSQL.Typed.TemplatePG (queryTuple) import qualified Database.PostgreSQL.Typed.Range as Range import Connect @@ -40,8 +40,8 @@ main = do s = "\"hel\\o'" l = [Just "a\\\"b,c", Nothing] r = Range.normal (Just (-2 :: Int32)) Nothing - Just (Just i', Just b', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r') <- - $(queryTuple "SELECT {Just i}::int, {b}::bool, {f}::float4, {s}::text, {Just d}::date, {t}::timestamp, {Time.zonedTimeToUTC z}::timestamptz, {p}::interval, {l}::text[], {r}::int4range") c + [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r')] <- pgQuery c + [pgSQL|$SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${s}::text, ${Just d}::date, ${t}::timestamp, ${Time.zonedTimeToUTC z}::timestamptz, ${p}::interval, ${l}::text[], ${r}::int4range|] assert $ i == i' && b == b' && s == s' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' ["box"] <- simple c 603 From 6177e520c895c61305ffbc7d1f0e4901872d663b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 14:51:55 -0500 Subject: [PATCH 084/306] Switch to strict ByteStrings --- Database/PostgreSQL/Typed/Enum.hs | 4 +- Database/PostgreSQL/Typed/Protocol.hs | 66 ++++----- Database/PostgreSQL/Typed/Types.hs | 193 +++++++++++++------------- 3 files changed, 135 insertions(+), 128 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 49c5048..5867dfe 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -10,8 +10,8 @@ module Database.PostgreSQL.Typed.Enum ) where import Control.Monad (when) -import qualified Data.ByteString.Lazy.Char8 as BSC -import qualified Data.ByteString.Lazy.UTF8 as U +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 diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index bccdb15..4f2c43b 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -32,10 +32,11 @@ import qualified Crypto.Hash as Hash 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 (c2w, w2c) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as LC -import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Data.ByteString.Lazy as BSL +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 as Map @@ -95,7 +96,7 @@ data ColDescription = ColDescription , colBinary :: !Bool } deriving (Show) -type MessageFields = Map.Map Word8 L.ByteString +type MessageFields = Map.Map Word8 BS.ByteString -- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. -- See . @@ -111,7 +112,7 @@ data PGFrontendMessage | Flush -- |Parse SQL Destination (prepared statement) | Parse { statementName :: String, queryString :: String, parseTypes :: [OID] } - | PasswordMessage L.ByteString + | PasswordMessage BS.ByteString -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, -- etc.) aren't allowed. | SimpleQuery { queryString :: String } @@ -124,7 +125,7 @@ data PGFrontendMessage data PGBackendMessage = AuthenticationOk | AuthenticationCleartextPassword - | AuthenticationMD5Password L.ByteString + | AuthenticationMD5Password BS.ByteString -- AuthenticationSCMCredential | BackendKeyData Word32 Word32 | BindComplete @@ -132,7 +133,7 @@ data PGBackendMessage -- |CommandComplete is bare for now, although it could be made -- to contain the number of rows affected by statements in a -- later version. - | CommandComplete L.ByteString + | 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 @@ -173,12 +174,12 @@ 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 = maybe "" U.toString $ Map.lookup (c2w c) m + where f c = maybe "" BSU.toString $ Map.lookup (c2w c) m -- |Message SQLState code. -- See . pgMessageCode :: MessageFields -> String -pgMessageCode = maybe "" LC.unpack . Map.lookup (c2w 'C') +pgMessageCode = maybe "" BSC.unpack . Map.lookup (c2w 'C') defaultLogMessage :: MessageFields -> IO () defaultLogMessage = hPutStrLn stderr . displayMessage @@ -198,8 +199,8 @@ pgTypeEnv :: PGConnection -> PGTypeEnv pgTypeEnv = connTypeEnv #ifdef USE_MD5 -md5 :: L.ByteString -> L.ByteString -md5 = L.fromStrict . Hash.digestToHexByteString . (Hash.hashlazy :: L.ByteString -> Hash.Digest Hash.MD5) +md5 :: BS.ByteString -> BS.ByteString +md5 = Hash.digestToHexByteString . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) #endif @@ -230,7 +231,7 @@ messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = fmt (PGBinaryValue _) = True fmt _ = False val PGNullValue = B.int32BE (-1) - val (PGTextValue v) = B.word32BE (fromIntegral $ L.length v) <> B.lazyByteString v + 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) @@ -243,7 +244,7 @@ messageBody Parse{ statementName = n, queryString = s, parseTypes = t } = (Just pgString n <> pgString s <> B.word16BE (fromIntegral $ length t) <> Fold.foldMap B.word32BE t) messageBody (PasswordMessage s) = (Just 'p', - B.lazyByteString s <> nul) + B.byteString s <> nul) messageBody SimpleQuery{ queryString = s } = (Just 'Q', pgString s) messageBody Sync = (Just 'S', mempty) @@ -254,28 +255,31 @@ 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 + L.length b) - L.hPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length - where (t, b) = second B.toLazyByteString $ messageBody 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 = U.toString <$> G.getLazyByteStringNul +getPGString = BSLU.toString <$> G.getLazyByteStringNul + +getByteStringNul :: G.Get BS.ByteString +getByteStringNul = fmap BSL.toStrict G.getLazyByteStringNul getMessageFields :: G.Get MessageFields getMessageFields = g =<< G.getWord8 where g 0 = return Map.empty - g f = liftM2 (Map.insert f) G.getLazyByteStringNul getMessageFields + g f = liftM2 (Map.insert f) getByteStringNul getMessageFields -- |Parse an incoming message. getMessageBody :: Char -> G.Get PGBackendMessage getMessageBody 'R' = auth =<< G.getWord32be where auth 0 = return AuthenticationOk auth 3 = return AuthenticationCleartextPassword - auth 5 = AuthenticationMD5Password <$> G.getLazyByteString 4 + auth 5 = AuthenticationMD5Password <$> G.getByteString 4 auth op = fail $ "pgGetMessage: unsupported authentication type: " ++ show op getMessageBody 't' = do numParams <- G.getWord16be @@ -307,13 +311,13 @@ getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where getMessageBody '1' = return ParseComplete getMessageBody '2' = return BindComplete getMessageBody '3' = return CloseComplete -getMessageBody 'C' = CommandComplete <$> G.getLazyByteStringNul +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.getLazyByteString (fromIntegral len) + 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 @@ -323,15 +327,15 @@ getMessageBody 's' = return PortalSuspended getMessageBody 'N' = NoticeResponse <$> getMessageFields getMessageBody t = fail $ "pgGetMessage: unknown message type: " ++ show t -runGet :: Monad m => G.Get a -> L.ByteString -> m a +runGet :: Monad m => G.Get a -> BSL.ByteString -> m a runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOrFail g s -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. pgReceive :: PGConnection -> IO PGBackendMessage pgReceive c@PGConnection{ connHandle = h } = do - (typ, len) <- runGet (liftM2 (,) G.getWord8 G.getWord32be) =<< L.hGet h 5 - msg <- runGet (getMessageBody $ w2c typ) =<< L.hGet h (fromIntegral len - 4) + (typ, len) <- runGet (liftM2 (,) G.getWord8 G.getWord32be) =<< BSL.hGet h 5 + msg <- runGet (getMessageBody $ w2c typ) =<< BSL.hGet h (fromIntegral len - 4) when (connDebug c) $ putStrLn $ "< " ++ show msg case msg of ReadyForQuery s -> msg <$ writeIORef (connState c) s @@ -382,12 +386,12 @@ pgConnect db = do 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 $ U.fromString $ pgDBPass db + pgSend c $ PasswordMessage $ BSU.fromString $ pgDBPass db pgFlush c conn c #ifdef USE_MD5 msg c (AuthenticationMD5Password salt) = do - pgSend c $ PasswordMessage $ LC.pack "md5" `L.append` md5 (md5 (U.fromString (pgDBPass db ++ pgDBUser db)) `L.append` salt) + pgSend c $ PasswordMessage $ BSC.pack "md5" `BS.append` md5 (md5 (BSU.fromString (pgDBPass db ++ pgDBUser db)) `BS.append` salt) pgFlush c conn c #endif @@ -461,15 +465,15 @@ pgDescribe h sql types nulls = do _ -> fail $ "Failed to determine nullability of column #" ++ show col | otherwise = return True -rowsAffected :: L.ByteString -> Int -rowsAffected = ra . LC.words where +rowsAffected :: BS.ByteString -> Int +rowsAffected = ra . BSC.words where ra [] = -1 - ra l = fromMaybe (-1) $ readMaybe $ LC.unpack $ last l + 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 (L.fromStrict x) : fixBinary b r -fixBinary (True :b) (PGTextValue x:r) = PGBinaryValue (L.toStrict x) : fixBinary b r +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 diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index b9ec394..2aeafae 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -44,12 +44,12 @@ 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 B -import qualified Data.ByteString.Builder.Prim as BP +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 L -import qualified Data.ByteString.Lazy.Char8 as LC -import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.UTF8 as BSU import Data.Char (isDigit, digitToInt, intToDigit, toLower) import Data.Int import Data.List (intersperse) @@ -60,10 +60,10 @@ import Data.Ratio ((%), numerator, denominator) import Data.Scientific (Scientific) #endif #ifdef USE_TEXT -import qualified Data.Text as Text -import qualified Data.Text.Encoding as TextE -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextLE +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 @@ -83,7 +83,7 @@ import Text.Parsec.Token (naturalOrFloat, makeTokenParser, GenLanguageDef(..)) import qualified Database.PostgreSQL.Typed.Range as Range -type PGTextValue = L.ByteString +type PGTextValue = BS.ByteString type PGBinaryValue = BS.ByteString data PGValue = PGNullValue @@ -111,7 +111,7 @@ class KnownSymbol t => PGParameter (t :: Symbol) a where -- |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 . U.toString . pgEncode t + pgLiteral t = pgQuote . BSU.toString . pgEncode t class (PGParameter t a, PGBinaryType t) => PGBinaryParameter t a where pgEncodeBinary :: PGTypeEnv -> PGTypeName t -> a -> PGBinaryValue @@ -189,13 +189,16 @@ pgQuote = ('\'':) . es where es (c@'\'':r) = c:c:es r es (c:r) = c:es r -dQuote :: String -> L.ByteString -> B.Builder +buildBS :: BSB.Builder -> BS.ByteString +buildBS = BSL.toStrict . BSB.toLazyByteString + +dQuote :: String -> BS.ByteString -> BSB.Builder dQuote unsafe s - | not (L.null s) && all (`LC.notElem` s) unsafe && LC.map toLower s /= LC.pack "null" = B.lazyByteString s - | otherwise = dq <> BP.primMapLazyByteStringBounded ec s <> dq where - dq = B.char7 '"' - ec = BP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BP.liftFixedToBounded BP.word8) - bs = BP.liftFixedToBounded $ ((,) '\\') BP.>$< (BP.char7 BP.>*< BP.word8) + | not (BS.null s) && all (`BSC.notElem` s) unsafe && BSC.map toLower s /= BSC.pack "null" = BSB.byteString s + | otherwise = dq <> BSBP.primMapByteStringBounded ec s <> dq where + dq = BSB.char7 '"' + ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8) + bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) parseDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String parseDQuote unsafe = (q P.<|> uq) where @@ -207,18 +210,18 @@ parseDQuote unsafe = (q P.<|> uq) where class (Show a, Read a, KnownSymbol t) => PGLiteralType t a instance PGLiteralType t a => PGParameter t a where - pgEncode _ = LC.pack . show + pgEncode _ = BSC.pack . show pgLiteral _ = show instance PGLiteralType t a => PGColumn t a where - pgDecode _ = read . LC.unpack + pgDecode _ = read . BSC.unpack instance PGParameter "bool" Bool where - pgEncode _ False = LC.singleton 'f' - pgEncode _ True = LC.singleton 't' + pgEncode _ False = BSC.singleton 'f' + pgEncode _ True = BSC.singleton 't' pgLiteral _ False = "false" pgLiteral _ True = "true" instance PGColumn "bool" Bool where - pgDecode _ s = case LC.head s of + pgDecode _ s = case BSC.head s of 'f' -> False 't' -> True c -> error $ "pgDecode bool: " ++ [c] @@ -238,38 +241,38 @@ instance PGLiteralType "float8" Double instance PGParameter "char" Char where - pgEncode _ = LC.singleton + pgEncode _ = BSC.singleton instance PGColumn "char" Char where - pgDecode _ = LC.head + pgDecode _ = BSC.head class KnownSymbol t => PGStringType t instance PGStringType t => PGParameter t String where - pgEncode _ = U.fromString + pgEncode _ = BSU.fromString instance PGStringType t => PGColumn t String where - pgDecode _ = U.toString + pgDecode _ = BSU.toString -instance PGStringType t => PGParameter t L.ByteString where +instance PGStringType t => PGParameter t BS.ByteString where pgEncode _ = id -instance PGStringType t => PGColumn t L.ByteString where +instance PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id -instance PGStringType t => PGParameter t BS.ByteString where - pgEncode _ = L.fromStrict -instance PGStringType t => PGColumn t BS.ByteString where - pgDecode _ = L.toStrict +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 TextL.Text where - pgEncode _ = TextLE.encodeUtf8 -instance PGStringType t => PGColumn t TextL.Text where - pgDecode _ = TextLE.decodeUtf8 - -instance PGStringType t => PGParameter t Text.Text where - pgEncode _ = L.fromStrict . TextE.encodeUtf8 -instance PGStringType t => PGColumn t Text.Text where - pgDecode _ = TextL.toStrict . TextLE.decodeUtf8 +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" @@ -280,48 +283,48 @@ pgNameType = PGTypeProxy instance PGStringType "bpchar" -- blank padded -encodeBytea :: B.Builder -> PGTextValue -encodeBytea h = B.toLazyByteString $ B.string7 "\\x" <> h +encodeBytea :: BSB.Builder -> PGTextValue +encodeBytea h = buildBS $ BSB.string7 "\\x" <> h decodeBytea :: PGTextValue -> [Word8] decodeBytea s | sm /= "\\x" = error $ "pgDecode bytea: " ++ sm - | otherwise = pd $ L.unpack d where - (m, d) = L.splitAt 2 s - sm = LC.unpack m + | 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" L.ByteString where - pgEncode _ = encodeBytea . B.lazyByteStringHex - pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t -instance PGColumn "bytea" L.ByteString where - pgDecode _ = L.pack . decodeBytea +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 . B.byteStringHex - pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t + 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 _ = LC.pack . Time.showGregorian - pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t + pgEncode _ = BSC.pack . Time.showGregorian + pgLiteral _ = pgQuoteUnsafe . Time.showGregorian instance PGColumn "date" Time.Day where - pgDecode _ = Time.readTime defaultTimeLocale "%F" . LC.unpack + pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack instance PGParameter "time" Time.TimeOfDay where - pgEncode _ = LC.pack . Time.formatTime defaultTimeLocale "%T%Q" - pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t + pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" + pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q" instance PGColumn "time" Time.TimeOfDay where - pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . LC.unpack + pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack instance PGParameter "timestamp" Time.LocalTime where - pgEncode _ = LC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" - pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t + pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" + pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%F %T%Q" instance PGColumn "timestamp" Time.LocalTime where - pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . LC.unpack + 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. @@ -334,13 +337,13 @@ fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = fixTZ (c:s) = c:fixTZ s instance PGParameter "timestamptz" Time.UTCTime where - pgEncode _ = LC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" - -- pgLiteral t = pgQuoteUnsafe . LC.unpack . pgEncode t + pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" + pgLiteral _ = pgQuote{-Unsafe-} . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" instance PGColumn "timestamptz" Time.UTCTime where - pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . LC.unpack + pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack instance PGParameter "interval" Time.DiffTime where - pgEncode _ = LC.pack . show + pgEncode _ = BSC.pack . show pgLiteral _ = pgQuoteUnsafe . show -- |Representation of DiffTime as interval. -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. @@ -379,8 +382,8 @@ instance PGColumn "interval" Time.DiffTime where instance PGParameter "numeric" Rational where pgEncode _ r - | denominator r == 0 = LC.pack "NaN" -- this can't happen - | otherwise = LC.pack $ take 30 (showRational (r / (10 ^^ e))) ++ 'e' : show e where + | 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 @@ -394,7 +397,7 @@ instance PGColumn "numeric" Rational where | otherwise = ur $ readFloat s where ur [(x,"")] = x ur _ = error $ "pgDecode numeric: " ++ s - s = LC.unpack bs + s = BSC.unpack bs -- This will produce infinite(-precision) strings showRational :: Rational -> String @@ -421,8 +424,8 @@ class (KnownSymbol ta, KnownSymbol t) => PGArrayType ta t | ta -> t, t -> ta whe pgArrayDelim _ = ',' instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where - pgEncode ta l = B.toLazyByteString $ B.char7 '{' <> mconcat (intersperse (B.char7 $ pgArrayDelim ta) $ map el l) <> B.char7 '}' where - el Nothing = B.string7 "null" + 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 @@ -433,7 +436,7 @@ instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where return l nel = Nothing <$ nul P.<|> Just <$> el nul = P.oneOf "Nn" >> P.oneOf "Uu" >> P.oneOf "Ll" >> P.oneOf "Ll" - el = pgDecode (pgArrayElementType ta) . LC.pack <$> parseDQuote (pgArrayDelim ta : "\"{}") + el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parseDQuote (pgArrayDelim ta : "\"{}") -- Just a dump of pg_type: instance PGArrayType "_bool" "bool" @@ -512,22 +515,22 @@ class (KnownSymbol tr, KnownSymbol t) => PGRangeType tr t | tr -> t where pgRangeElementType PGTypeProxy = PGTypeProxy instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range.Range a) where - pgEncode _ Range.Empty = LC.pack "empty" - pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = B.toLazyByteString $ + pgEncode _ Range.Empty = BSC.pack "empty" + pgEncode tr (Range.Range (Range.Lower l) (Range.Upper u)) = buildBS $ pc '[' '(' l <> pb (Range.bound l) - <> B.char7 ',' + <> BSB.char7 ',' <> pb (Range.bound u) <> pc ']' ')' u where pb Nothing = mempty pb (Just b) = dQuote "\"(),[\\]" $ pgEncode (pgRangeElementType tr) b - pc c o b = B.char7 $ if Range.boundClosed b then c else o + 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 "array" 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) . LC.pack <$> parseDQuote "\"(),[\\]" + pp = pgDecode (pgRangeElementType tr) . BSC.pack <$> parseDQuote "\"(),[\\]" pc c o = True <$ P.char c P.<|> False <$ P.char o pb = P.optionMaybe pp mb = maybe Range.Unbounded . Range.Bounded @@ -548,10 +551,10 @@ instance PGRangeType "int8range" "int8" #ifdef USE_UUID instance PGParameter "uuid" UUID.UUID where - pgEncode _ = UUID.toLazyASCIIBytes + pgEncode _ = UUID.toASCIIBytes pgLiteral _ = pgQuoteUnsafe . UUID.toString instance PGColumn "uuid" UUID.UUID where - pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ LC.unpack u) $ UUID.fromLazyASCIIBytes u + pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u #endif #ifdef USE_BINARY @@ -614,36 +617,36 @@ instance PGBinaryType "text" instance PGBinaryType "varchar" instance PGBinaryType "bpchar" instance PGBinaryType "name" -- not strictly textsend, but essentially the same -instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t Text.Text where +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t T.Text where pgEncodeBinary _ _ = BinE.text . Left -instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t Text.Text where +instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t T.Text where pgDecodeBinary _ = binDec BinD.text -instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t TextL.Text where +instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t TL.Text where pgEncodeBinary _ _ = BinE.text . Right -instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t TextL.Text where - pgDecodeBinary _ t = TextL.fromStrict . binDec BinD.text t +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 . TextE.decodeUtf8 + pgEncodeBinary _ _ = BinE.text . Left . TE.decodeUtf8 instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BS.ByteString where - pgDecodeBinary _ t = TextE.encodeUtf8 . binDec BinD.text t -instance (PGStringType t, PGBinaryType t) => PGBinaryParameter t L.ByteString where - pgEncodeBinary _ _ = BinE.text . Right . TextLE.decodeUtf8 -instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t L.ByteString where - pgDecodeBinary _ t = L.fromStrict . TextE.encodeUtf8 . binDec BinD.text t + 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 . Text.pack + pgEncodeBinary _ _ = BinE.text . Left . T.pack instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t String where - pgDecodeBinary _ t = Text.unpack . binDec BinD.text t + 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" L.ByteString where +instance PGBinaryParameter "bytea" BSL.ByteString where pgEncodeBinary _ _ = BinE.bytea . Right -instance PGBinaryColumn "bytea" L.ByteString where - pgDecodeBinary _ t = L.fromStrict . binDec BinD.bytea t +instance PGBinaryColumn "bytea" BSL.ByteString where + pgDecodeBinary _ t = BSL.fromStrict . binDec BinD.bytea t instance PGBinaryType "date" instance PGBinaryParameter "date" Time.Day where From 775d450e26288cfc77f32cf6ca00cdf552250f63 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 15:24:40 -0500 Subject: [PATCH 085/306] Change useTPGDatabase to use pgReconnect --- Database/PostgreSQL/Typed/Protocol.hs | 2 +- Database/PostgreSQL/Typed/Query.hs | 7 +++++++ Database/PostgreSQL/Typed/TH.hs | 17 +++++++++-------- test/Main.hs | 2 +- 4 files changed, 18 insertions(+), 10 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 4f2c43b..bd2eb5c 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -448,7 +448,7 @@ pgDescribe h sql types nulls = do RowDescription r -> mapM desc r _ -> fail $ "describeStatement: unexpected response: " ++ show m where - desc (ColDescription{ colName = name, colTable = tab, colNumber = col, colType = typ}) = do + 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. diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index a354ee9..4255c2e 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -189,6 +189,13 @@ qqQuery f@QueryFlags{ flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = sql _ = fail "pgSQL: unterminated argument list" qqQuery f q = makePGQuery f q +{- +qqTop :: String -> TH.DecsQ +qqTop sql = + TH.runIO $ withTPGConnection $ \c -> + _ <- pgSimpleQuery c sql +-} + -- |A quasi-quoter for PGSQL queries. -- -- Used in expression context, it may contain any SQL statement @[pgSQL|SELECT ...|]@. diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 4260363..daecdd0 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -18,9 +18,9 @@ module Database.PostgreSQL.Typed.TH , pgTypeDecoder ) where -import Control.Applicative ((<$>), (<$), (<|>)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, swapMVar) -import Control.Monad ((>=>), void, liftM2) +import Control.Applicative ((<$>), (<|>)) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) +import Control.Monad ((>=>), liftM2) import Data.Foldable (toList) import Data.Maybe (isJust, fromMaybe) import qualified Language.Haskell.TH as TH @@ -58,15 +58,16 @@ tpgConnection = unsafePerformIO $ newMVar $ Left $ pgConnect =<< getTPGDatabase withTPGConnection :: (PGConnection -> IO a) -> IO a withTPGConnection f = modifyMVar tpgConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) -setTPGConnection :: Either (IO PGConnection) PGConnection -> IO () -setTPGConnection = void . swapMVar 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 will also clear all types registered with 'registerTPGType'. +-- It uses 'pgReconnect' so is a no-op to call multiple times with the same database. useTPGDatabase :: PGDatabase -> TH.DecsQ -useTPGDatabase db = [] <$ TH.runIO (setTPGConnection $ Left $ pgConnect db) +useTPGDatabase db = do + TH.runIO $ modifyMVar_ tpgConnection $ either + (const $ return $ Left $ pgConnect db) + (\c -> Right <$> pgReconnect c db) + return [] data PGTypeInfo = PGTypeInfo { pgTypeOID :: OID diff --git a/test/Main.hs b/test/Main.hs index c740030..a99ce11 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -41,7 +41,7 @@ main = do l = [Just "a\\\"b,c", Nothing] r = Range.normal (Just (-2 :: Int32)) Nothing [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r')] <- pgQuery c - [pgSQL|$SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${s}::text, ${Just d}::date, ${t}::timestamp, ${Time.zonedTimeToUTC z}::timestamptz, ${p}::interval, ${l}::text[], ${r}::int4range|] + [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|] assert $ i == i' && b == b' && s == s' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' ["box"] <- simple c 603 From a35ea514a2127126b22c98b68c4ec8b6ec942777 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 15:42:23 -0500 Subject: [PATCH 086/306] Minor doc updates --- Database/PostgreSQL/Typed/Protocol.hs | 1 + Database/PostgreSQL/Typed/Query.hs | 2 ++ Database/PostgreSQL/Typed/Types.hs | 27 +++++++++++++++++++-------- 3 files changed, 22 insertions(+), 8 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index bd2eb5c..c04d6db 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards #-} -- 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 diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 4255c2e..7004ff6 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -142,11 +142,13 @@ splitCommas = spl where 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 diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 2aeafae..c8c5106 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} -- | --- Module: Database.PostgreSQL.Typed.Type --- Copyright: 2010, 2011, 2013 Chris Forno +-- 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. @@ -85,10 +84,11 @@ 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 - | PGBinaryValue PGBinaryValue + | 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] @@ -101,8 +101,11 @@ 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 } + { 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 @@ -155,25 +158,32 @@ instance PGColumn t a => PGColumnNotNull t (Maybe a) where 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 @@ -411,11 +421,12 @@ 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! +-- 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 @@ -509,7 +520,7 @@ 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. +-- 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 From a34d9dacf1bbda667034067dde8704caa786dca2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 16:35:23 -0500 Subject: [PATCH 087/306] Minor fixes to array and range marshalling wrt padding --- Database/PostgreSQL/Typed/Types.hs | 31 ++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index c8c5106..359eb88 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -49,7 +49,7 @@ 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 (isDigit, digitToInt, intToDigit, toLower) +import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower) import Data.Int import Data.List (intersperse) import Data.Maybe (fromMaybe) @@ -202,19 +202,22 @@ pgQuote = ('\'':) . es where 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 - | not (BS.null s) && all (`BSC.notElem` s) unsafe && BSC.map toLower s /= BSC.pack "null" = BSB.byteString s - | otherwise = dq <> BSBP.primMapByteStringBounded ec s <> dq where - dq = BSB.char7 '"' - ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8) - bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) + | 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) + uq = P.many1 (P.noneOf ('"':'\\':unsafe)) class (Show a, Read a, KnownSymbol t) => PGLiteralType t a @@ -437,7 +440,7 @@ class (KnownSymbol ta, KnownSymbol t) => PGArrayType ta t | ta -> t, t -> ta whe 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 + 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 @@ -445,9 +448,9 @@ instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where P.sepBy nel (P.char (pgArrayDelim ta)) _ <- P.eof return l - nel = Nothing <$ nul P.<|> Just <$> el + 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 : "\"{}") + el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parseDQuote (pgArrayDelim ta : "{}") -- Just a dump of pg_type: instance PGArrayType "_bool" "bool" @@ -535,15 +538,15 @@ instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range.Range a) w <> pc ']' ')' u where pb Nothing = mempty - pb (Just b) = dQuote "\"(),[\\]" $ pgEncode (pgRangeElementType tr) b + 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 "array" 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 "\"(),[\\]" + pp = pgDecode (pgRangeElementType tr) . BSC.pack <$> parseDQuote "(),[]" pc c o = True <$ P.char c P.<|> False <$ P.char o - pb = P.optionMaybe pp + pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp mb = maybe Range.Unbounded . Range.Bounded pr = do lc <- pc '[' '(' From 7e39747d68eb74811e4c8c15d4026edc1238e1f3 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 19:16:35 -0500 Subject: [PATCH 088/306] Cache all type info on connect; switch to formatted type names --- Database/PostgreSQL/Typed/Protocol.hs | 4 +- Database/PostgreSQL/Typed/Query.hs | 17 +- Database/PostgreSQL/Typed/TH.hs | 180 ++++++++++++------- Database/PostgreSQL/Typed/Types.hs | 246 ++++++++++++-------------- 4 files changed, 247 insertions(+), 200 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index c04d6db..d7a4797 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards #-} +{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards, DataKinds #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- Copyright 2014-2015 Dylan Simon @@ -461,7 +461,7 @@ pgDescribe h sql types nulls = do -- 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 pgBoolType s + [[PGTextValue s]] -> return $ not $ pgDecode (PGTypeProxy :: PGTypeName "boolean") s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col | otherwise = return True diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 7004ff6..0752c12 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -155,22 +155,19 @@ 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) <- TH.runIO $ withTPGConnection $ \c -> - tpgDescribe c sqlp (fromMaybe [] prep) (not nulls) + (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 - b <- pgTypeIsBinary t - v <- TH.newName "p" - return (TH.VarP v, pgTypeEncoder (isNothing prep) b e t v)) pt - (pats, conv, bc) <- unzip3 <$> mapM (\(c, t, n) -> do - v <- TH.newName c - b <- pgTypeIsBinary t - return (TH.VarP v, pgTypeDecoder n b e t v, b)) rt + 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 . pgTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE (map boolL bc) + | 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)) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index daecdd0..ebd110e 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -1,28 +1,30 @@ -{-# LANGUAGE PatternGuards, ScopedTypeVariables, FlexibleContexts, TemplateHaskell #-} +{-# 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. --- Although this is meant to be used from other TH code, it will work during normal runtime if just want simple PGConnection management. +-- You can use these to build your own Template Haskell functions using the PostgreSQL connection. module Database.PostgreSQL.Typed.TH ( getTPGDatabase , withTPGConnection , useTPGDatabase - , PGTypeInfo(..) - , getPGTypeInfo + , TPGValueInfo(..) , tpgDescribe - , pgTypeIsBinary - , pgTypeEncoder - , pgTypeDecoder + , tpgTypeEncoder + , tpgTypeDecoder ) where -import Control.Applicative ((<$>), (<|>)) -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_) -import Control.Monad ((>=>), liftM2) -import Data.Foldable (toList) +import Control.Applicative ((<$>), (<$), (<|>)) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar) +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) @@ -31,6 +33,9 @@ import System.IO.Unsafe (unsafePerformIO) 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 @@ -51,74 +56,129 @@ getTPGDatabase = do , pgDBDebug = debug } -tpgConnection :: MVar (Either (IO PGConnection) PGConnection) -tpgConnection = unsafePerformIO $ newMVar $ Left $ pgConnect =<< getTPGDatabase +tpgState :: MVar (PGDatabase, Maybe TPGState) +tpgState = unsafePerformIO $ + newMVar (unsafePerformIO getTPGDatabase, Nothing) + +data TPGState = TPGState + { tpgConnection :: PGConnection + , tpgTypes :: IntMap.IntMap TPGType -- keyed on fromIntegral OID + } + +tpgInit :: PGConnection -> IO TPGState +tpgInit c = do + (_, tl) <- pgSimpleQuery c "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 $ TPGState + { tpgConnection = c + , tpgTypes = IntMap.fromAscList $ map (\[PGTextValue to, PGTextValue tn] -> + (fromIntegral (pgDecode (PGTypeProxy :: PGTypeName "oid") to :: OID), pgDecode (PGTypeProxy :: PGTypeName "text") tn)) $ Fold.toList tl + } + +-- |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 = modifyMVar tpgConnection $ either id return >=> (\c -> (,) (Right c) <$> f c) +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 a no-op to call multiple times with the same database. +-- It uses 'pgReconnect' so is safe to call multiple times with the same database. useTPGDatabase :: PGDatabase -> TH.DecsQ -useTPGDatabase db = do - TH.runIO $ modifyMVar_ tpgConnection $ either - (const $ return $ Left $ pgConnect db) - (\c -> Right <$> pgReconnect c db) +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 [] -data PGTypeInfo = PGTypeInfo - { pgTypeOID :: OID - , pgTypeName :: String - } +-- |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 by OID, internal or formatted name (case sensitive). +-- |Lookup a type OID by type name. +-- This is less common and thus less efficient than going the other way. -- Fail if not found. -getPGTypeInfo :: PGConnection -> Either OID String -> IO PGTypeInfo -getPGTypeInfo c t = do - (_, r) <- pgSimpleQuery c $ "SELECT oid, typname FROM pg_catalog.pg_type WHERE " ++ either - (\o -> "oid = " ++ pgLiteral pgOIDType o) - (\n -> "typname = " ++ pgQuote n ++ " OR format_type(oid, -1) = " ++ pgQuote n) - t - case toList r of - [[PGTextValue o, PGTextValue n]] -> return $ PGTypeInfo (pgDecode pgOIDType o) (pgDecode pgNameType n) - _ -> fail $ "Unknown PostgreSQL type: " ++ either show id t - - --- |A type-aware wrapper to 'pgDescribe' -tpgDescribe :: PGConnection -> String -> [String] -> Bool -> IO ([PGTypeInfo], [(String, PGTypeInfo, Bool)]) -tpgDescribe conn sql types nulls = do - at <- mapM (fmap pgTypeOID . getPGTypeInfo conn . Right) types - (pt, rt) <- pgDescribe conn sql at nulls - pth <- mapM (getPGTypeInfo conn . Left) pt - rth <- mapM (\(c, t, n) -> do - th <- getPGTypeInfo conn (Left t) - return (c, th, n)) rt - return (pth, rth) - -pgTypeIsBinary :: PGTypeInfo -> TH.Q Bool -pgTypeIsBinary PGTypeInfo{ pgTypeName = t } = +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 + } -typeApply :: TH.Name -> TH.Name -> PGTypeInfo -> TH.Name -> TH.Exp -typeApply f e PGTypeInfo{ pgTypeName = n } v = +-- |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 n))) + `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'. -pgTypeEncoder :: Bool -> Bool -> TH.Name -> PGTypeInfo -> TH.Name -> TH.Exp -pgTypeEncoder False False = typeApply 'pgEncodeParameter -pgTypeEncoder False True = typeApply 'pgEncodeBinaryParameter -pgTypeEncoder True _ = typeApply 'pgEscapeParameter +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. -pgTypeDecoder :: Bool -> Bool -> TH.Name -> PGTypeInfo -> TH.Name -> TH.Exp -pgTypeDecoder True False = typeApply 'pgDecodeColumn -pgTypeDecoder True True = typeApply 'pgDecodeBinaryColumn -pgTypeDecoder False False = typeApply 'pgDecodeColumnNotNull -pgTypeDecoder False True = typeApply 'pgDecodeBinaryColumnNotNull +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/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 359eb88..5787584 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -31,9 +31,6 @@ module Database.PostgreSQL.Typed.Types , pgDecodeBinaryColumnNotNull -- * Specific type support - , pgBoolType - , pgOIDType - , pgNameType , PGArrayType , PGRangeType ) where @@ -228,34 +225,29 @@ instance PGLiteralType t a => PGParameter t a where instance PGLiteralType t a => PGColumn t a where pgDecode _ = read . BSC.unpack -instance PGParameter "bool" Bool where +instance PGParameter "boolean" Bool where pgEncode _ False = BSC.singleton 'f' pgEncode _ True = BSC.singleton 't' pgLiteral _ False = "false" pgLiteral _ True = "true" -instance PGColumn "bool" Bool where +instance PGColumn "boolean" Bool where pgDecode _ s = case BSC.head s of 'f' -> False 't' -> True - c -> error $ "pgDecode bool: " ++ [c] -pgBoolType :: PGTypeName "bool" -pgBoolType = PGTypeProxy + c -> error $ "pgDecode boolean: " ++ [c] type OID = Word32 instance PGLiteralType "oid" OID -pgOIDType :: PGTypeName "oid" -pgOIDType = PGTypeProxy +instance PGLiteralType "smallint" Int16 +instance PGLiteralType "integer" Int32 +instance PGLiteralType "bigint" Int64 +instance PGLiteralType "real" Float +instance PGLiteralType "double precision" Double -instance PGLiteralType "int2" Int16 -instance PGLiteralType "int4" Int32 -instance PGLiteralType "int8" Int64 -instance PGLiteralType "float4" Float -instance PGLiteralType "float8" Double - -instance PGParameter "char" Char where +instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton -instance PGColumn "char" Char where +instance PGColumn "\"char\"" Char where pgDecode _ = BSC.head @@ -289,10 +281,8 @@ instance PGStringType t => PGColumn t TL.Text where #endif instance PGStringType "text" -instance PGStringType "varchar" +instance PGStringType "character varying" instance PGStringType "name" -- limit 63 characters -pgNameType :: PGTypeName "name" -pgNameType = PGTypeProxy instance PGStringType "bpchar" -- blank padded @@ -327,16 +317,16 @@ instance PGParameter "date" Time.Day where instance PGColumn "date" Time.Day where pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack -instance PGParameter "time" Time.TimeOfDay where +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" Time.TimeOfDay where +instance PGColumn "time without time zone" Time.TimeOfDay where pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack -instance PGParameter "timestamp" Time.LocalTime where +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" Time.LocalTime where +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. @@ -349,10 +339,10 @@ fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit 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 "timestamptz" Time.UTCTime where +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 "timestamptz" Time.UTCTime where +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 @@ -453,73 +443,73 @@ instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parseDQuote (pgArrayDelim ta : "{}") -- Just a dump of pg_type: -instance PGArrayType "_bool" "bool" -instance PGArrayType "_bytea" "bytea" -instance PGArrayType "_char" "char" -instance PGArrayType "_name" "name" -instance PGArrayType "_int8" "int8" -instance PGArrayType "_int2" "int2" -instance PGArrayType "_int2vector" "int2vector" -instance PGArrayType "_int4" "int4" -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 +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 "_float4" "float4" -instance PGArrayType "_float8" "float8" -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 "_varchar" "varchar" -instance PGArrayType "_date" "date" -instance PGArrayType "_time" "time" -instance PGArrayType "_timestamp" "timestamp" -instance PGArrayType "_timestamptz" "timestamptz" -instance PGArrayType "_interval" "interval" -instance PGArrayType "_timetz" "timetz" -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" +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. @@ -556,12 +546,12 @@ instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range.Range a) where uc <- pc ']' ')' return $ Range.Range (Range.Lower (mb lc lb)) (Range.Upper (mb uc ub)) -instance PGRangeType "int4range" "int4" +instance PGRangeType "int4range" "integer" instance PGRangeType "numrange" "numeric" -instance PGRangeType "tsrange" "timestamp" -instance PGRangeType "tstzrange" "timestamptz" +instance PGRangeType "tsrange" "timestamp without time zone" +instance PGRangeType "tstzrange" "timestamp with time zone" instance PGRangeType "daterange" "date" -instance PGRangeType "int8range" "int8" +instance PGRangeType "int8range" "bigint" #ifdef USE_UUID instance PGParameter "uuid" UUID.UUID where @@ -581,34 +571,34 @@ instance PGBinaryParameter "oid" OID where instance PGBinaryColumn "oid" OID where pgDecodeBinary _ = binDec BinD.int -instance PGBinaryType "int2" -instance PGBinaryParameter "int2" Int16 where +instance PGBinaryType "smallint" +instance PGBinaryParameter "smallint" Int16 where pgEncodeBinary _ _ = BinE.int2 . Left -instance PGBinaryColumn "int2" Int16 where +instance PGBinaryColumn "smallint" Int16 where pgDecodeBinary _ = binDec BinD.int -instance PGBinaryType "int4" -instance PGBinaryParameter "int4" Int32 where +instance PGBinaryType "integer" +instance PGBinaryParameter "integer" Int32 where pgEncodeBinary _ _ = BinE.int4 . Left -instance PGBinaryColumn "int4" Int32 where +instance PGBinaryColumn "integer" Int32 where pgDecodeBinary _ = binDec BinD.int -instance PGBinaryType "int8" -instance PGBinaryParameter "int8" Int64 where +instance PGBinaryType "bigint" +instance PGBinaryParameter "bigint" Int64 where pgEncodeBinary _ _ = BinE.int8 . Left -instance PGBinaryColumn "int8" Int64 where +instance PGBinaryColumn "bigint" Int64 where pgDecodeBinary _ = binDec BinD.int -instance PGBinaryType "float4" -instance PGBinaryParameter "float4" Float where +instance PGBinaryType "real" +instance PGBinaryParameter "real" Float where pgEncodeBinary _ _ = BinE.float4 -instance PGBinaryColumn "float4" Float where +instance PGBinaryColumn "real" Float where pgDecodeBinary _ = binDec BinD.float4 -instance PGBinaryType "float8" -instance PGBinaryParameter "float8" Double where +instance PGBinaryType "double precision" +instance PGBinaryParameter "double precision" Double where pgEncodeBinary _ _ = BinE.float8 -instance PGBinaryColumn "float8" Double where +instance PGBinaryColumn "double precision" Double where pgDecodeBinary _ = binDec BinD.float8 instance PGBinaryType "numeric" @@ -621,14 +611,14 @@ instance PGBinaryParameter "numeric" Rational where instance PGBinaryColumn "numeric" Rational where pgDecodeBinary _ t = realToFrac . binDec BinD.numeric t -instance PGBinaryType "char" -instance PGBinaryParameter "char" Char where +instance PGBinaryType "\"char\"" +instance PGBinaryParameter "\"char\"" Char where pgEncodeBinary _ _ = BinE.char -instance PGBinaryColumn "char" Char where +instance PGBinaryColumn "\"char\"" Char where pgDecodeBinary _ = binDec BinD.char instance PGBinaryType "text" -instance PGBinaryType "varchar" +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 @@ -667,20 +657,20 @@ instance PGBinaryParameter "date" Time.Day where pgEncodeBinary _ _ = BinE.date instance PGBinaryColumn "date" Time.Day where pgDecodeBinary _ = binDec BinD.date -instance PGBinaryType "time" -instance PGBinaryParameter "time" Time.TimeOfDay where +instance PGBinaryType "time without time zone" +instance PGBinaryParameter "time without time zone" Time.TimeOfDay where pgEncodeBinary e _ = BinE.time (pgIntegerDatetimes e) -instance PGBinaryColumn "time" Time.TimeOfDay where +instance PGBinaryColumn "time without time zone" Time.TimeOfDay where pgDecodeBinary e = binDec $ BinD.time (pgIntegerDatetimes e) -instance PGBinaryType "timestamp" -instance PGBinaryParameter "timestamp" Time.LocalTime where +instance PGBinaryType "timestamp without time zone" +instance PGBinaryParameter "timestamp without time zone" Time.LocalTime where pgEncodeBinary e _ = BinE.timestamp (pgIntegerDatetimes e) -instance PGBinaryColumn "timestamp" Time.LocalTime where +instance PGBinaryColumn "timestamp without time zone" Time.LocalTime where pgDecodeBinary e = binDec $ BinD.timestamp (pgIntegerDatetimes e) -instance PGBinaryType "timestamptz" -instance PGBinaryParameter "timestamptz" Time.UTCTime where +instance PGBinaryType "timestamp with time zone" +instance PGBinaryParameter "timestamp with time zone" Time.UTCTime where pgEncodeBinary e _ = BinE.timestamptz (pgIntegerDatetimes e) -instance PGBinaryColumn "timestamptz" Time.UTCTime where +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 @@ -688,10 +678,10 @@ instance PGBinaryParameter "interval" Time.DiffTime where instance PGBinaryColumn "interval" Time.DiffTime where pgDecodeBinary e = binDec $ BinD.interval (pgIntegerDatetimes e) -instance PGBinaryType "bool" -instance PGBinaryParameter "bool" Bool where +instance PGBinaryType "boolean" +instance PGBinaryParameter "boolean" Bool where pgEncodeBinary _ _ = BinE.bool -instance PGBinaryColumn "bool" Bool where +instance PGBinaryColumn "boolean" Bool where pgDecodeBinary _ = binDec BinD.bool instance PGBinaryType "uuid" From f8d33071dff8864fa7a55a496e1c8f996a797ef2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 19:18:43 -0500 Subject: [PATCH 089/306] Minor doc update --- Database/PostgreSQL/Typed.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index d5b55fd..f4b1751 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -173,7 +173,7 @@ import Database.PostgreSQL.Typed.Query -- > pgEncode _ (v :: MyType) = ... :: ByteString -- > instance PGColumn "mytype" MyType where -- > pgDecode _ (s :: ByteString) = ... :: MyType --- > instance PGArrayType "_mytype" "mytype" +-- > instance PGArrayType "mytype[]" "mytype" -- -- Required language extensions: FlexibleInstances, MultiParamTypeClasses, DataKinds From a074937e57375f5459a5d30d08aca344a4994299 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 19:32:13 -0500 Subject: [PATCH 090/306] Update snaplet for package name change --- Database/PostgreSQL/Typed/Types.hs | 14 +++++++------- .../{TemplatePG.hs => PostgresqlTyped.hs} | 9 ++++----- ...g.cabal => snaplet-postgresql-typed.cabal} | 19 +++++++++---------- 3 files changed, 20 insertions(+), 22 deletions(-) rename snaplet/Snap/Snaplet/{TemplatePG.hs => PostgresqlTyped.hs} (95%) rename snaplet/{snaplet-templatepg.cabal => snaplet-postgresql-typed.cabal} (68%) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 5787584..8e50041 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -469,7 +469,7 @@ instance PGArrayType "polygon[]" "polygon" instance PGArrayType "line[]" "line" instance PGArrayType "cidr[]" "cidr" instance PGArrayType "real[]" "real" -instance PGArrayType "double precision[]" "double precision" +instance PGArrayType "double precision[]" "double precision" instance PGArrayType "abstime[]" "abstime" instance PGArrayType "reltime[]" "reltime" instance PGArrayType "tinterval[]" "tinterval" @@ -479,13 +479,13 @@ instance PGArrayType "macaddr[]" "macaddr" instance PGArrayType "inet[]" "inet" instance PGArrayType "aclitem[]" "aclitem" instance PGArrayType "bpchar[]" "bpchar" -instance PGArrayType "character varying[]" "character varying" +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 "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 "time with time zone[]" "time with time zone" instance PGArrayType "bit[]" "bit" instance PGArrayType "varbit[]" "varbit" instance PGArrayType "numeric[]" "numeric" @@ -690,7 +690,7 @@ instance PGBinaryParameter "uuid" UUID.UUID where instance PGBinaryColumn "uuid" UUID.UUID where pgDecodeBinary _ = binDec BinD.uuid --- TODO: arrays +-- TODO: arrays (a bit complicated, need OID?, but theoretically possible) #endif {- diff --git a/snaplet/Snap/Snaplet/TemplatePG.hs b/snaplet/Snap/Snaplet/PostgresqlTyped.hs similarity index 95% rename from snaplet/Snap/Snaplet/TemplatePG.hs rename to snaplet/Snap/Snaplet/PostgresqlTyped.hs index 9774b96..6d1d9d5 100644 --- a/snaplet/Snap/Snaplet/TemplatePG.hs +++ b/snaplet/Snap/Snaplet/PostgresqlTyped.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, OverloadedStrings #-} -module Snap.Snaplet.TemplatePG ( +module Snap.Snaplet.PostgresqlTyped ( -- * The Snaplet PG(..) , HasPG(..) @@ -19,7 +19,6 @@ module Snap.Snaplet.TemplatePG ( , pgRunQuery , pgExecute , pgQuery - , PG.registerTPGType ) where import Control.Applicative @@ -35,9 +34,9 @@ import Data.Sequence (Seq) import Network (PortID(..)) import Snap -import qualified Database.TemplatePG as PG -import qualified Database.TemplatePG.Query as PG -import Paths_snaplet_templatepg +import qualified Database.PostgreSQL.Typed as PG +import qualified Database.PostgreSQL.Typed.Query as PG +import Paths_snaplet_postgresql_typed data PG diff --git a/snaplet/snaplet-templatepg.cabal b/snaplet/snaplet-postgresql-typed.cabal similarity index 68% rename from snaplet/snaplet-templatepg.cabal rename to snaplet/snaplet-postgresql-typed.cabal index fb044a4..6687bbd 100644 --- a/snaplet/snaplet-templatepg.cabal +++ b/snaplet/snaplet-postgresql-typed.cabal @@ -1,6 +1,6 @@ -name: snaplet-templatepg +name: snaplet-postgresql-typed version: 0 -synopsis: templatepg snaplet for the Snap Framework +synopsis: postgresql-types snaplet for the Snap Framework description: This snaplet contains support for using the Postgresql database with a Snap Framework application via the templatepg package. Based on snaplet-postgresql-simple. @@ -10,7 +10,7 @@ author: Dylan simon maintainer: dylan@dylex.net build-type: Simple cabal-version: >= 1.6 -homepage: https://github.com/dylex/snaplet-templatepg +homepage: https://github.com/dylex/postgresql-typed/snaplet/tree/master/snaplet category: Snap data-files: @@ -18,14 +18,14 @@ data-files: source-repository head type: git - location: https://github.com/dylex/snaplet-templatepg.git + location: https://github.com/dylex/postgresql-typed.git Library exposed-modules: - Snap.Snaplet.TemplatePG + Snap.Snaplet.PostgresqlTyped other-modules: - Paths_snaplet_templatepg + Paths_snaplet_postgresql_typed build-depends: base >= 4 && < 4.8, @@ -34,13 +34,12 @@ Library lens, MonadCatchIO-transformers >= 0.3 && < 0.4, mtl >= 2 && < 2.3, - templatepg >= 0.3 && < 0.4, resource-pool-catchio >= 0.2 && < 0.3, snap >= 0.10 && < 0.14, transformers >= 0.2 && < 0.5, containers, time, - network + network, + postgresql-typed - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-orphans -fno-warn-unused-do-bind + ghc-options: -Wall From ced31ad7c18c65ce5600916fff66476870e7a211 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 20:24:15 -0500 Subject: [PATCH 091/306] Allow compile-time SQL execution; fix error handling Minor other changes --- Database/PostgreSQL/Typed/Enum.hs | 2 +- Database/PostgreSQL/Typed/Protocol.hs | 43 ++++++++++++++------------- Database/PostgreSQL/Typed/Query.hs | 19 +++++++----- Database/PostgreSQL/Typed/TH.hs | 26 ++++++++++------ test/Main.hs | 13 ++++++-- 5 files changed, 63 insertions(+), 40 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 5867dfe..11f7bd1 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -37,7 +37,7 @@ makePGEnum :: String -- ^ PostgreSQL enum type name -> 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 ON pg_enum.enumtypid = pg_type.oid WHERE typtype = 'e' AND typname = " ++ pgQuote name ++ " ORDER BY enumsortorder" + 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 diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index d7a4797..115d293 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -333,21 +333,27 @@ runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOr -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. -pgReceive :: PGConnection -> IO PGBackendMessage -pgReceive c@PGConnection{ connHandle = h } = do +pgReceive :: Bool -> PGConnection -> IO PGBackendMessage +pgReceive raw c@PGConnection{ connHandle = h } = do (typ, len) <- runGet (liftM2 (,) G.getWord8 G.getWord32be) =<< BSL.hGet h 5 msg <- runGet (getMessageBody $ w2c typ) =<< BSL.hGet h (fromIntegral len - 4) when (connDebug c) $ putStrLn $ "< " ++ show msg + let rawres + | raw = return msg + | otherwise = pgReceive raw c case msg of - ReadyForQuery s -> msg <$ writeIORef (connState c) s + ReadyForQuery s -> + writeIORef (connState c) s >> rawres NoticeResponse{ messageFields = m } -> - connLogMessage c m >> pgReceive c + connLogMessage c m >> pgReceive raw c ErrorResponse{ messageFields = m } -> writeIORef (connState c) StateUnknown >> throwIO (PGError m) + EmptyQueryResponse -> -- just ignore these: usually means someone put a stray semi-colon somewhere + rawres _ -> return msg -pgHandle :: PGConnection -> (PGBackendMessage -> IO a) -> IO a -pgHandle c = (pgReceive c >>=) +pgHandle :: Bool -> PGConnection -> (PGBackendMessage -> IO a) -> IO a +pgHandle raw c = (pgReceive raw c >>=) -- |Connect to a PostgreSQL server. pgConnect :: PGDatabase -> IO PGConnection @@ -377,7 +383,7 @@ pgConnect db = do pgFlush c conn c where - conn c = pgHandle c (msg c) + conn c = pgHandle True c (msg c) msg c (ReadyForQuery _) = return c { connTypeEnv = PGTypeEnv { pgIntegerDatetimes = (connParameters c Map.! "integer_datetimes") == "on" @@ -424,7 +430,7 @@ pgSync c@PGConnection{ connState = sr } = do when (s == StateUnknown) $ do pgSend c Sync pgFlush c - _ <- pgReceive c `catch` \(PGError m) -> ErrorResponse m <$ connLogMessage c m + _ <- pgReceive True c `catch` \(PGError m) -> ErrorResponse m <$ connLogMessage c m pgSync c -- |Describe a SQL statement/query. A statement description consists of 0 or @@ -441,9 +447,9 @@ pgDescribe h sql types nulls = do pgSend h $ Describe "" pgSend h $ Flush pgFlush h - ParseComplete <- pgReceive h - ParameterDescription ps <- pgReceive h - m <- pgReceive h + ParseComplete <- pgReceive False h + ParameterDescription ps <- pgReceive False h + m <- pgReceive False h (,) ps <$> case m of NoData -> return [] RowDescription r -> mapM desc r @@ -489,17 +495,14 @@ pgSimpleQuery h sql = do pgSend h $ SimpleQuery sql pgFlush h go start where - go = pgHandle h + go = pgHandle False h start (CommandComplete c) = got c Seq.empty start (RowDescription rd) = go $ row (map colBinary rd) 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 = (rowsAffected c, s) <$ go end - end (ReadyForQuery _) = return [] - end EmptyQueryResponse = go end - end m = fail $ "pgSimpleQuery: unexpected message: " ++ 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 @@ -511,7 +514,7 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = types } pgSend c $ Bind{ statementName = sn, bindParameters = bind, binaryColumns = bc } let - go = pgHandle c start + go = pgHandle False c start start ParseComplete = do modifyIORef psr $ \(i, m) -> (i, Map.insert key n m) @@ -536,7 +539,7 @@ pgPreparedQuery c sql types bind bc = do start go Seq.empty where - go = pgHandle c . row + go = pgHandle False c . row row s (DataRow fs) = go (s Seq.|> fixBinary bc fs) row s (CommandComplete r) = return (rowsAffected r, s) row _ m = fail $ "pgPreparedQuery: unexpected row: " ++ show m @@ -556,7 +559,7 @@ pgPreparedLazyQuery c sql types bind bc count = do pgSend c $ Execute count pgSend c $ Flush pgFlush c - go = pgHandle c . row + go = pgHandle False 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 @@ -570,5 +573,5 @@ pgCloseStatement c@PGConnection{ connPreparedStatements = psr } sql types = do Fold.forM_ mn $ \n -> do pgSend c $ Close{ statementName = show n } pgFlush c - CloseComplete <- pgReceive c + CloseComplete <- pgReceive False c return () diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 0752c12..c46c2b2 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -16,6 +16,7 @@ module Database.PostgreSQL.Typed.Query 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) @@ -188,12 +189,13 @@ qqQuery f@QueryFlags{ flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = sql _ = fail "pgSQL: unterminated argument list" qqQuery f q = makePGQuery f q -{- -qqTop :: String -> TH.DecsQ -qqTop sql = - TH.runIO $ withTPGConnection $ \c -> - _ <- pgSimpleQuery c sql --} +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. -- @@ -209,10 +211,13 @@ qqTop sql = -- [@?@] 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 = const $ fail "pgSQL not supported at top level" + , quoteDec = qqTop True } diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index ebd110e..1034ac6 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -10,6 +10,7 @@ module Database.PostgreSQL.Typed.TH ( getTPGDatabase , withTPGConnection , useTPGDatabase + , reloadTPGTypes , TPGValueInfo(..) , tpgDescribe , tpgTypeEncoder @@ -17,7 +18,7 @@ module Database.PostgreSQL.Typed.TH ) where import Control.Applicative ((<$>), (<$), (<|>)) -import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, modifyMVar_) import Control.Exception (onException, finally) import Control.Monad (liftM2) import qualified Data.Foldable as Fold @@ -28,7 +29,7 @@ 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) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Protocol @@ -65,14 +66,16 @@ data TPGState = TPGState , 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 = do - (_, tl) <- pgSimpleQuery c "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 $ TPGState - { tpgConnection = c - , tpgTypes = IntMap.fromAscList $ map (\[PGTextValue to, PGTextValue tn] -> - (fromIntegral (pgDecode (PGTypeProxy :: PGTypeName "oid") to :: OID), pgDecode (PGTypeProxy :: PGTypeName "text") tn)) $ Fold.toList tl - } +tpgInit c = tpgLoadTypes TPGState{ tpgConnection = c, tpgTypes = undefined } -- |Run an action using the Template Haskell state. withTPGState :: (TPGState -> IO a) -> IO a @@ -102,6 +105,11 @@ useTPGDatabase db = TH.runIO $ do `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 diff --git a/test/Main.hs b/test/Main.hs index a99ce11..ec3b73e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -9,6 +9,7 @@ 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 @@ -18,6 +19,11 @@ 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] @@ -40,9 +46,10 @@ main = do s = "\"hel\\o'" l = [Just "a\\\"b,c", Nothing] r = Range.normal (Just (-2 :: Int32)) Nothing - [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r')] <- 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|] - assert $ i == i' && b == b' && s == s' && f == f' && d == d' && t == t' && Time.zonedTimeToUTC z == z' && p == p' && l == l' && r == r' + 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 From 76a37ffcc8a7fdb7c457dc2c2c277d589b87743b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 21:51:14 -0500 Subject: [PATCH 092/306] A couple more name changes in snaplet --- snaplet/Snap/Snaplet/PostgresqlTyped.hs | 2 +- snaplet/snaplet-postgresql-typed.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/snaplet/Snap/Snaplet/PostgresqlTyped.hs b/snaplet/Snap/Snaplet/PostgresqlTyped.hs index 6d1d9d5..1f0e304 100644 --- a/snaplet/Snap/Snaplet/PostgresqlTyped.hs +++ b/snaplet/Snap/Snaplet/PostgresqlTyped.hs @@ -118,7 +118,7 @@ getPGConfig config = do return $ PGConfig db stripes idle resources pgMake :: Initializer b PG PGConfig -> SnapletInit b PG -pgMake config = makeSnaplet "templatepg" "TemplatePG interface" (Just getDataDir) $ do +pgMake config = makeSnaplet "postgresql-typed" "PostgreSQL-Typed interface" (Just getDataDir) $ do c <- config liftIO $ PGPool <$> createPool (PG.pgConnect (pgConfigDatabase c)) PG.pgDisconnect (pgConfigNumStripes c) (realToFrac $ pgConfigIdleTime c) (pgConfigResources c) diff --git a/snaplet/snaplet-postgresql-typed.cabal b/snaplet/snaplet-postgresql-typed.cabal index 6687bbd..f3661c3 100644 --- a/snaplet/snaplet-postgresql-typed.cabal +++ b/snaplet/snaplet-postgresql-typed.cabal @@ -1,9 +1,9 @@ name: snaplet-postgresql-typed version: 0 -synopsis: postgresql-types snaplet for the Snap Framework +synopsis: postgresql-typed snaplet for the Snap Framework description: This snaplet contains support for using the Postgresql database with a Snap Framework application via the - templatepg package. Based on snaplet-postgresql-simple. + postgresql-typed package. Based on snaplet-postgresql-simple. license: BSD3 license-file: LICENSE author: Dylan simon From 45071ffaf3c8786fdd5d4d964c1ca00721a79409 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 3 Jan 2015 21:53:55 -0500 Subject: [PATCH 093/306] TODO item done --- TODO | 1 - 1 file changed, 1 deletion(-) diff --git a/TODO b/TODO index ce7222c..531fcd8 100644 --- a/TODO +++ b/TODO @@ -17,5 +17,4 @@ But easier for the programmer would be to have TemplatePG add explicit casts to all values it sends in. This is probably safer in the long run as well, although possibly less flexible. Prepared placeholder type specification provides one solution to this [pgSQL|$(type,...)SQL...|] -* Use postgresql-binary package for binary protocol with supported types * Consider using postgresql-libpq (worse performance but much easier maintenance) From 4fd9bcd41b32b0cea4773a95c612c3c7f8db7640 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 4 Jan 2015 16:56:57 -0500 Subject: [PATCH 094/306] Rewrite protocol message input to be more robust And hopefully also more efficient: fewer read calls --- Database/PostgreSQL/Typed/Protocol.hs | 141 +++++++++++++++++--------- 1 file changed, 91 insertions(+), 50 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 115d293..2e840e2 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -25,7 +25,7 @@ module Database.PostgreSQL.Typed.Protocol ( import Control.Applicative ((<$>), (<$)) import Control.Arrow (second) -import Control.Exception (Exception, throwIO, catch) +import Control.Exception (Exception, throwIO) import Control.Monad (liftM2, replicateM, when, unless) #ifdef USE_MD5 import qualified Crypto.Hash as Hash @@ -34,18 +34,19 @@ 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 (c2w, w2c) +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 as Map +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 (Word8, Word32) +import Data.Word (Word32) import Network (HostName, PortID(..), connectTo) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) import System.IO.Unsafe (unsafeInterleaveIO) @@ -86,6 +87,7 @@ data PGConnection = PGConnection , connTypeEnv :: PGTypeEnv , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) , connState :: IORef PGState + , connInput :: IORef (G.Decoder PGBackendMessage) } data ColDescription = ColDescription @@ -97,7 +99,7 @@ data ColDescription = ColDescription , colBinary :: !Bool } deriving (Show) -type MessageFields = Map.Map Word8 BS.ByteString +type MessageFields = Map.Map Char String -- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. -- See . @@ -175,12 +177,15 @@ 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 = maybe "" BSU.toString $ Map.lookup (c2w c) m + 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 = maybe "" BSC.unpack . Map.lookup (c2w 'C') +pgMessageCode = Map.findWithDefault "" 'C' defaultLogMessage :: MessageFields -> IO () defaultLogMessage = hPutStrLn stderr . displayMessage @@ -271,9 +276,9 @@ getByteStringNul :: G.Get BS.ByteString getByteStringNul = fmap BSL.toStrict G.getLazyByteStringNul getMessageFields :: G.Get MessageFields -getMessageFields = g =<< G.getWord8 where - g 0 = return Map.empty - g f = liftM2 (Map.insert f) getByteStringNul getMessageFields +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 @@ -328,38 +333,57 @@ getMessageBody 's' = return PortalSuspended getMessageBody 'N' = NoticeResponse <$> getMessageFields getMessageBody t = fail $ "pgGetMessage: unknown message type: " ++ show t -runGet :: Monad m => G.Get a -> BSL.ByteString -> m a -runGet g s = either (\(_, _, e) -> fail e) (\(_, _, r) -> return r) $ G.runGetOrFail g s +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 :: Bool -> PGConnection -> IO PGBackendMessage -pgReceive raw c@PGConnection{ connHandle = h } = do - (typ, len) <- runGet (liftM2 (,) G.getWord8 G.getWord32be) =<< BSL.hGet h 5 - msg <- runGet (getMessageBody $ w2c typ) =<< BSL.hGet h (fromIntegral len - 4) - when (connDebug c) $ putStrLn $ "< " ++ show msg - let rawres - | raw = return msg - | otherwise = pgReceive raw c - case msg of - ReadyForQuery s -> - writeIORef (connState c) s >> rawres - NoticeResponse{ messageFields = m } -> - connLogMessage c m >> pgReceive raw c - ErrorResponse{ messageFields = m } -> - writeIORef (connState c) StateUnknown >> throwIO (PGError m) - EmptyQueryResponse -> -- just ignore these: usually means someone put a stray semi-colon somewhere - rawres - _ -> return msg - -pgHandle :: Bool -> PGConnection -> (PGBackendMessage -> IO a) -> IO a -pgHandle raw c = (pgReceive raw c >>=) +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 @@ -370,6 +394,7 @@ pgConnect db = do , connPreparedStatements = prep , connState = state , connTypeEnv = undefined + , connInput = input } pgSend c $ StartupMessage [ ("user", pgDBUser db) @@ -383,7 +408,7 @@ pgConnect db = do pgFlush c conn c where - conn c = pgHandle True c (msg c) + conn c = pgReceive c >>= msg c msg c (ReadyForQuery _) = return c { connTypeEnv = PGTypeEnv { pgIntegerDatetimes = (connParameters c Map.! "integer_datetimes") == "on" @@ -427,11 +452,21 @@ pgSync :: PGConnection -> IO () pgSync c@PGConnection{ connState = sr } = do s <- readIORef sr when (s == StateClosed) $ fail "pgSync: operation on closed connection" - when (s == StateUnknown) $ do - pgSend c Sync - pgFlush c - _ <- pgReceive True c `catch` \(PGError m) -> ErrorResponse m <$ connLogMessage c m - pgSync c + 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 @@ -445,11 +480,12 @@ pgDescribe h sql types nulls = do pgSync h pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = types } pgSend h $ Describe "" - pgSend h $ Flush + pgSend h Flush + pgSend h Sync pgFlush h - ParseComplete <- pgReceive False h - ParameterDescription ps <- pgReceive False h - m <- pgReceive False h + ParseComplete <- pgReceive h + ParameterDescription ps <- pgReceive h + m <- pgReceive h (,) ps <$> case m of NoData -> return [] RowDescription r -> mapM desc r @@ -495,9 +531,10 @@ pgSimpleQuery h sql = do pgSend h $ SimpleQuery sql pgFlush h go start where - go = pgHandle False h - start (CommandComplete c) = got c Seq.empty + 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 @@ -514,7 +551,7 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = types } pgSend c $ Bind{ statementName = sn, bindParameters = bind, binaryColumns = bc } let - go = pgHandle False c start + go = pgReceive c >>= start start ParseComplete = do modifyIORef psr $ \(i, m) -> (i, Map.insert key n m) @@ -534,14 +571,16 @@ pgPreparedQuery :: PGConnection -> String -- ^ SQL statement with placeholders pgPreparedQuery c sql types bind bc = do start <- pgPreparedBind c sql types bind bc pgSend c $ Execute 0 - pgSend c $ Flush + pgSend c Flush + pgSend c Sync pgFlush c start go Seq.empty where - go = pgHandle False c . row + 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. @@ -559,10 +598,11 @@ pgPreparedLazyQuery c sql types bind bc count = do pgSend c $ Execute count pgSend c $ Flush pgFlush c - go = pgHandle False c . row + 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). @@ -571,7 +611,8 @@ 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 False c + CloseComplete <- pgReceive c return () From f02ba9c194a6b1b4bddc293b6f2e548f9d611c32 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 4 Jan 2015 21:45:48 -0500 Subject: [PATCH 095/306] Minor grammar fix in package desc --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 174ac94..25f36c6 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -12,7 +12,7 @@ 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. + Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statements at compile time and provide appropriate type marshalling for both parameters and results. Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell. Supports many built-in PostgreSQL types already, including arrays and ranges, and can be easily extended in user code to support any other types. Originally based on Chris Forno's templatepg library. From cbb748dafae011cc9b9077ab266b63523b7fcd28 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 4 Jan 2015 23:57:58 -0500 Subject: [PATCH 096/306] Minor doc updates --- Database/PostgreSQL/Typed.hs | 29 ++++++++++++------------- Database/PostgreSQL/Typed/Query.hs | 4 ++-- Database/PostgreSQL/Typed/TemplatePG.hs | 14 +++--------- 3 files changed, 19 insertions(+), 28 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index f4b1751..937cfd0 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -71,7 +71,7 @@ import Database.PostgreSQL.Typed.Query -- 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 +-- 'PGError' or other failure (if types change). Also, nullable result fields resulting from outer joins are not -- detected and need to be handled explicitly. -- -- Based originally on Chris Forno's TemplatePG library. @@ -102,12 +102,11 @@ import Database.PostgreSQL.Typed.Query -- -- [@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: +-- If you'd like to specify what connection to use directly, use 'useTPGDatabase' at the top level: -- --- > myConnect = pgConnect ... --- > useTHConnection myConnect +-- > useTPGDatabase PGDatabase{ ... } -- --- 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. +-- Note that due to TH limitations, the database must be in-line or in a different module. This call must be processed by the compiler before (above) any other TH calls. -- -- You can set @TPG_DEBUG@ at compile or runtime to get a protocol-level trace. @@ -119,7 +118,7 @@ import Database.PostgreSQL.Typed.Query -- -- > 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.) +-- Expression placeholders are substituted with PostgreSQL ones in left-to-right order starting with 1, so must be in places that PostgreSQL allows them (e.g., not identifiers, table names, column names, operators, etc.) -- However, this does mean that you can repeat expressions using the corresponding PostgreSQL placeholder as above. -- If there are extra PostgreSQL parameters the may be passed as arguments: -- @@ -137,7 +136,7 @@ import Database.PostgreSQL.Typed.Query -- -- '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'.) +-- (Prepared queries are released automatically at 'pgDisconnect', but may be closed early using 'Database.PostgreSQL.Typed.Protocol.pgCloseQuery'.) -- $templatepg -- There is also an older, simpler interface based on TemplatePG that combines both the compile and runtime steps. @@ -149,7 +148,7 @@ import Database.PostgreSQL.Typed.Query -- given one at compile-time, so you need to pass it after the splice: -- -- > h <- pgConnect ... --- > tuples <- $(queryTuples \"SELECT * FROM pg_database\") h +-- > 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: @@ -157,17 +156,17 @@ import Database.PostgreSQL.Typed.Query -- > 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 +-- TemplatePG provides 'Database.PostgreSQL.Typed.TemplatePG.withTransaction', 'Database.PostgreSQL.Typed.TemplatePG.rollback', and 'Database.PostgreSQL.Typed.TemplatePG.insertIgnore', but they've -- not been thoroughly tested, so use them at your own risk. -- $types -- Most builtin types are already supported. -- For the most part, exactly equivalent types are all supported (e.g., 'Int32' for int4) as well as other safe equivalents, but you cannot, for example, pass an 'Integer' as a @smallint@. -- To achieve this flexibility, the exact types of all parameters and results must be fully known (e.g., numeric literals will not work). --- Currenly only 1-dimentional arrays are supported. +-- Currently only 1-dimensional 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): +-- However you can add support for your own types or add flexibility to existing types by creating new instances of 'Database.PostgreSQL.Typed.Types.PGParameter' (for encoding) and 'Database.PostgreSQL.Typed.Types.PGColumn' (for decoding). +-- If you also want to support arrays of a new type, you should also provide a 'Database.PostgreSQL.Typed.Types.PGArrayType' instance (or 'Database.PostgreSQL.Typed.Types.PGRangeType' for new ranges): -- -- > instance PGParameter "mytype" MyType where -- > pgEncode _ (v :: MyType) = ... :: ByteString @@ -193,7 +192,7 @@ import Database.PostgreSQL.Typed.Query -- 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 (?)@). +-- 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: @@ -205,6 +204,6 @@ import Database.PostgreSQL.Typed.Query -- 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\") +-- > (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\") +-- > uncurryN someFunction \`liftM\` $(queryTuple "SELECT a, b, c FROM table LIMIT 1") diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index c46c2b2..a4e1691 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -39,7 +39,7 @@ class PGQuery q a | q -> a where pgRunQuery :: PGConnection -> q -> IO (Int, Seq a) class PGQuery q PGValues => PGRawQuery q --- |Execute a query that does not return result. +-- |Execute a query that does not return results. -- Return the number of rows affected (or -1 if not known). pgExecute :: PGQuery q () => PGConnection -> q -> IO Int pgExecute c q = fst <$> pgRunQuery c q @@ -212,7 +212,7 @@ qqTop err sql = do -- [@$@] 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). +-- 'pgSQL' can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results). -- Here the query can only be prefixed with @!@ to make errors non-fatal. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index b45d732..c89d9bf 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -44,8 +44,7 @@ querySQL "" = "" -- -- Example (where @h@ is a handle from 'pgConnect'): -- --- @$(queryTuples \"SELECT usesysid, usename FROM pg_user\") h :: IO [(Maybe String, Maybe Integer)] --- @ +-- > $(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) |] @@ -56,10 +55,8 @@ queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleFlags $ querySQL sql) | -- -- 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)) --- @ +-- > 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) |] @@ -68,11 +65,6 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- 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) |] From 52ec94a8860edabcd513517e78ea0ac457a498e7 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 5 Jan 2015 00:02:26 -0500 Subject: [PATCH 097/306] One more tiny doc update --- Database/PostgreSQL/Typed.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index 937cfd0..336a569 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -206,4 +206,4 @@ import Database.PostgreSQL.Typed.Query -- -- > (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") +-- > uncurryN someFunction `liftM` $(queryTuple "SELECT a, b, c FROM table LIMIT 1") From 307840dc0ca099a83d3c9fda203c96ff458e0d38 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 5 Jan 2015 09:03:54 -0500 Subject: [PATCH 098/306] Eliminate PGLiteralType to increase coherency At the cost of a bit of duplicate code, but it's simpler this way anyway, and produces better error messages. --- Database/PostgreSQL/Typed/Types.hs | 54 +++++++++++++++++++++--------- 1 file changed, 39 insertions(+), 15 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 8e50041..f1a8eae 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -217,14 +217,6 @@ parseDQuote unsafe = (q P.<|> uq) where 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' @@ -237,13 +229,41 @@ instance PGColumn "boolean" Bool where 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 "oid" OID where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "oid" OID where + pgDecode _ = read . BSC.unpack + +instance PGParameter "smallint" Int16 where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "smallint" Int16 where + pgDecode _ = read . BSC.unpack + +instance PGParameter "integer" Int32 where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "integer" Int32 where + pgDecode _ = read . BSC.unpack + +instance PGParameter "bigint" Int64 where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "bigint" Int64 where + pgDecode _ = read . BSC.unpack +instance PGParameter "real" Float where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "real" Float where + pgDecode _ = read . BSC.unpack + +instance PGParameter "double precision" Double where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "double precision" Double where + pgDecode _ = read . BSC.unpack instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton @@ -410,7 +430,11 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) #ifdef USE_SCIENTIFIC -instance PGLiteralType "numeric" Scientific +instance PGParameter "numeric" Scientific where + pgEncode _ = BSC.pack . show + pgLiteral _ = show +instance PGColumn "numeric" Scientific where + pgDecode _ = read . BSC.unpack #endif -- |The cannonical representation of a PostgreSQL array of any type, which may always contain NULLs. From fe60fe04a78a04d705b0397030572c3bbd03c35d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 5 Jan 2015 21:26:30 -0500 Subject: [PATCH 099/306] Add NOINLINE to tpgState This is actually not critical, because having multiple database connections is hardly the end of the world, but it does confuse useTPGDatabase. --- Database/PostgreSQL/Typed/TH.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 1034ac6..9651ca9 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -57,9 +57,11 @@ getTPGDatabase = do , pgDBDebug = debug } +{-# NOINLINE tpgState #-} tpgState :: MVar (PGDatabase, Maybe TPGState) -tpgState = unsafePerformIO $ - newMVar (unsafePerformIO getTPGDatabase, Nothing) +tpgState = unsafePerformIO $ do + db <- unsafeInterleaveIO getTPGDatabase + newMVar (db, Nothing) data TPGState = TPGState { tpgConnection :: PGConnection From eca0644b5e760f221fbc4da7ed7343c833cb534c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 5 Jan 2015 23:55:36 -0500 Subject: [PATCH 100/306] Very basic (and un-useful) support for record types Still considering approaches to make more generic typed instances. --- Database/PostgreSQL/Typed/Types.hs | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index f1a8eae..4d13c4b 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -17,9 +17,10 @@ module Database.PostgreSQL.Typed.Types -- * Marshalling classes , PGParameter(..) - , PGBinaryParameter , PGColumn(..) , PGBinaryType + , PGBinaryParameter(..) + , PGBinaryColumn(..) -- * Marshalling utilities , pgEncodeParameter @@ -48,7 +49,7 @@ 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.List (intersperse, intercalate) import Data.Maybe (fromMaybe) import Data.Monoid ((<>), mconcat, mempty) import Data.Ratio ((%), numerator, denominator) @@ -585,6 +586,28 @@ instance PGColumn "uuid" UUID.UUID where pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u #endif +-- |Generic class of composite (row or record) types. +class KnownSymbol t => PGRecordType t +instance PGRecordType t => PGParameter t [Maybe PGTextValue] where + pgEncode _ l = + buildBS $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (dQuote "(),")) l) <> BSB.char7 ')' where + pgLiteral _ l = + "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where +instance PGRecordType t => PGColumn t [Maybe PGTextValue] where + pgDecode _ = either (error . ("pgDecode record: " ++) . show) id . P.parse pa "record" where + pa = do + l <- P.between (P.char '(') (P.char ')') $ + P.sepBy nel (P.char ',') + _ <- P.eof + return l + nel = P.optionMaybe $ P.between P.spaces P.spaces el + el = BSC.pack <$> parseDQuote "()," + +-- |The generic anonymous record type, as created by @ROW@. +-- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). +instance PGRecordType "record" + + #ifdef 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 From ee5c1baf81c805c28fe0c4ba0f25429d7ad76d80 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 7 Jan 2015 15:16:51 -0500 Subject: [PATCH 101/306] Strengthen OID caveat, since we do store OIDs --- Database/PostgreSQL/Typed.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index 336a569..18677e1 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -195,9 +195,8 @@ import Database.PostgreSQL.Typed.Query -- 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. +-- Furthermore, prepared queries also store OIDs for user types, so the generated 'PGPreparedQuery' can only be run on the exact same database or one restored from a dump with OIDs (@pg_dump -o@). If this is a concern, only use built-in types in prepared queries. +-- (This requirement could be weakened with some work, if there were need.) -- $tips -- If you find yourself pattern matching on result tuples just to pass them on From 2f15aff735b7b942515e689fd1aea9b2747523ad Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 7 Jan 2015 15:57:06 -0500 Subject: [PATCH 102/306] Split array into separate module and relocate range support At the cost of a couple orphans, but if I make a custom array type (as will be necessary for multi-dim arrays) this should go away. --- Database/PostgreSQL/Typed/Array.hs | 120 ++++++++++++++++++++ Database/PostgreSQL/Typed/Range.hs | 54 ++++++++- Database/PostgreSQL/Typed/Types.hs | 172 +++-------------------------- postgresql-typed.cabal | 1 + test/Main.hs | 1 + 5 files changed, 190 insertions(+), 158 deletions(-) create mode 100644 Database/PostgreSQL/Typed/Array.hs diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs new file mode 100644 index 0000000..fd4dd88 --- /dev/null +++ b/Database/PostgreSQL/Typed/Array.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds #-} +-- | +-- Module: Database.PostgreSQL.Typed.Array +-- Copyright: 2015 Dylan Simon +-- +-- Representaion of PostgreSQL's array type. +-- Currently this only supports one-dimensional arrays. +-- PostgreSQL arrays in theory can dynamically be any (rectangular) shape. + +module Database.PostgreSQL.Typed.Array where + +import Control.Applicative ((<$>), (<$)) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as BSC +import Data.List (intersperse) +import Data.Monoid ((<>), mconcat) +import GHC.TypeLits (KnownSymbol) +import qualified Text.Parsec as P + +import Database.PostgreSQL.Typed.Types + +-- |The cannonical representation of a PostgreSQL array of any type, which may always contain NULLs. +-- Currenly only one-dimetional arrays are supported, although in PostgreSQL, any array may be of any dimentionality. +type PGArray a = [Maybe a] + +-- |Class indicating that the first PostgreSQL type is an array of the second. +-- This implies 'PGParameter' and 'PGColumn' instances that will work for any type using comma as a delimiter (i.e., anything but @box@). +-- This will only work with 1-dimensional arrays. +class (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 = buildPGValue $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where + el Nothing = BSB.string7 "null" + el (Just e) = pgDQuote (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 <$> parsePGDQuote (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" + + diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 7def048..e9f1f6a 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds #-} -- | -- Module: Database.PostgreSQL.Typed.Range -- Copyright: 2015 Dylan Simon @@ -8,9 +9,15 @@ module Database.PostgreSQL.Typed.Range where -import Control.Applicative ((<$)) +import Control.Applicative ((<$>), (<$)) import Control.Monad (guard) -import Data.Monoid ((<>)) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as BSC +import Data.Monoid ((<>), mempty) +import GHC.TypeLits (KnownSymbol) +import qualified Text.Parsec as P + +import Database.PostgreSQL.Typed.Types data Bound a = Unbounded @@ -139,3 +146,46 @@ 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 + + +-- |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 a) where + pgEncode _ Empty = BSC.pack "empty" + pgEncode tr (Range (Lower l) (Upper u)) = buildPGValue $ + pc '[' '(' l + <> pb (bound l) + <> BSB.char7 ',' + <> pb (bound u) + <> pc ']' ')' u + where + pb Nothing = mempty + pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b + pc c o b = BSB.char7 $ if boundClosed b then c else o +instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where + pgDecode tr = either (error . ("pgDecode range: " ++) . show) id . P.parse per "range" where + per = 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 <$> parsePGDQuote "(),[]" + pc c o = True <$ P.char c P.<|> False <$ P.char o + pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp + mb = maybe Unbounded . Bounded + pr = do + lc <- pc '[' '(' + lb <- pb + _ <- P.char ',' + ub <- pb + uc <- pc ']' ')' + return $ Range (Lower (mb lc lb)) (Upper (mb uc ub)) + +instance 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" + diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 4d13c4b..b56d1c0 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -11,7 +11,6 @@ module Database.PostgreSQL.Typed.Types OID , PGValue(..) , PGValues - , pgQuote , PGTypeName(..) , PGTypeEnv(..) @@ -22,7 +21,7 @@ module Database.PostgreSQL.Typed.Types , PGBinaryParameter(..) , PGBinaryColumn(..) - -- * Marshalling utilities + -- * Marshalling interface , pgEncodeParameter , pgEncodeBinaryParameter , pgEscapeParameter @@ -31,9 +30,11 @@ module Database.PostgreSQL.Typed.Types , pgDecodeBinaryColumn , pgDecodeBinaryColumnNotNull - -- * Specific type support - , PGArrayType - , PGRangeType + -- * Conversion utilities + , pgQuote + , pgDQuote + , parsePGDQuote + , buildPGValue ) where import Control.Applicative ((<$>), (<$)) @@ -78,8 +79,6 @@ 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. @@ -197,13 +196,13 @@ pgQuote = ('\'':) . es where es (c@'\'':r) = c:c:es r es (c:r) = c:es r -buildBS :: BSB.Builder -> BS.ByteString -buildBS = BSL.toStrict . BSB.toLazyByteString +buildPGValue :: BSB.Builder -> BS.ByteString +buildPGValue = 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 +pgDQuote :: String -> BS.ByteString -> BSB.Builder +pgDQuote 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 @@ -211,8 +210,9 @@ dQuote unsafe s 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 +-- |Parse double-quoted values ala 'pgDQuote'. +parsePGDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String +parsePGDQuote 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)) @@ -308,7 +308,7 @@ instance PGStringType "bpchar" -- blank padded encodeBytea :: BSB.Builder -> PGTextValue -encodeBytea h = buildBS $ BSB.string7 "\\x" <> h +encodeBytea h = buildPGValue $ BSB.string7 "\\x" <> h decodeBytea :: PGTextValue -> [Word8] decodeBytea s @@ -438,146 +438,6 @@ instance PGColumn "numeric" Scientific where pgDecode _ = read . BSC.unpack #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 @@ -590,7 +450,7 @@ instance PGColumn "uuid" UUID.UUID where class KnownSymbol t => PGRecordType t instance PGRecordType t => PGParameter t [Maybe PGTextValue] where pgEncode _ l = - buildBS $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (dQuote "(),")) l) <> BSB.char7 ')' where + buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where pgLiteral _ l = "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where instance PGRecordType t => PGColumn t [Maybe PGTextValue] where @@ -601,7 +461,7 @@ instance PGRecordType t => PGColumn t [Maybe PGTextValue] where _ <- P.eof return l nel = P.optionMaybe $ P.between P.spaces P.spaces el - el = BSC.pack <$> parseDQuote "()," + el = BSC.pack <$> parsePGDQuote "()," -- |The generic anonymous record type, as created by @ROW@. -- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 25f36c6..0322fa2 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -60,6 +60,7 @@ Library Database.PostgreSQL.Typed.TH Database.PostgreSQL.Typed.Query Database.PostgreSQL.Typed.Enum + Database.PostgreSQL.Typed.Array Database.PostgreSQL.Typed.Range Database.PostgreSQL.Typed.TemplatePG GHC-Options: -Wall diff --git a/test/Main.hs b/test/Main.hs index ec3b73e..50180f1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,6 +8,7 @@ import System.Exit (exitSuccess, exitFailure) import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types (OID) +import Database.PostgreSQL.Typed.Array () import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum From c6c15802935800df6494d166363cf0081d7534d8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 7 Jan 2015 16:15:55 -0500 Subject: [PATCH 103/306] Add Dynamic with PGRep class Useful when constructing raw queries --- Database/PostgreSQL/Typed/Dynamic.hs | 86 +++++++++++++++++++++++++++ Database/PostgreSQL/Typed/Protocol.hs | 5 +- Database/PostgreSQL/Typed/TH.hs | 5 +- Database/PostgreSQL/Typed/Types.hs | 1 + postgresql-typed.cabal | 1 + 5 files changed, 94 insertions(+), 4 deletions(-) create mode 100644 Database/PostgreSQL/Typed/Dynamic.hs diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs new file mode 100644 index 0000000..97b789a --- /dev/null +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures #-} +-- | +-- Module: Database.PostgreSQL.Typed.Dynamic +-- Copyright: 2015 Dylan Simon +-- +-- Automatic (dynamic) marshalling of PostgreSQL values based on Haskell types (not SQL statements). +-- This is intended for direct construction of queries and query data, bypassing the normal SQL type inference. + +module Database.PostgreSQL.Typed.Dynamic where + +import Data.Int +#ifdef USE_SCIENTIFIC +import Data.Scientific (Scientific) +#endif +#ifdef USE_TEXT +import qualified Data.Text as T +#endif +import qualified Data.Time as Time +#ifdef USE_UUID +import qualified Data.UUID as UUID +#endif +import GHC.TypeLits (KnownSymbol) + +import Database.PostgreSQL.Typed.Types + +-- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling. +class KnownSymbol t => PGRep t a | a -> t where + pgTypeOf :: a -> PGTypeName t + pgTypeOf _ = PGTypeProxy + pgEncodeRep :: a -> PGValue +#ifdef USE_BINARY_NEED_ENV + default pgEncodeRep :: PGBinaryParameter t a => a -> PGValue + pgEncodeRep x = PGBinaryValue $ pgEncodeBinary (pgTypeOf x) x +#else + default pgEncodeRep :: PGParameter t a => a -> PGValue + pgEncodeRep x = PGTextValue $ pgEncode (pgTypeOf x) x +#endif + pgLiteralRep :: a -> String + default pgLiteralRep :: PGParameter t a => a -> String + pgLiteralRep x = pgLiteral (pgTypeOf x) x + pgDecodeRep :: PGValue -> a +#ifdef USE_BINARY_NEED_ENV + default pgDecodeRep :: PGBinaryColumn t a => PGValue -> a + pgDecodeRep (PGBinaryValue v) = pgDecodeBinary (PGTypeProxy :: PGTypeName t) v +#else + default pgDecodeRep :: PGColumn t a => PGValue -> a +#endif + pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName t) v + pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue" + +-- |Produce a safely type-cast literal value for interpolation in a SQL statement. +pgSafeLiteral :: PGRep t a => a -> String +pgSafeLiteral x = pgLiteralRep x ++ "::" ++ pgTypeName (pgTypeOf x) + +instance PGRep t a => PGRep t (Maybe a) where + pgEncodeRep Nothing = PGNullValue + pgEncodeRep (Just x) = pgEncodeRep x + pgLiteralRep Nothing = "NULL" + pgLiteralRep (Just x) = pgLiteralRep x + pgDecodeRep PGNullValue = Nothing + pgDecodeRep v = Just (pgDecodeRep v) + +instance PGRep "boolean" Bool +instance PGRep "oid" OID +instance PGRep "smallint" Int16 +instance PGRep "integer" Int32 +instance PGRep "bigint" Int64 +instance PGRep "real" Float +instance PGRep "double precision" Double +instance PGRep "\"char\"" Char +instance PGRep "text" String +#ifdef USE_TEXT +instance PGRep "text" T.Text +#endif +instance PGRep "date" Time.Day +instance PGRep "time without time zone" Time.TimeOfDay +instance PGRep "timestamp without time zone" Time.LocalTime +instance PGRep "timestamp with time zone" Time.UTCTime +instance PGRep "interval" Time.DiffTime +instance PGRep "numeric" Rational +#ifdef USE_SCIENTIFIC +instance PGRep "numeric" Scientific +#endif +#ifdef USE_UUID +instance PGRep "uuid" UUID.UUID +#endif diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 2e840e2..0096c37 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -53,6 +53,7 @@ import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic data PGState = StateUnknown @@ -501,9 +502,9 @@ pgDescribe h sql types nulls = do | 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) + (_, r) <- pgSimpleQuery h ("SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = " ++ pgSafeLiteral oid ++ " AND attnum = " ++ show col) case Fold.toList r of - [[PGTextValue s]] -> return $ not $ pgDecode (PGTypeProxy :: PGTypeName "boolean") s + [[s]] -> return $ not $ pgDecodeRep s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col | otherwise = return True diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 9651ca9..2b4c89c 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -32,6 +32,7 @@ import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol -- |A particular PostgreSQL type, identified by full formatted name (from @format_type@ or @\\dT@). @@ -72,8 +73,8 @@ 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 + return $ tpg{ tpgTypes = IntMap.fromAscList $ map (\[to, tn] -> + (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) $ Fold.toList $ snd tl } tpgInit :: PGConnection -> IO TPGState diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index b56d1c0..3cedf52 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -12,6 +12,7 @@ module Database.PostgreSQL.Typed.Types , PGValue(..) , PGValues , PGTypeName(..) + , pgTypeName , PGTypeEnv(..) -- * Marshalling classes diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0322fa2..fa899f6 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -62,6 +62,7 @@ Library Database.PostgreSQL.Typed.Enum Database.PostgreSQL.Typed.Array Database.PostgreSQL.Typed.Range + Database.PostgreSQL.Typed.Dynamic Database.PostgreSQL.Typed.TemplatePG GHC-Options: -Wall if flag(md5) From c1b206b2969c608be8ee9b5e70d82fcaf3282c26 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 7 Jan 2015 16:26:04 -0500 Subject: [PATCH 104/306] Bump version for eventual next release --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index fa899f6..7ebda9d 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.3.0 +Version: 0.3.1 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From 088ebcd95e9b7ae7fd20cd36cbbd2fca705205a6 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 7 Jan 2015 23:29:00 -0500 Subject: [PATCH 105/306] Have makePGEnum create PGRep instance --- Database/PostgreSQL/Typed/Enum.hs | 7 +++++-- Database/PostgreSQL/Typed/Query.hs | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 11f7bd1..8ec48c5 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -19,6 +19,7 @@ import qualified Language.Haskell.TH as TH import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TH import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic -- |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 @@ -45,10 +46,10 @@ makePGEnum name typs valnf = do 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.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `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.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `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 ++ @@ -56,7 +57,9 @@ makePGEnum name typs valnf = do TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE ds)) []]) []] ] + , TH.InstanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) [] ] where typn = TH.mkName typs typt = TH.ConT typn + typl = TH.LitT (TH.StrTyLit name) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index a4e1691..4b9ba27 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -143,7 +143,7 @@ splitCommas = spl where trim :: String -> String trim = dropWhileEnd isSpace . dropWhile isSpace --- |Flags affecting how and what type of query to build with 'makeQuery'. +-- |Flags affecting how and what type of query to build with 'makePGQuery'. 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). From 22e4b90129e5183a0e4562383910c717f68d56ab Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 8 Jan 2015 21:52:14 -0500 Subject: [PATCH 106/306] Fix pgSync protocol state management Previously if two queries were sent in rapid succession before the ReadyForQuery response came back, it would trigger an unexpected ReadyForQuery. --- Database/PostgreSQL/Typed/Protocol.hs | 15 +++++++++++---- Database/PostgreSQL/Typed/Query.hs | 2 +- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 0096c37..27c4988 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -56,10 +56,13 @@ import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic data PGState - = StateUnknown + = StateUnknown -- no Sync + | StatePending -- Sync sent + -- ReadyForQuery received: | StateIdle | StateTransaction | StateTransactionFailed + -- Terminate sent or EOF received | StateClosed deriving (Show, Eq) @@ -260,7 +263,7 @@ 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 + writeIORef sr (case msg of Sync -> StatePending ; _ -> 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 @@ -452,8 +455,12 @@ pgReconnect c@PGConnection{ connDatabase = cd, connState = cs } d = do 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 + case s of + StateClosed -> fail "pgSync: operation on closed connection" + StatePending -> wait True + StateUnknown -> wait False + _ -> return () + where wait s = do r <- pgRecv s c case r of diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 4b9ba27..6643937 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -159,7 +159,7 @@ 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" + 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 From adc8531f3122fad0053da4f2490c5c243186fe8c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 9 Jan 2015 00:03:21 -0500 Subject: [PATCH 107/306] Fix pgDecodeBinaryColumnNotNull, adding PGBinaryColumnNotNull --- Database/PostgreSQL/Typed/Types.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 3cedf52..8c15656 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -133,6 +133,8 @@ class PGParameterNull t a => PGBinaryParameterNull t a where -- |Support decoding of assumed non-null columns but also still allow decoding into 'Maybe'. class PGColumnNotNull t a where pgDecodeNotNull :: PGTypeName t -> PGValue -> a +class PGColumnNotNull t a => PGBinaryColumnNotNull t a where + pgDecodeBinaryNotNull :: PGTypeEnv -> PGTypeName t -> PGValue -> a instance PGParameter t a => PGParameterNull t a where @@ -154,6 +156,12 @@ 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 +instance PGBinaryColumn t a => PGBinaryColumnNotNull t a where + pgDecodeBinaryNotNull e t (PGBinaryValue v) = pgDecodeBinary e t v + pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v +instance PGBinaryColumn t a => PGBinaryColumnNotNull t (Maybe a) where + pgDecodeBinaryNotNull e t (PGBinaryValue v) = Just $ pgDecodeBinary e t v + pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v -- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. @@ -178,13 +186,11 @@ 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 +pgDecodeBinaryColumn = pgDecodeBinaryNotNull -- |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 +pgDecodeBinaryColumnNotNull :: PGBinaryColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGValue -> a +pgDecodeBinaryColumnNotNull = pgDecodeBinaryNotNull pgQuoteUnsafe :: String -> String From d95921788675412df5cf89aa35a435564205e80e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 9 Jan 2015 10:02:18 -0500 Subject: [PATCH 108/306] Allow arbitrarily nested Maybes on parameters and columns I'm not entirely happy with this, but it seems to still make it through type inference, and I can't think of a reasonable PostgreSQL representation for Maybe Nothing to cause ambiguity. It does make writing generic decoding wrappers a lot easier. (No use case for the parameters, yet, but for consistency.) --- Database/PostgreSQL/Typed/Types.hs | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 8c15656..c28c3d6 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -140,27 +140,26 @@ class PGColumnNotNull t a => PGBinaryColumnNotNull t a where 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 PGParameterNull t a => PGParameterNull t (Maybe a) where + pgEncodeNull t = maybe PGNullValue (pgEncodeNull t) + pgLiteralNull = maybe "NULL" . pgLiteralNull 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 PGBinaryParameterNull t a => PGBinaryParameterNull t (Maybe a) where + pgEncodeBinaryNull e t = maybe PGNullValue (pgEncodeBinaryNull 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 +instance PGColumnNotNull 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 + pgDecodeNotNull t v = Just $ pgDecodeNotNull t v instance PGBinaryColumn t a => PGBinaryColumnNotNull t a where pgDecodeBinaryNotNull e t (PGBinaryValue v) = pgDecodeBinary e t v pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v -instance PGBinaryColumn t a => PGBinaryColumnNotNull t (Maybe a) where - pgDecodeBinaryNotNull e t (PGBinaryValue v) = Just $ pgDecodeBinary e t v +instance PGBinaryColumnNotNull t a => PGBinaryColumnNotNull t (Maybe a) where + pgDecodeBinaryNotNull e t (PGBinaryValue v) = Just $ pgDecodeBinaryNotNull e t (PGBinaryValue v) pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v @@ -185,7 +184,7 @@ pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGV 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 :: PGBinaryColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a pgDecodeBinaryColumn = pgDecodeBinaryNotNull -- |Final column decoding function used for a non-nullable binary-encoded result value. From 439f12a7381226159d3c7e96f400cb45b79023a7 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 9 Jan 2015 23:45:10 -0500 Subject: [PATCH 109/306] Revert "Allow arbitrarily nested Maybes on parameters and columns" This reverts commit d95921788675412df5cf89aa35a435564205e80e. --- Database/PostgreSQL/Typed/Types.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index c28c3d6..8c15656 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -140,26 +140,27 @@ class PGColumnNotNull t a => PGBinaryColumnNotNull t a where instance PGParameter t a => PGParameterNull t a where pgEncodeNull t = PGTextValue . pgEncode t pgLiteralNull = pgLiteral -instance PGParameterNull t a => PGParameterNull t (Maybe a) where - pgEncodeNull t = maybe PGNullValue (pgEncodeNull t) - pgLiteralNull = maybe "NULL" . pgLiteralNull +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 PGBinaryParameterNull t a => PGBinaryParameterNull t (Maybe a) where - pgEncodeBinaryNull e t = maybe PGNullValue (pgEncodeBinaryNull 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 PGColumnNotNull t a => PGColumnNotNull t (Maybe a) where +instance PGColumn t a => PGColumnNotNull t (Maybe a) where pgDecodeNotNull _ PGNullValue = Nothing - pgDecodeNotNull t v = Just $ pgDecodeNotNull t v + pgDecodeNotNull t (PGTextValue v) = Just $ pgDecode t v + pgDecodeNotNull t (PGBinaryValue _) = error $ "pgDecode: unexpected binary value in " ++ pgTypeName t instance PGBinaryColumn t a => PGBinaryColumnNotNull t a where pgDecodeBinaryNotNull e t (PGBinaryValue v) = pgDecodeBinary e t v pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v -instance PGBinaryColumnNotNull t a => PGBinaryColumnNotNull t (Maybe a) where - pgDecodeBinaryNotNull e t (PGBinaryValue v) = Just $ pgDecodeBinaryNotNull e t (PGBinaryValue v) +instance PGBinaryColumn t a => PGBinaryColumnNotNull t (Maybe a) where + pgDecodeBinaryNotNull e t (PGBinaryValue v) = Just $ pgDecodeBinary e t v pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v @@ -184,7 +185,7 @@ pgDecodeColumnNotNull :: PGColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGV pgDecodeColumnNotNull _ = pgDecodeNotNull -- |Final column decoding function used for a nullable binary-encoded result value. -pgDecodeBinaryColumn :: PGBinaryColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a +pgDecodeBinaryColumn :: PGBinaryColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a pgDecodeBinaryColumn = pgDecodeBinaryNotNull -- |Final column decoding function used for a non-nullable binary-encoded result value. From eb3423bed0c398f7e6f049c0aae6e9b76a3ff74b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 10 Jan 2015 00:39:48 -0500 Subject: [PATCH 110/306] Use prepared query for notnull checking To improve performance --- Database/PostgreSQL/Typed/Protocol.hs | 11 ++++++----- Database/PostgreSQL/Typed/Types.hs | 5 +++++ 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 27c4988..906225f 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -41,6 +41,7 @@ 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 Data.Int (Int32, Int16) import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) @@ -97,9 +98,9 @@ data PGConnection = PGConnection data ColDescription = ColDescription { colName :: String , colTable :: !OID - , colNumber :: !Int + , colNumber :: !Int16 , colType :: !OID - , colModifier :: !Word32 + , colModifier :: !Int32 , colBinary :: !Bool } deriving (Show) @@ -310,7 +311,7 @@ getMessageBody 'T' = do , colTable = oid , colNumber = fromIntegral col , colType = typ' - , colModifier = tmod + , colModifier = fromIntegral tmod , colBinary = toEnum (fromIntegral fmt) } getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where @@ -397,7 +398,7 @@ pgConnect db = do , connParameters = Map.empty , connPreparedStatements = prep , connState = state - , connTypeEnv = undefined + , connTypeEnv = unknownPGTypeEnv , connInput = input } pgSend c $ StartupMessage @@ -509,7 +510,7 @@ pgDescribe h sql types nulls = do | 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 = " ++ pgSafeLiteral oid ++ " AND attnum = " ++ show col) + (_, r) <- pgPreparedQuery h "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] case Fold.toList r of [[s]] -> return $ not $ pgDecodeRep s [] -> return True diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 8c15656..7fc43ce 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -14,6 +14,7 @@ module Database.PostgreSQL.Typed.Types , PGTypeName(..) , pgTypeName , PGTypeEnv(..) + , unknownPGTypeEnv -- * Marshalling classes , PGParameter(..) @@ -105,6 +106,10 @@ data PGTypeEnv = PGTypeEnv { pgIntegerDatetimes :: Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. } +unknownPGTypeEnv :: PGTypeEnv +unknownPGTypeEnv = PGTypeEnv + { pgIntegerDatetimes = error "current setting of pgIntegerDatetimes is unknown" } + -- |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. From ac893efab556d7a8a4124a38c86058ce5e6d3d6f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 10 Jan 2015 01:18:37 -0500 Subject: [PATCH 111/306] Fold PGBinaryParameter into PGParameter Since we can just dynamically use binary encoding whenever available. Also make PGTypeEnv more explicit about unknown settings (so we can fall back to text encoding). Next to figure this out for decoding... --- Database/PostgreSQL/Typed/Dynamic.hs | 35 +++-- Database/PostgreSQL/Typed/Protocol.hs | 2 +- Database/PostgreSQL/Typed/TH.hs | 4 +- Database/PostgreSQL/Typed/Types.hs | 182 ++++++++++++++------------ 4 files changed, 116 insertions(+), 107 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 97b789a..b0e83d3 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -28,20 +28,15 @@ class KnownSymbol t => PGRep t a | a -> t where pgTypeOf :: a -> PGTypeName t pgTypeOf _ = PGTypeProxy pgEncodeRep :: a -> PGValue -#ifdef USE_BINARY_NEED_ENV - default pgEncodeRep :: PGBinaryParameter t a => a -> PGValue - pgEncodeRep x = PGBinaryValue $ pgEncodeBinary (pgTypeOf x) x -#else default pgEncodeRep :: PGParameter t a => a -> PGValue - pgEncodeRep x = PGTextValue $ pgEncode (pgTypeOf x) x -#endif + pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x pgLiteralRep :: a -> String default pgLiteralRep :: PGParameter t a => a -> String pgLiteralRep x = pgLiteral (pgTypeOf x) x pgDecodeRep :: PGValue -> a -#ifdef USE_BINARY_NEED_ENV +#ifdef USE_BINARY_XXX default pgDecodeRep :: PGBinaryColumn t a => PGValue -> a - pgDecodeRep (PGBinaryValue v) = pgDecodeBinary (PGTypeProxy :: PGTypeName t) v + pgDecodeRep (PGBinaryValue v) = pgDecodeBinary unknownPGTypeEnv (PGTypeProxy :: PGTypeName t) v #else default pgDecodeRep :: PGColumn t a => PGValue -> a #endif @@ -60,17 +55,17 @@ instance PGRep t a => PGRep t (Maybe a) where pgDecodeRep PGNullValue = Nothing pgDecodeRep v = Just (pgDecodeRep v) -instance PGRep "boolean" Bool -instance PGRep "oid" OID -instance PGRep "smallint" Int16 -instance PGRep "integer" Int32 -instance PGRep "bigint" Int64 -instance PGRep "real" Float -instance PGRep "double precision" Double -instance PGRep "\"char\"" Char -instance PGRep "text" String +instance PGRep "boolean" Bool where +instance PGRep "oid" OID where +instance PGRep "smallint" Int16 where +instance PGRep "integer" Int32 where +instance PGRep "bigint" Int64 where +instance PGRep "real" Float where +instance PGRep "double precision" Double where +instance PGRep "\"char\"" Char where +instance PGRep "text" String where #ifdef USE_TEXT -instance PGRep "text" T.Text +instance PGRep "text" T.Text where #endif instance PGRep "date" Time.Day instance PGRep "time without time zone" Time.TimeOfDay @@ -79,8 +74,8 @@ instance PGRep "timestamp with time zone" Time.UTCTime instance PGRep "interval" Time.DiffTime instance PGRep "numeric" Rational #ifdef USE_SCIENTIFIC -instance PGRep "numeric" Scientific +instance PGRep "numeric" Scientific where #endif #ifdef USE_UUID -instance PGRep "uuid" UUID.UUID +instance PGRep "uuid" UUID.UUID where #endif diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 906225f..1c25804 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -416,7 +416,7 @@ pgConnect db = do conn c = pgReceive c >>= msg c msg c (ReadyForQuery _) = return c { connTypeEnv = PGTypeEnv - { pgIntegerDatetimes = (connParameters c Map.! "integer_datetimes") == "on" + { pgIntegerDatetimes = fmap ("on" ==) $ Map.lookup "integer_datetimes" (connParameters c) } } msg c (BackendKeyData p k) = conn c{ connPid = p, connKey = k } diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 2b4c89c..e728f9b 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -165,7 +165,7 @@ tpgDescribe sql types nulls = do ) #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) + (,) pv <$> fillBin rv where fillBin = mapM (\i -> do b <- tpgTypeIsBinary (tpgValueType i) @@ -186,7 +186,7 @@ typeApply t f e v = 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 + else 'pgEncodeParameter -- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Name -> TH.Exp diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 7fc43ce..b6fbe81 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -20,12 +20,10 @@ module Database.PostgreSQL.Typed.Types , PGParameter(..) , PGColumn(..) , PGBinaryType - , PGBinaryParameter(..) , PGBinaryColumn(..) -- * Marshalling interface , pgEncodeParameter - , pgEncodeBinaryParameter , pgEscapeParameter , pgDecodeColumn , pgDecodeColumnNotNull @@ -86,8 +84,8 @@ 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. + | PGTextValue { pgTextValue :: PGTextValue } -- ^ The standard text encoding format (also used for unknown formats) + | PGBinaryValue { pgBinaryValue :: PGBinaryValue } -- ^ Special binary-encoded data. Not supported in all cases. deriving (Show, Eq) -- |A list of (nullable) data values, e.g. a single row or query parameters. type PGValues = [PGValue] @@ -102,24 +100,29 @@ pgTypeName = symbolVal -- |Parameters that affect how marshalling happens. -- Currenly we force all other relevant parameters at connect time. +-- Nothing values represent unknown. data PGTypeEnv = PGTypeEnv - { pgIntegerDatetimes :: Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. + { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. } unknownPGTypeEnv :: PGTypeEnv unknownPGTypeEnv = PGTypeEnv - { pgIntegerDatetimes = error "current setting of pgIntegerDatetimes is unknown" } + { pgIntegerDatetimes = Nothing + } -- |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 + pgEncode t = pgTextValue . pgEncodeValue unknownPGTypeEnv t -- |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 + -- |Encode a value to a PostgreSQL representation. + -- Defaults to the text representation by pgEncode + pgEncodeValue :: PGTypeEnv -> PGTypeName t -> a -> PGValue + pgEncodeValue _ t = PGTextValue . pgEncode t -- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@. class KnownSymbol t => PGColumn (t :: Symbol) a where @@ -128,13 +131,6 @@ class KnownSymbol t => PGColumn (t :: Symbol) a where 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 @@ -142,16 +138,9 @@ class PGColumnNotNull t a => PGBinaryColumnNotNull t a where pgDecodeBinaryNotNull :: PGTypeEnv -> 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 PGParameter t a => PGParameter t (Maybe a) where + pgLiteral = maybe "NULL" . pgLiteral + pgEncodeValue e = maybe PGNullValue . pgEncodeValue e instance PGColumn t a => PGColumnNotNull t a where pgDecodeNotNull t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)" @@ -170,16 +159,12 @@ instance PGBinaryColumn t a => PGBinaryColumnNotNull t (Maybe a) where -- |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 +pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> PGValue +pgEncodeParameter = pgEncodeValue -- |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 +pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> String +pgEscapeParameter _ = pgLiteral -- |Final column decoding function used for a nullable result value. pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a @@ -235,6 +220,9 @@ instance PGParameter "boolean" Bool where pgEncode _ True = BSC.singleton 't' pgLiteral _ False = "false" pgLiteral _ True = "true" +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.bool +#endif instance PGColumn "boolean" Bool where pgDecode _ s = case BSC.head s of 'f' -> False @@ -245,41 +233,62 @@ type OID = Word32 instance PGParameter "oid" OID where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.int4 . Right +#endif instance PGColumn "oid" OID where pgDecode _ = read . BSC.unpack instance PGParameter "smallint" Int16 where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.int2 . Left +#endif instance PGColumn "smallint" Int16 where pgDecode _ = read . BSC.unpack instance PGParameter "integer" Int32 where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.int4 . Left +#endif instance PGColumn "integer" Int32 where pgDecode _ = read . BSC.unpack instance PGParameter "bigint" Int64 where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.int8 . Left +#endif instance PGColumn "bigint" Int64 where pgDecode _ = read . BSC.unpack instance PGParameter "real" Float where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.float4 +#endif instance PGColumn "real" Float where pgDecode _ = read . BSC.unpack instance PGParameter "double precision" Double where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.float8 +#endif instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.char +#endif instance PGColumn "\"char\"" Char where pgDecode _ = BSC.head @@ -288,34 +297,49 @@ class KnownSymbol t => PGStringType t instance PGStringType t => PGParameter t String where pgEncode _ = BSU.fromString +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.text . Left . T.pack +#endif instance PGStringType t => PGColumn t String where pgDecode _ = BSU.toString instance PGStringType t => PGParameter t BS.ByteString where pgEncode _ = id +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.text . Left . TE.decodeUtf8 +#endif instance PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id instance PGStringType t => PGParameter t BSL.ByteString where pgEncode _ = BSL.toStrict +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.text . Right . TLE.decodeUtf8 +#endif 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 +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.text . Left +#endif instance PGStringType t => PGColumn t T.Text where pgDecode _ = TE.decodeUtf8 instance PGStringType t => PGParameter t TL.Text where pgEncode _ = BSL.toStrict . TLE.encodeUtf8 +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.text . Right +#endif 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 "name" -- limit 63 characters; not strictly textsend but essentially the same instance PGStringType "bpchar" -- blank padded @@ -336,29 +360,47 @@ decodeBytea s instance PGParameter "bytea" BSL.ByteString where pgEncode _ = encodeBytea . BSB.lazyByteStringHex pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.bytea . Right +#endif 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 +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.bytea . Left +#endif 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 +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.date +#endif instance PGColumn "date" Time.Day where pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack +binEncDatetime :: PGParameter t a => (Bool -> a -> PGBinaryValue) -> PGTypeEnv -> PGTypeName t -> a -> PGValue +binEncDatetime f e t = maybe (PGTextValue . pgEncode t) ((PGBinaryValue .) . f) (pgIntegerDatetimes e) + instance PGParameter "time without time zone" Time.TimeOfDay where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q" +#ifdef USE_BINARY + pgEncodeValue = binEncDatetime BinE.time +#endif 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" +#ifdef USE_BINARY + pgEncodeValue = binEncDatetime BinE.timestamp +#endif instance PGColumn "timestamp without time zone" Time.LocalTime where pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack @@ -375,12 +417,18 @@ 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" +#ifdef USE_BINARY + pgEncodeValue = binEncDatetime BinE.timestamptz +#endif 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 +#ifdef USE_BINARY + pgEncodeValue = binEncDatetime BinE.interval +#endif -- |Representation of DiffTime as interval. -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. -- We collapse all interval fields into seconds @@ -424,6 +472,9 @@ instance PGParameter "numeric" Rational where pgLiteral _ r | denominator r == 0 = "'NaN'" -- this can't happen | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.numeric . realToFrac +#endif -- |High-precision representation of Rational as numeric. -- Unfortunately, numeric has an NaN, while Rational does not. -- NaN numeric values will produce exceptions. @@ -446,6 +497,9 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where instance PGParameter "numeric" Scientific where pgEncode _ = BSC.pack . show pgLiteral _ = show +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.numeric +#endif instance PGColumn "numeric" Scientific where pgDecode _ = read . BSC.unpack #endif @@ -454,6 +508,9 @@ instance PGColumn "numeric" Scientific where instance PGParameter "uuid" UUID.UUID where pgEncode _ = UUID.toASCIIBytes pgLiteral _ = pgQuoteUnsafe . UUID.toString +#ifdef USE_BINARY + pgEncodeValue _ _ = PGBinaryValue . BinE.uuid +#endif instance PGColumn "uuid" UUID.UUID where pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u #endif @@ -485,54 +542,36 @@ 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 @@ -540,72 +579,47 @@ 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 +binDecDatetime :: KnownSymbol t => (Bool -> BinD.D a) -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a +binDecDatetime f e = binDec $ f $ fromMaybe (error "pgDecodeBinary: unknown integer_datetimes value") $ pgIntegerDatetimes e + 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) + pgDecodeBinary = binDecDatetime BinD.time 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) + pgDecodeBinary = binDecDatetime BinD.timestamp 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) + pgDecodeBinary = binDecDatetime BinD.timestamptz 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) + pgDecodeBinary = binDecDatetime BinD.interval 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 From 64fe3f5708099eae4d77ed9622c7070c4d0d59df Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 10 Jan 2015 12:15:32 -0500 Subject: [PATCH 112/306] Fold PGBinaryColumn into PGColumn Introduced PGType class to support this, also allowing run-time determination of binary support. --- Database/PostgreSQL/Typed.hs | 13 +- Database/PostgreSQL/Typed/Array.hs | 203 ++++++++++------ Database/PostgreSQL/Typed/Dynamic.hs | 3 +- Database/PostgreSQL/Typed/Enum.hs | 1 + Database/PostgreSQL/Typed/Query.hs | 37 ++- Database/PostgreSQL/Typed/Range.hs | 10 +- Database/PostgreSQL/Typed/TH.hs | 87 +++---- Database/PostgreSQL/Typed/Types.hs | 333 +++++++++++---------------- 8 files changed, 351 insertions(+), 336 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index 18677e1..c27e6d7 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -163,15 +163,24 @@ import Database.PostgreSQL.Typed.Query -- 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). --- Currently only 1-dimensional arrays are supported. -- -- However you can add support for your own types or add flexibility to existing types by creating new instances of 'Database.PostgreSQL.Typed.Types.PGParameter' (for encoding) and 'Database.PostgreSQL.Typed.Types.PGColumn' (for decoding). --- If you also want to support arrays of a new type, you should also provide a 'Database.PostgreSQL.Typed.Types.PGArrayType' instance (or 'Database.PostgreSQL.Typed.Types.PGRangeType' for new ranges): -- +-- > instance PGType "mytype" -- > instance PGParameter "mytype" MyType where -- > pgEncode _ (v :: MyType) = ... :: ByteString -- > instance PGColumn "mytype" MyType where -- > pgDecode _ (s :: ByteString) = ... :: MyType +-- +-- You can make as many 'PGParameter' and 'PGColumn' instances as you want if you want to support different representations of your type. +-- If you want to use any of the functions in "Database.PostgreSQL.Typed.Dynamic", however, such as 'Database.PostgreSQL.Typed.Dynamic.pgSafeLiteral', you must define a default representation: +-- +-- > instance PGRep "mytype" MyType +-- +-- If you want to support arrays of your new type, you should also provide a 'Database.PostgreSQL.Typed.Array.PGArrayType' instance (or 'Database.PostgreSQL.Typed.Range.PGRangeType' for new ranges). +-- Currently only 1-dimensional arrays are supported. +-- +-- > instance PGType "mytype[]" -- > instance PGArrayType "mytype[]" "mytype" -- -- Required language extensions: FlexibleInstances, MultiParamTypeClasses, DataKinds diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index fd4dd88..920c552 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Array -- Copyright: 2015 Dylan Simon @@ -14,7 +15,6 @@ import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC import Data.List (intersperse) import Data.Monoid ((<>), mconcat) -import GHC.TypeLits (KnownSymbol) import qualified Text.Parsec as P import Database.PostgreSQL.Typed.Types @@ -26,7 +26,7 @@ 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 +class (PGType ta, PGType 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@). @@ -49,72 +49,137 @@ instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where el = pgDecode (pgArrayElementType ta) . BSC.pack <$> parsePGDQuote (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 +instance PGType "boolean" => PGType "boolean[]" +instance PGType "boolean" => PGArrayType "boolean[]" "boolean" +instance PGType "bytea" => PGType "bytea[]" +instance PGType "bytea" => PGArrayType "bytea[]" "bytea" +instance PGType "\"char\"" => PGType "\"char\"[]" +instance PGType "\"char\"" => PGArrayType "\"char\"[]" "\"char\"" +instance PGType "name" => PGType "name[]" +instance PGType "name" => PGArrayType "name[]" "name" +instance PGType "bigint" => PGType "bigint[]" +instance PGType "bigint" => PGArrayType "bigint[]" "bigint" +instance PGType "smallint" => PGType "smallint[]" +instance PGType "smallint" => PGArrayType "smallint[]" "smallint" +instance PGType "int2vector" => PGType "int2vector[]" +instance PGType "int2vector" => PGArrayType "int2vector[]" "int2vector" +instance PGType "integer" => PGType "integer[]" +instance PGType "integer" => PGArrayType "integer[]" "integer" +instance PGType "regproc" => PGType "regproc[]" +instance PGType "regproc" => PGArrayType "regproc[]" "regproc" +instance PGType "text" => PGType "text[]" +instance PGType "text" => PGArrayType "text[]" "text" +instance PGType "oid" => PGType "oid[]" +instance PGType "oid" => PGArrayType "oid[]" "oid" +instance PGType "tid" => PGType "tid[]" +instance PGType "tid" => PGArrayType "tid[]" "tid" +instance PGType "xid" => PGType "xid[]" +instance PGType "xid" => PGArrayType "xid[]" "xid" +instance PGType "cid" => PGType "cid[]" +instance PGType "cid" => PGArrayType "cid[]" "cid" +instance PGType "oidvector" => PGType "oidvector[]" +instance PGType "oidvector" => PGArrayType "oidvector[]" "oidvector" +instance PGType "json" => PGType "json[]" +instance PGType "json" => PGArrayType "json[]" "json" +instance PGType "xml" => PGType "xml[]" +instance PGType "xml" => PGArrayType "xml[]" "xml" +instance PGType "point" => PGType "point[]" +instance PGType "point" => PGArrayType "point[]" "point" +instance PGType "lseg" => PGType "lseg[]" +instance PGType "lseg" => PGArrayType "lseg[]" "lseg" +instance PGType "path" => PGType "path[]" +instance PGType "path" => PGArrayType "path[]" "path" +instance PGType "box" => PGType "box[]" +instance PGType "box" => 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" - +instance PGType "polygon" => PGType "polygon[]" +instance PGType "polygon" => PGArrayType "polygon[]" "polygon" +instance PGType "line" => PGType "line[]" +instance PGType "line" => PGArrayType "line[]" "line" +instance PGType "cidr" => PGType "cidr[]" +instance PGType "cidr" => PGArrayType "cidr[]" "cidr" +instance PGType "real" => PGType "real[]" +instance PGType "real" => PGArrayType "real[]" "real" +instance PGType "double precision" => PGType "double precision[]" +instance PGType "double precision" => PGArrayType "double precision[]" "double precision" +instance PGType "abstime" => PGType "abstime[]" +instance PGType "abstime" => PGArrayType "abstime[]" "abstime" +instance PGType "reltime" => PGType "reltime[]" +instance PGType "reltime" => PGArrayType "reltime[]" "reltime" +instance PGType "tinterval" => PGType "tinterval[]" +instance PGType "tinterval" => PGArrayType "tinterval[]" "tinterval" +instance PGType "circle" => PGType "circle[]" +instance PGType "circle" => PGArrayType "circle[]" "circle" +instance PGType "money" => PGType "money[]" +instance PGType "money" => PGArrayType "money[]" "money" +instance PGType "macaddr" => PGType "macaddr[]" +instance PGType "macaddr" => PGArrayType "macaddr[]" "macaddr" +instance PGType "inet" => PGType "inet[]" +instance PGType "inet" => PGArrayType "inet[]" "inet" +instance PGType "aclitem" => PGType "aclitem[]" +instance PGType "aclitem" => PGArrayType "aclitem[]" "aclitem" +instance PGType "bpchar" => PGType "bpchar[]" +instance PGType "bpchar" => PGArrayType "bpchar[]" "bpchar" +instance PGType "character varying" => PGType "character varying[]" +instance PGType "character varying" => PGArrayType "character varying[]" "character varying" +instance PGType "date" => PGType "date[]" +instance PGType "date" => PGArrayType "date[]" "date" +instance PGType "time without time zone" => PGType "time without time zone[]" +instance PGType "time without time zone" => PGArrayType "time without time zone[]" "time without time zone" +instance PGType "timestamp without time zone" => PGType "timestamp without time zone[]" +instance PGType "timestamp without time zone" => PGArrayType "timestamp without time zone[]" "timestamp without time zone" +instance PGType "timestamp with time zone" => PGType "timestamp with time zone[]" +instance PGType "timestamp with time zone" => PGArrayType "timestamp with time zone[]" "timestamp with time zone" +instance PGType "interval" => PGType "interval[]" +instance PGType "interval" => PGArrayType "interval[]" "interval" +instance PGType "time with time zone" => PGType "time with time zone[]" +instance PGType "time with time zone" => PGArrayType "time with time zone[]" "time with time zone" +instance PGType "bit" => PGType "bit[]" +instance PGType "bit" => PGArrayType "bit[]" "bit" +instance PGType "varbit" => PGType "varbit[]" +instance PGType "varbit" => PGArrayType "varbit[]" "varbit" +instance PGType "numeric" => PGType "numeric[]" +instance PGType "numeric" => PGArrayType "numeric[]" "numeric" +instance PGType "refcursor" => PGType "refcursor[]" +instance PGType "refcursor" => PGArrayType "refcursor[]" "refcursor" +instance PGType "regprocedure" => PGType "regprocedure[]" +instance PGType "regprocedure" => PGArrayType "regprocedure[]" "regprocedure" +instance PGType "regoper" => PGType "regoper[]" +instance PGType "regoper" => PGArrayType "regoper[]" "regoper" +instance PGType "regoperator" => PGType "regoperator[]" +instance PGType "regoperator" => PGArrayType "regoperator[]" "regoperator" +instance PGType "regclass" => PGType "regclass[]" +instance PGType "regclass" => PGArrayType "regclass[]" "regclass" +instance PGType "regtype" => PGType "regtype[]" +instance PGType "regtype" => PGArrayType "regtype[]" "regtype" +instance PGType "record" => PGType "record[]" +instance PGType "record" => PGArrayType "record[]" "record" +instance PGType "cstring" => PGType "cstring[]" +instance PGType "cstring" => PGArrayType "cstring[]" "cstring" +instance PGType "uuid" => PGType "uuid[]" +instance PGType "uuid" => PGArrayType "uuid[]" "uuid" +instance PGType "txid_snapshot" => PGType "txid_snapshot[]" +instance PGType "txid_snapshot" => PGArrayType "txid_snapshot[]" "txid_snapshot" +instance PGType "tsvector" => PGType "tsvector[]" +instance PGType "tsvector" => PGArrayType "tsvector[]" "tsvector" +instance PGType "tsquery" => PGType "tsquery[]" +instance PGType "tsquery" => PGArrayType "tsquery[]" "tsquery" +instance PGType "gtsvector" => PGType "gtsvector[]" +instance PGType "gtsvector" => PGArrayType "gtsvector[]" "gtsvector" +instance PGType "regconfig" => PGType "regconfig[]" +instance PGType "regconfig" => PGArrayType "regconfig[]" "regconfig" +instance PGType "regdictionary" => PGType "regdictionary[]" +instance PGType "regdictionary" => PGArrayType "regdictionary[]" "regdictionary" +instance PGType "int4range" => PGType "int4range[]" +instance PGType "int4range" => PGArrayType "int4range[]" "int4range" +instance PGType "numrange" => PGType "numrange[]" +instance PGType "numrange" => PGArrayType "numrange[]" "numrange" +instance PGType "tsrange" => PGType "tsrange[]" +instance PGType "tsrange" => PGArrayType "tsrange[]" "tsrange" +instance PGType "tstzrange" => PGType "tstzrange[]" +instance PGType "tstzrange" => PGArrayType "tstzrange[]" "tstzrange" +instance PGType "daterange" => PGType "daterange[]" +instance PGType "daterange" => PGArrayType "daterange[]" "daterange" +instance PGType "int8range" => PGType "int8range[]" +instance PGType "int8range" => PGArrayType "int8range[]" "int8range" diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index b0e83d3..2eec86b 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -19,12 +19,11 @@ import qualified Data.Time as Time #ifdef USE_UUID import qualified Data.UUID as UUID #endif -import GHC.TypeLits (KnownSymbol) import Database.PostgreSQL.Typed.Types -- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling. -class KnownSymbol t => PGRep t a | a -> t where +class PGType t => PGRep t a | a -> t where pgTypeOf :: a -> PGTypeName t pgTypeOf _ = PGTypeProxy pgEncodeRep :: a -> PGValue diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 8ec48c5..4fed035 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -46,6 +46,7 @@ makePGEnum name typs valnf = do ds <- TH.newName "s" return [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded] + , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `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 ] diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 6643937..f177d44 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-} +{-# LANGUAGE CPP, PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-} module Database.PostgreSQL.Typed.Query ( PGQuery(..) , PGSimpleQuery @@ -156,28 +156,43 @@ 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) + (pt, rt) <- TH.runIO $ 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 + return + ( TH.VarP v + , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v + )) pt + (pats, conv, bins) <- 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) + return + ( TH.VarP v + , tpgTypeDecoder t e `TH.AppE` TH.VarE v + , tpgTypeBinary t e + )) rt foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser - `TH.AppE` TH.LamE [TH.VarP e] pgq + `TH.AppE` TH.LamE [TH.VarP e] (if isNothing prep + then TH.ConE 'SimpleQuery + `TH.AppE` sqlSubstitute sqlp vals + else 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 +#ifdef USE_BINARY + bins +#else + [] +#endif + ) `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 diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index e9f1f6a..1d1612e 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range -- Copyright: 2015 Dylan Simon @@ -14,7 +15,6 @@ import Control.Monad (guard) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC import Data.Monoid ((<>), mempty) -import GHC.TypeLits (KnownSymbol) import qualified Text.Parsec as P import Database.PostgreSQL.Typed.Types @@ -150,7 +150,7 @@ intersect _ _ = Empty -- |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 +class (PGType tr, PGType t) => PGRangeType tr t | tr -> t where pgRangeElementType :: PGTypeName tr -> PGTypeName t pgRangeElementType PGTypeProxy = PGTypeProxy @@ -182,10 +182,16 @@ instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where uc <- pc ']' ')' return $ Range (Lower (mb lc lb)) (Upper (mb uc ub)) +instance PGType "int4range" instance PGRangeType "int4range" "integer" +instance PGType "numrange" instance PGRangeType "numrange" "numeric" +instance PGType "tsrange" instance PGRangeType "tsrange" "timestamp without time zone" +instance PGType "tstzrange" instance PGRangeType "tstzrange" "timestamp with time zone" +instance PGType "daterange" instance PGRangeType "daterange" "date" +instance PGType "int8range" instance PGRangeType "int8range" "bigint" diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index e728f9b..53af63e 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -15,6 +15,7 @@ module Database.PostgreSQL.Typed.TH , tpgDescribe , tpgTypeEncoder , tpgTypeDecoder + , tpgTypeBinary ) where import Control.Applicative ((<$>), (<$), (<|>)) @@ -127,69 +128,53 @@ 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: - (,) 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 = +tpgDescribe :: String -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo]) +tpgDescribe sql types nulls = 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 + , tpgValueNullable = True + }) pt + , map (\(c, o, n) -> TPGValueInfo + { tpgValueName = c + , tpgValueTypeOID = o + , tpgValueType = tpgType tpg o + , tpgValueNullable = n + }) rt + ) + +typeApply :: TPGType -> TH.Name -> TH.Name -> TH.Exp +typeApply t f e = TH.VarE f `TH.AppE` TH.VarE e `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''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 'pgEncodeParameter +tpgTypeEncoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeEncoder lit v = typeApply (tpgValueType v) $ + if lit + then 'pgEscapeParameter + else 'pgEncodeParameter -- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. -tpgTypeDecoder :: 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 +tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeDecoder v = typeApply (tpgValueType v) $ + if tpgValueNullable v + then 'pgDecodeColumn + else 'pgDecodeColumnNotNull + +-- |TH expression calling 'pgBinaryColumn'. +tpgTypeBinary :: TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeBinary v = typeApply (tpgValueType v) 'pgBinaryColumn diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index b6fbe81..be003b7 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -12,23 +12,19 @@ module Database.PostgreSQL.Typed.Types , PGValue(..) , PGValues , PGTypeName(..) - , pgTypeName , PGTypeEnv(..) , unknownPGTypeEnv -- * Marshalling classes + , PGType(..) , PGParameter(..) , PGColumn(..) - , PGBinaryType - , PGBinaryColumn(..) -- * Marshalling interface , pgEncodeParameter , pgEscapeParameter , pgDecodeColumn , pgDecodeColumnNotNull - , pgDecodeBinaryColumn - , pgDecodeBinaryColumnNotNull -- * Conversion utilities , pgQuote @@ -90,14 +86,6 @@ data PGValue -- |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. -- Nothing values represent unknown. @@ -110,11 +98,24 @@ unknownPGTypeEnv = PGTypeEnv { pgIntegerDatetimes = Nothing } +-- |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 + +-- |A valid PostgreSQL type. +-- This is just an indicator class: no implementation is needed. +-- Unfortunately this will generate orphan instances wherever used. +class KnownSymbol t => PGType t where + pgTypeName :: PGTypeName t -> String + pgTypeName = symbolVal + -- |Does this type support binary decoding? + -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type. + pgBinaryColumn :: PGTypeEnv -> PGTypeName t -> Bool + pgBinaryColumn _ _ = False + -- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@. -class KnownSymbol t => PGParameter (t :: Symbol) a where +class PGType t => PGParameter t a where -- |Encode a value to a PostgreSQL text representation. pgEncode :: PGTypeName t -> a -> PGTextValue - pgEncode t = pgTextValue . pgEncodeValue unknownPGTypeEnv t -- |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 @@ -125,37 +126,28 @@ class KnownSymbol t => PGParameter (t :: Symbol) a where pgEncodeValue _ t = PGTextValue . pgEncode t -- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@. -class KnownSymbol t => PGColumn (t :: Symbol) a where +class PGType t => PGColumn t 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 + -- |Decode the PostgreSQL binary representation into a value. + -- Only needs to be implemented if 'pgBinaryColumn' is true. pgDecodeBinary :: PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a - --- |Support decoding of assumed non-null columns but also still allow decoding into 'Maybe'. -class PGColumnNotNull t a where - pgDecodeNotNull :: PGTypeName t -> PGValue -> a -class PGColumnNotNull t a => PGBinaryColumnNotNull t a where - pgDecodeBinaryNotNull :: PGTypeEnv -> PGTypeName t -> PGValue -> a - + pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgTypeName t ++ ": not supported" + pgDecodeValue :: PGTypeEnv -> PGTypeName t -> PGValue -> a + pgDecodeValue _ t (PGTextValue v) = pgDecode t v + pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v + pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)" instance PGParameter t a => PGParameter t (Maybe a) where + pgEncode t = maybe (error $ "pgEncode " ++ pgTypeName t ++ ": Nothing") (pgEncode t) pgLiteral = maybe "NULL" . pgLiteral pgEncodeValue e = maybe PGNullValue . pgEncodeValue e -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 -instance PGBinaryColumn t a => PGBinaryColumnNotNull t a where - pgDecodeBinaryNotNull e t (PGBinaryValue v) = pgDecodeBinary e t v - pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v -instance PGBinaryColumn t a => PGBinaryColumnNotNull t (Maybe a) where - pgDecodeBinaryNotNull e t (PGBinaryValue v) = Just $ pgDecodeBinary e t v - pgDecodeBinaryNotNull _ t v = pgDecodeNotNull t v +instance PGColumn t a => PGColumn t (Maybe a) where + pgDecode t = Just . pgDecode t + pgDecodeBinary e t = Just . pgDecodeBinary e t + pgDecodeValue _ _ PGNullValue = Nothing + pgDecodeValue e t v = Just $ pgDecodeValue e t v -- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. @@ -167,20 +159,12 @@ pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> String pgEscapeParameter _ = pgLiteral -- |Final column decoding function used for a nullable result value. -pgDecodeColumn :: PGColumnNotNull t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a -pgDecodeColumn _ = pgDecodeNotNull +pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a +pgDecodeColumn = pgDecodeValue -- |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 = pgDecodeBinaryNotNull - --- |Final column decoding function used for a non-nullable binary-encoded result value. -pgDecodeBinaryColumnNotNull :: PGBinaryColumnNotNull t a => PGTypeEnv -> PGTypeName t -> PGValue -> a -pgDecodeBinaryColumnNotNull = pgDecodeBinaryNotNull +pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> a +pgDecodeColumnNotNull = pgDecodeValue pgQuoteUnsafe :: String -> String @@ -214,129 +198,140 @@ parsePGDQuote unsafe = (q P.<|> uq) where P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" uq = P.many1 (P.noneOf ('"':'\\':unsafe)) +#ifdef USE_BINARY +binDec :: PGType t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . d + +#define BIN_COL pgBinaryColumn _ _ = True +#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . F +#define BIN_DEC(F) pgDecodeBinary _ = F +#else +#define BIN_COL +#define BIN_ENC(F) +#define BIN_DEC(F) +#endif +instance PGType "boolean" where BIN_COL instance PGParameter "boolean" Bool where pgEncode _ False = BSC.singleton 'f' pgEncode _ True = BSC.singleton 't' pgLiteral _ False = "false" pgLiteral _ True = "true" -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.bool -#endif + BIN_ENC(BinE.bool) instance PGColumn "boolean" Bool where pgDecode _ s = case BSC.head s of 'f' -> False 't' -> True c -> error $ "pgDecode boolean: " ++ [c] + BIN_DEC(binDec BinD.bool) type OID = Word32 +instance PGType "oid" where BIN_COL instance PGParameter "oid" OID where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.int4 . Right -#endif + BIN_ENC(BinE.int4 . Right) instance PGColumn "oid" OID where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.int) +instance PGType "smallint" where BIN_COL instance PGParameter "smallint" Int16 where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.int2 . Left -#endif + BIN_ENC(BinE.int2. Left) instance PGColumn "smallint" Int16 where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.int) +instance PGType "integer" where BIN_COL instance PGParameter "integer" Int32 where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.int4 . Left -#endif + BIN_ENC(BinE.int4 . Left) instance PGColumn "integer" Int32 where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.int) +instance PGType "bigint" where BIN_COL instance PGParameter "bigint" Int64 where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.int8 . Left -#endif + BIN_ENC(BinE.int8 . Left) instance PGColumn "bigint" Int64 where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.int) +instance PGType "real" where BIN_COL instance PGParameter "real" Float where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.float4 -#endif + BIN_ENC(BinE.float4) instance PGColumn "real" Float where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.float4) +instance PGType "double precision" where BIN_COL instance PGParameter "double precision" Double where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.float8 -#endif + BIN_ENC(BinE.float8) instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.float8) +instance PGType "\"char\"" where BIN_COL instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.char -#endif + BIN_ENC(BinE.char) instance PGColumn "\"char\"" Char where pgDecode _ = BSC.head + BIN_DEC(binDec BinD.char) -class KnownSymbol t => PGStringType t +class PGType t => PGStringType t instance PGStringType t => PGParameter t String where pgEncode _ = BSU.fromString -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.text . Left . T.pack -#endif + BIN_ENC(BinE.text . Left . T.pack) instance PGStringType t => PGColumn t String where pgDecode _ = BSU.toString + BIN_DEC((T.unpack .) . binDec BinD.text) instance PGStringType t => PGParameter t BS.ByteString where pgEncode _ = id -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.text . Left . TE.decodeUtf8 -#endif + BIN_ENC(BinE.text . Left . TE.decodeUtf8) instance PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id + BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text) instance PGStringType t => PGParameter t BSL.ByteString where pgEncode _ = BSL.toStrict -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.text . Right . TLE.decodeUtf8 -#endif + BIN_ENC(BinE.text . Right . TLE.decodeUtf8) instance PGStringType t => PGColumn t BSL.ByteString where pgDecode _ = BSL.fromStrict + BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text) #ifdef USE_TEXT instance PGStringType t => PGParameter t T.Text where pgEncode _ = TE.encodeUtf8 -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.text . Left -#endif + BIN_ENC(BinE.text . Left) instance PGStringType t => PGColumn t T.Text where pgDecode _ = TE.decodeUtf8 + BIN_DEC(binDec BinD.text) instance PGStringType t => PGParameter t TL.Text where pgEncode _ = BSL.toStrict . TLE.encodeUtf8 -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.text . Right -#endif + BIN_ENC(BinE.text . Right) instance PGStringType t => PGColumn t TL.Text where pgDecode _ = TL.fromStrict . TE.decodeUtf8 + BIN_DEC((TL.fromStrict .) . binDec BinD.text) #endif +instance PGType "text" where BIN_COL +instance PGType "character varying" where BIN_COL +instance PGType "name" where BIN_COL +instance PGType "bpchar" where BIN_COL instance PGStringType "text" instance PGStringType "character varying" instance PGStringType "name" -- limit 63 characters; not strictly textsend but essentially the same @@ -357,35 +352,47 @@ decodeBytea s pd [x] = error $ "pgDecode bytea: " ++ show x unhex = fromIntegral . digitToInt . w2c +instance PGType "bytea" where BIN_COL instance PGParameter "bytea" BSL.ByteString where pgEncode _ = encodeBytea . BSB.lazyByteStringHex pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.bytea . Right -#endif + BIN_ENC(BinE.bytea . Right) instance PGColumn "bytea" BSL.ByteString where pgDecode _ = BSL.pack . decodeBytea + BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea) instance PGParameter "bytea" BS.ByteString where pgEncode _ = encodeBytea . BSB.byteStringHex pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.bytea . Left -#endif + BIN_ENC(BinE.bytea . Left) instance PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea + BIN_DEC(binDec BinD.bytea) +instance PGType "date" where BIN_COL instance PGParameter "date" Time.Day where pgEncode _ = BSC.pack . Time.showGregorian pgLiteral _ = pgQuoteUnsafe . Time.showGregorian -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.date -#endif + BIN_ENC(BinE.date) instance PGColumn "date" Time.Day where pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack + BIN_DEC(binDec BinD.date) +binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool +#ifdef USE_BINARY +binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True +#endif +binColDatetime _ _ = False + +#ifdef USE_BINARY binEncDatetime :: PGParameter t a => (Bool -> a -> PGBinaryValue) -> PGTypeEnv -> PGTypeName t -> a -> PGValue binEncDatetime f e t = maybe (PGTextValue . pgEncode t) ((PGBinaryValue .) . f) (pgIntegerDatetimes e) +binDecDatetime :: PGColumn t a => (Bool -> BinD.D a) -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a +binDecDatetime f e = binDec $ f $ fromMaybe (error "pgDecodeBinary: unknown integer_datetimes value") $ pgIntegerDatetimes e +#endif + +instance PGType "time without time zone" where + pgBinaryColumn = binColDatetime instance PGParameter "time without time zone" Time.TimeOfDay where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q" @@ -394,7 +401,12 @@ instance PGParameter "time without time zone" Time.TimeOfDay where #endif instance PGColumn "time without time zone" Time.TimeOfDay where pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack +#ifdef USE_BINARY + pgDecodeBinary = binDecDatetime BinD.time +#endif +instance PGType "timestamp without time zone" where + pgBinaryColumn = binColDatetime 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" @@ -403,6 +415,9 @@ instance PGParameter "timestamp without time zone" Time.LocalTime where #endif instance PGColumn "timestamp without time zone" Time.LocalTime where pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack +#ifdef USE_BINARY + pgDecodeBinary = binDecDatetime BinD.timestamp +#endif -- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. -- readTime can successfully parse both formats, but PostgreSQL needs the colon. @@ -414,6 +429,8 @@ fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2] fixTZ (c:s) = c:fixTZ s +instance PGType "timestamp with time zone" where + pgBinaryColumn = binColDatetime 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" @@ -422,7 +439,12 @@ instance PGParameter "timestamp with time zone" Time.UTCTime where #endif instance PGColumn "timestamp with time zone" Time.UTCTime where pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack +#ifdef USE_BINARY + pgDecodeBinary = binDecDatetime BinD.timestamptz +#endif +instance PGType "interval" where + pgBinaryColumn = binColDatetime instance PGParameter "interval" Time.DiffTime where pgEncode _ = BSC.pack . show pgLiteral _ = pgQuoteUnsafe . show @@ -463,7 +485,11 @@ instance PGColumn "interval" Time.DiffTime where , reservedNames = [] , caseSensitive = True } +#ifdef USE_BINARY + pgDecodeBinary = binDecDatetime BinD.interval +#endif +instance PGType "numeric" where BIN_COL instance PGParameter "numeric" Rational where pgEncode _ r | denominator r == 0 = BSC.pack "NaN" -- this can't happen @@ -472,9 +498,7 @@ instance PGParameter "numeric" Rational where pgLiteral _ r | denominator r == 0 = "'NaN'" -- this can't happen | otherwise = '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.numeric . realToFrac -#endif + BIN_ENC(BinE.numeric . realToFrac) -- |High-precision representation of Rational as numeric. -- Unfortunately, numeric has an NaN, while Rational does not. -- NaN numeric values will produce exceptions. @@ -485,6 +509,7 @@ instance PGColumn "numeric" Rational where ur [(x,"")] = x ur _ = error $ "pgDecode numeric: " ++ s s = BSC.unpack bs + BIN_DEC((realToFrac .) . binDec BinD.numeric) -- This will produce infinite(-precision) strings showRational :: Rational -> String @@ -497,26 +522,25 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where instance PGParameter "numeric" Scientific where pgEncode _ = BSC.pack . show pgLiteral _ = show -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.numeric -#endif + BIN_ENC(BinE.numeric) instance PGColumn "numeric" Scientific where pgDecode _ = read . BSC.unpack + BIN_DEC(binDec BinD.numeric) #endif #ifdef USE_UUID +instance PGType "uuid" where BIN_COL instance PGParameter "uuid" UUID.UUID where pgEncode _ = UUID.toASCIIBytes pgLiteral _ = pgQuoteUnsafe . UUID.toString -#ifdef USE_BINARY - pgEncodeValue _ _ = PGBinaryValue . BinE.uuid -#endif + BIN_ENC(BinE.uuid) instance PGColumn "uuid" UUID.UUID where pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u + BIN_DEC(binDec BinD.uuid) #endif -- |Generic class of composite (row or record) types. -class KnownSymbol t => PGRecordType t +class PGType t => PGRecordType t instance PGRecordType t => PGParameter t [Maybe PGTextValue] where pgEncode _ l = buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where @@ -532,100 +556,11 @@ instance PGRecordType t => PGColumn t [Maybe PGTextValue] where nel = P.optionMaybe $ P.between P.spaces P.spaces el el = BSC.pack <$> parsePGDQuote "()," +instance PGType "record" -- |The generic anonymous record type, as created by @ROW@. -- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). instance PGRecordType "record" - -#ifdef 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 PGBinaryColumn "oid" OID where - pgDecodeBinary _ = binDec BinD.int - -instance PGBinaryType "smallint" -instance PGBinaryColumn "smallint" Int16 where - pgDecodeBinary _ = binDec BinD.int - -instance PGBinaryType "integer" -instance PGBinaryColumn "integer" Int32 where - pgDecodeBinary _ = binDec BinD.int - -instance PGBinaryType "bigint" -instance PGBinaryColumn "bigint" Int64 where - pgDecodeBinary _ = binDec BinD.int - -instance PGBinaryType "real" -instance PGBinaryColumn "real" Float where - pgDecodeBinary _ = binDec BinD.float4 - -instance PGBinaryType "double precision" -instance PGBinaryColumn "double precision" Double where - pgDecodeBinary _ = binDec BinD.float8 - -instance PGBinaryType "numeric" -instance PGBinaryColumn "numeric" Scientific where - pgDecodeBinary _ = binDec BinD.numeric -instance PGBinaryColumn "numeric" Rational where - pgDecodeBinary _ t = realToFrac . binDec BinD.numeric t - -instance PGBinaryType "\"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) => PGBinaryColumn t T.Text where - pgDecodeBinary _ = binDec BinD.text -instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t TL.Text where - pgDecodeBinary _ t = TL.fromStrict . binDec BinD.text t -instance (PGStringType t, PGBinaryType t) => PGBinaryColumn t BS.ByteString where - pgDecodeBinary _ t = TE.encodeUtf8 . binDec BinD.text t -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) => PGBinaryColumn t String where - pgDecodeBinary _ t = T.unpack . binDec BinD.text t - -instance PGBinaryType "bytea" -instance PGBinaryColumn "bytea" BS.ByteString where - pgDecodeBinary _ = binDec BinD.bytea -instance PGBinaryColumn "bytea" BSL.ByteString where - pgDecodeBinary _ t = BSL.fromStrict . binDec BinD.bytea t - -binDecDatetime :: KnownSymbol t => (Bool -> BinD.D a) -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a -binDecDatetime f e = binDec $ f $ fromMaybe (error "pgDecodeBinary: unknown integer_datetimes value") $ pgIntegerDatetimes e - -instance PGBinaryType "date" -instance PGBinaryColumn "date" Time.Day where - pgDecodeBinary _ = binDec BinD.date -instance PGBinaryType "time without time zone" -instance PGBinaryColumn "time without time zone" Time.TimeOfDay where - pgDecodeBinary = binDecDatetime BinD.time -instance PGBinaryType "timestamp without time zone" -instance PGBinaryColumn "timestamp without time zone" Time.LocalTime where - pgDecodeBinary = binDecDatetime BinD.timestamp -instance PGBinaryType "timestamp with time zone" -instance PGBinaryColumn "timestamp with time zone" Time.UTCTime where - pgDecodeBinary = binDecDatetime BinD.timestamptz -instance PGBinaryType "interval" -instance PGBinaryColumn "interval" Time.DiffTime where - pgDecodeBinary = binDecDatetime BinD.interval - -instance PGBinaryType "boolean" -instance PGBinaryColumn "boolean" Bool where - pgDecodeBinary _ = binDec BinD.bool - -instance PGBinaryType "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", ?) From e6d38f1abe47aa3723e3861d9c30a195f79fc292 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 10 Jan 2015 18:53:43 -0500 Subject: [PATCH 113/306] Dump snaplet: it really wasn't doing anything interesting --- snaplet/.gitignore | 1 - snaplet/LICENSE | 28 ----- snaplet/Setup.hs | 3 - snaplet/Snap/Snaplet/PostgresqlTyped.hs | 140 ------------------------ snaplet/devel.cfg | 18 --- snaplet/snaplet-postgresql-typed.cabal | 45 -------- 6 files changed, 235 deletions(-) delete mode 100644 snaplet/.gitignore delete mode 100644 snaplet/LICENSE delete mode 100644 snaplet/Setup.hs delete mode 100644 snaplet/Snap/Snaplet/PostgresqlTyped.hs delete mode 100644 snaplet/devel.cfg delete mode 100644 snaplet/snaplet-postgresql-typed.cabal diff --git a/snaplet/.gitignore b/snaplet/.gitignore deleted file mode 100644 index 178135c..0000000 --- a/snaplet/.gitignore +++ /dev/null @@ -1 +0,0 @@ -/dist/ diff --git a/snaplet/LICENSE b/snaplet/LICENSE deleted file mode 100644 index d958f92..0000000 --- a/snaplet/LICENSE +++ /dev/null @@ -1,28 +0,0 @@ -Copyright (c) 2012, Doug Beardsley -Copyright (c) 2015, Dylan Simon -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 the authors nor the names of its contributors may be used -to endorse or promote products derived from this software without specific -prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/snaplet/Setup.hs b/snaplet/Setup.hs deleted file mode 100644 index e8ef27d..0000000 --- a/snaplet/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/snaplet/Snap/Snaplet/PostgresqlTyped.hs b/snaplet/Snap/Snaplet/PostgresqlTyped.hs deleted file mode 100644 index 1f0e304..0000000 --- a/snaplet/Snap/Snaplet/PostgresqlTyped.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverloadedStrings #-} -module Snap.Snaplet.PostgresqlTyped ( - -- * The Snaplet - PG(..) - , HasPG(..) - , PGConfig(..) - , pgDefaultConfig - - , pgInit - , pgInit' - - , getPGConfig - , getPGDatabase - , loadPGDatabase - , withPG - , liftPG - - , PG.pgSQL - , pgRunQuery - , pgExecute - , pgQuery - ) where - -import Control.Applicative -import Control.Lens (set) -import Control.Monad.CatchIO (MonadCatchIO) -import Control.Monad.IO.Class -import Control.Monad.State -import Control.Monad.Reader -import qualified Data.Configurator as C -import qualified Data.Configurator.Types as C -import Data.Pool -import Data.Sequence (Seq) -import Network (PortID(..)) -import Snap - -import qualified Database.PostgreSQL.Typed as PG -import qualified Database.PostgreSQL.Typed.Query as PG -import Paths_snaplet_postgresql_typed - - -data PG - = PGPool (Pool PG.PGConnection) - | PGConn PG.PGConnection - -class (MonadCatchIO m) => HasPG m where - getPGState :: m PG - setLocalPGState :: PG -> m a -> m a - -instance HasPG (Handler b PG) where - getPGState = get - setLocalPGState s = local (const s) - -instance (MonadCatchIO m) => HasPG (ReaderT (Snaplet PG) m) where - getPGState = asks (^# snapletValue) - setLocalPGState s = local (set snapletValue s) - -instance (MonadCatchIO m) => HasPG (ReaderT PG m) where - getPGState = ask - setLocalPGState s = local (const s) - -withPG :: HasPG m => m b -> m b -withPG f = do - s <- getPGState - case s of - PGPool p -> withResource p (\c -> setLocalPGState (PGConn c) f) - PGConn _ -> f - -liftPG :: HasPG m => (PG.PGConnection -> IO a) -> m a -liftPG f = do - s <- getPGState - liftPG' s f - -liftPG' :: MonadIO m => PG -> (PG.PGConnection -> IO a) -> m a -liftPG' (PGPool p) f = liftIO (withResource p f) -liftPG' (PGConn c) f = liftIO (f c) - -data PGConfig = PGConfig - { pgConfigDatabase :: PG.PGDatabase - , pgConfigNumStripes :: Int - , pgConfigIdleTime :: Double - , pgConfigResources :: Int - } - -pgDefaultConfig :: PG.PGDatabase -> PGConfig -pgDefaultConfig db = PGConfig db 1 60 16 - -getPGDatabase :: C.Config -> IO PG.PGDatabase -getPGDatabase config = do - host <- C.lookupDefault "localhost" config "host" - port <- C.lookupDefault (5432 :: Int) config "port" - sock <- C.lookup config "sock" - user <- C.require config "user" - db <- C.lookupDefault user config "db" - passwd <- C.lookupDefault "" config "pass" - debug <- C.lookupDefault False config "debug" - return $ PG.PGDatabase - { PG.pgDBHost = host - , PG.pgDBPort = maybe (PortNumber (fromIntegral port)) UnixSocket sock - , PG.pgDBName = db - , PG.pgDBUser = user - , PG.pgDBPass = passwd - , PG.pgDBDebug = debug - , PG.pgDBLogMessage = \_ -> return () -- something better? - } - --- |Suitable for use with 'useTPGDatabase' -loadPGDatabase :: FilePath -> IO PG.PGDatabase -loadPGDatabase f = getPGDatabase =<< C.load [C.Required f] - -getPGConfig :: C.Config -> IO PGConfig -getPGConfig config = do - db <- getPGDatabase config - let def = pgDefaultConfig db - stripes <- C.lookupDefault (pgConfigNumStripes def) config "numStripes" - idle <- C.lookupDefault (pgConfigIdleTime def) config "idleTime" - resources <- C.lookupDefault (pgConfigResources def) config "maxResourcesPerStripe" - return $ PGConfig db stripes idle resources - -pgMake :: Initializer b PG PGConfig -> SnapletInit b PG -pgMake config = makeSnaplet "postgresql-typed" "PostgreSQL-Typed interface" (Just getDataDir) $ do - c <- config - liftIO $ PGPool <$> createPool (PG.pgConnect (pgConfigDatabase c)) PG.pgDisconnect - (pgConfigNumStripes c) (realToFrac $ pgConfigIdleTime c) (pgConfigResources c) - -pgInit :: SnapletInit b PG -pgInit = pgMake (liftIO . getPGConfig =<< getSnapletUserConfig) - -pgInit' :: PGConfig -> SnapletInit b PG -pgInit' config = pgMake (return config) - - -pgRunQuery :: (HasPG m, PG.PGQuery q a) => q -> m (Int, Seq a) -pgRunQuery q = liftPG $ \c -> PG.pgRunQuery c q - -pgExecute :: (HasPG m, PG.PGQuery q ()) => q -> m Int -pgExecute q = liftPG $ \c -> PG.pgExecute c q - -pgQuery :: (HasPG m, PG.PGQuery q a) => q -> m [a] -pgQuery q = liftPG $ \c -> PG.pgQuery c q diff --git a/snaplet/devel.cfg b/snaplet/devel.cfg deleted file mode 100644 index cc1a1af..0000000 --- a/snaplet/devel.cfg +++ /dev/null @@ -1,18 +0,0 @@ -host = "localhost" -port = 5432 -#sock = "/tmp/.s.PGSQL.5432" -user = "postgres" -pass = "" -db = "testdb" - -# Nmuber of distinct connection pools to maintain. The smallest acceptable -# value is 1. -numStripes = 1 - -# Number of seconds an unused resource is kept open. The smallest acceptable -# value is 0.5 seconds. -idleTime = 60 - -# Maximum number of resources to keep open per stripe. The smallest -# acceptable value is 1. -maxResourcesPerStripe = 16 diff --git a/snaplet/snaplet-postgresql-typed.cabal b/snaplet/snaplet-postgresql-typed.cabal deleted file mode 100644 index f3661c3..0000000 --- a/snaplet/snaplet-postgresql-typed.cabal +++ /dev/null @@ -1,45 +0,0 @@ -name: snaplet-postgresql-typed -version: 0 -synopsis: postgresql-typed snaplet for the Snap Framework -description: This snaplet contains support for using the Postgresql - database with a Snap Framework application via the - postgresql-typed package. Based on snaplet-postgresql-simple. -license: BSD3 -license-file: LICENSE -author: Dylan simon -maintainer: dylan@dylex.net -build-type: Simple -cabal-version: >= 1.6 -homepage: https://github.com/dylex/postgresql-typed/snaplet/tree/master/snaplet -category: Snap - -data-files: - devel.cfg - -source-repository head - type: git - location: https://github.com/dylex/postgresql-typed.git - -Library - exposed-modules: - Snap.Snaplet.PostgresqlTyped - - other-modules: - Paths_snaplet_postgresql_typed - - build-depends: - base >= 4 && < 4.8, - bytestring >= 0.9.1 && < 0.11, - configurator >= 0.2 && < 0.4, - lens, - MonadCatchIO-transformers >= 0.3 && < 0.4, - mtl >= 2 && < 2.3, - resource-pool-catchio >= 0.2 && < 0.3, - snap >= 0.10 && < 0.14, - transformers >= 0.2 && < 0.5, - containers, - time, - network, - postgresql-typed - - ghc-options: -Wall From d08b5b9eabb029a0d29d14c430d8b7fc81768528 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 11 Jan 2015 01:13:16 -0500 Subject: [PATCH 114/306] Add pgSubstituteLiteral TH wrapper to pgSafeLiteral I wish there were a way to combine this with normal queries, but I don't think there is, since it needs two TH passes... though actually maybe it could sort of by allowing them passed through to describe first, but then ignoring the results? --- Database/PostgreSQL/Typed/Dynamic.hs | 25 ++++++++++++++-- Database/PostgreSQL/Typed/Internal.hs | 33 +++++++++++++++++++++ Database/PostgreSQL/Typed/Query.hs | 41 ++++++++++++--------------- postgresql-typed.cabal | 2 ++ test/Main.hs | 2 ++ 5 files changed, 78 insertions(+), 25 deletions(-) create mode 100644 Database/PostgreSQL/Typed/Internal.hs diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 2eec86b..673932e 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, TemplateHaskell #-} -- | -- Module: Database.PostgreSQL.Typed.Dynamic -- Copyright: 2015 Dylan Simon @@ -6,8 +6,13 @@ -- Automatic (dynamic) marshalling of PostgreSQL values based on Haskell types (not SQL statements). -- This is intended for direct construction of queries and query data, bypassing the normal SQL type inference. -module Database.PostgreSQL.Typed.Dynamic where +module Database.PostgreSQL.Typed.Dynamic + ( PGRep(..) + , pgSafeLiteral + , pgSubstituteLiterals + ) where +import Control.Applicative ((<$>)) import Data.Int #ifdef USE_SCIENTIFIC import Data.Scientific (Scientific) @@ -19,7 +24,10 @@ import qualified Data.Time as Time #ifdef USE_UUID import qualified Data.UUID as UUID #endif +import Language.Haskell.Meta.Parse (parseExp) +import qualified Language.Haskell.TH as TH +import Database.PostgreSQL.Typed.Internal import Database.PostgreSQL.Typed.Types -- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling. @@ -78,3 +86,16 @@ instance PGRep "numeric" Scientific where #ifdef USE_UUID instance PGRep "uuid" UUID.UUID where #endif + +-- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@. +-- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries. +-- Unlike most other TH functions, this does not require any database connection. +pgSubstituteLiterals :: String -> TH.ExpQ +pgSubstituteLiterals ('$':'$':'{':s) = (++$) "${" <$> pgSubstituteLiterals s +pgSubstituteLiterals ('$':'{':s) + | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = do + v <- either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e + ($++$) (TH.VarE 'pgSafeLiteral `TH.AppE` v) <$> pgSubstituteLiterals r + | otherwise = fail $ "Error parsing SQL: could not find end of expression: ${" ++ s +pgSubstituteLiterals (c:r) = (++$) [c] <$> pgSubstituteLiterals r +pgSubstituteLiterals "" = return $ stringE "" diff --git a/Database/PostgreSQL/Typed/Internal.hs b/Database/PostgreSQL/Typed/Internal.hs new file mode 100644 index 0000000..ef5dca7 --- /dev/null +++ b/Database/PostgreSQL/Typed/Internal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE PatternSynonyms, TemplateHaskell #-} +module Database.PostgreSQL.Typed.Internal + ( stringE + , pattern StringE + , ($++$) + , (++$) + ) where + +import Data.String (IsString(..)) +import qualified Language.Haskell.TH as TH + +stringE :: String -> TH.Exp +stringE = TH.LitE . TH.StringL + +pattern StringE s = TH.LitE (TH.StringL s) +pattern InfixE l o r = TH.InfixE (Just l) (TH.VarE o) (Just r) + +instance IsString TH.Exp where + fromString = stringE + +($++$) :: TH.Exp -> TH.Exp -> TH.Exp +infixr 5 $++$ +StringE s $++$ r = s ++$ r +l $++$ StringE "" = l +InfixE ll pp (StringE lr) $++$ StringE r | pp == '(++) = ll $++$ StringE (lr ++ r) +l $++$ r = InfixE l '(++) r + +(++$) :: String -> TH.Exp -> TH.Exp +infixr 5 ++$ +"" ++$ r = r +l ++$ StringE r = StringE (l ++ r) +l ++$ InfixE (StringE rl) pp rr | pp == '(++) = (l ++ rl) ++$ rr +l ++$ r = InfixE (StringE l) '(++) r diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index f177d44..12517e7 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -30,7 +30,9 @@ import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Numeric (readDec) +import Database.PostgreSQL.Typed.Internal import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TH @@ -110,28 +112,16 @@ sqlPlaceholders = sph (1 :: Int) where -- |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 +sqlSubstitute sql exprl = ss 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) + ss ('$':'$':d:r) | isDigit d = ['$',d] ++$ ss r + ss ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = expr n $++$ ss r + ss (c:r) = [c] ++$ ss r + ss "" = stringE "" splitCommas :: String -> [String] splitCommas = spl where @@ -145,16 +135,18 @@ trim = dropWhileEnd isSpace . dropWhile isSpace -- |Flags affecting how and what type of query to build with 'makePGQuery'. data QueryFlags = QueryFlags - { flagNullable :: Bool -- ^ Assume all results are nullable and don't try to guess. + { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment) + , 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 +simpleFlags = QueryFlags True False Nothing -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ +makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do (pt, rt) <- TH.runIO $ tpgDescribe 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 '$${'" @@ -178,7 +170,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do then TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals else TH.ConE 'PreparedQuery - `TH.AppE` stringL sqlp + `TH.AppE` stringE sqlp `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE @@ -195,9 +187,10 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e 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 +qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = qqQuery f{ flagQuery = False } q +qqQuery f@QueryFlags{ flagQuery = True, flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q +qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q +qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = Just args } =<< sql r where args = map trim $ splitCommas arg (arg, r) = break (')' ==) s sql (')':q) = return q @@ -218,6 +211,7 @@ qqTop err sql = do -- 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 @$${@. -- @@ -226,6 +220,7 @@ qqTop err sql = do -- [@?@] 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). +-- [@#@] Only do literal @${}@ substitution using 'pgSubstituteLiterals' and return a string, not a query. -- -- 'pgSQL' can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results). -- Here the query can only be prefixed with @!@ to make errors non-fatal. diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 7ebda9d..498c4d4 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -64,6 +64,8 @@ Library Database.PostgreSQL.Typed.Range Database.PostgreSQL.Typed.Dynamic Database.PostgreSQL.Typed.TemplatePG + Other-Modules: + Database.PostgreSQL.Typed.Internal GHC-Options: -Wall if flag(md5) Build-Depends: cryptohash >= 0.5 diff --git a/test/Main.hs b/test/Main.hs index 50180f1..6700769 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -59,5 +59,7 @@ main = do [Just "line"] <- prepared c 628 "line" ["line"] <- preparedApply c 628 + assert $ [pgSQL|#abc${f}def|] == "abc3.14::realdef" + pgDisconnect c exitSuccess From 9475673c94ef3fa2671e909703cc2c32388bc543 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 11 Jan 2015 09:19:00 -0500 Subject: [PATCH 115/306] Don't use Seq It's actually faster without, despite the stack overhead. I'll add a conduit interfaces if/when it matters. --- Database/PostgreSQL/Typed/Enum.hs | 6 ++-- Database/PostgreSQL/Typed/Protocol.hs | 47 +++++++++++++-------------- Database/PostgreSQL/Typed/Query.hs | 6 ++-- Database/PostgreSQL/Typed/TH.hs | 2 +- 4 files changed, 28 insertions(+), 33 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 4fed035..4dde273 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -12,8 +12,6 @@ module Database.PostgreSQL.Typed.Enum 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 @@ -39,9 +37,9 @@ makePGEnum :: String -- ^ PostgreSQL enum type name 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" + when (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 + valn = map (\[PGTextValue v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) vals dv <- TH.newName "x" ds <- TH.newName "s" return diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 1c25804..e914bcd 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -45,7 +45,6 @@ import Data.Int (Int32, Int16) 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) @@ -511,7 +510,7 @@ pgDescribe h sql types nulls = do -- In cases where the resulting field is tracable to the column of a -- table, we can check there. (_, r) <- pgPreparedQuery h "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] - case Fold.toList r of + case r of [[s]] -> return $ not $ pgDecodeRep s [] -> return True _ -> fail $ "Failed to determine nullability of column #" ++ show col @@ -534,21 +533,21 @@ fixBinary _ l = l -- 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 + -> IO (Int, [PGValues]) -- ^ The number of rows affected and a list of result rows pgSimpleQuery h sql = do pgSync h pgSend h $ SimpleQuery sql pgFlush h go start where go = (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 (RowDescription rd) = go (row (map colBinary rd)) + start (CommandComplete c) = got c + start EmptyQueryResponse = return (0, []) 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) + row bc (DataRow fs) = second (fixBinary bc fs :) <$> go (row bc) + row _ (CommandComplete c) = got c + row _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m + got c = return (rowsAffected c, []) pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do @@ -576,7 +575,7 @@ 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) + -> IO (Int, [PGValues]) pgPreparedQuery c sql types bind bc = do start <- pgPreparedBind c sql types bind bc pgSend c $ Execute 0 @@ -584,13 +583,13 @@ pgPreparedQuery c sql types bind bc = do pgSend c Sync pgFlush c start - go Seq.empty + go 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 + go = pgReceive c >>= row + row (DataRow fs) = second (fixBinary bc fs :) <$> go + row (CommandComplete r) = return (rowsAffected r, []) + row EmptyQueryResponse = return (0, []) + 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. @@ -601,18 +600,18 @@ pgPreparedLazyQuery c sql types bind bc count = do unsafeInterleaveIO $ do execute start - go Seq.empty + go 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 + go = pgReceive c >>= row + row (DataRow fs) = (fixBinary bc fs :) <$> go + row PortalSuspended = unsafeInterleaveIO (execute >> go) + row (CommandComplete _) = return [] + row EmptyQueryResponse = return [] + row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m -- |Close a previously prepared query (if necessary). pgCloseStatement :: PGConnection -> String -> [OID] -> IO () diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 12517e7..8c785d8 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -20,10 +20,8 @@ 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 @@ -38,7 +36,7 @@ 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) + pgRunQuery :: PGConnection -> q -> IO (Int, [a]) class PGQuery q PGValues => PGRawQuery q -- |Execute a query that does not return results. @@ -48,7 +46,7 @@ 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 +pgQuery c q = snd <$> pgRunQuery c q data SimpleQuery = SimpleQuery String diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 53af63e..293cdf7 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -75,7 +75,7 @@ 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 (\[to, tn] -> - (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) $ Fold.toList $ snd tl + (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) $ snd tl } tpgInit :: PGConnection -> IO TPGState From 1c27af6e38ce302147230bf088adf46c5f995727 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 12 Jan 2015 20:44:11 -0500 Subject: [PATCH 116/306] Derive Show and Read instances for enums I don't see why not. I suppose there may be an argument for using the postgres names rather than the haskell ones for text. --- Database/PostgreSQL/Typed/Enum.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 4dde273..c4bc537 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -24,7 +24,7 @@ import Database.PostgreSQL.Typed.Dynamic -- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: -- -- @ --- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded) +-- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read) -- instance PGType Foo where ... -- registerPGType \"foo\" (ConT ''Foo) -- @ @@ -43,7 +43,7 @@ makePGEnum name typs valnf = do dv <- TH.newName "x" ds <- TH.newName "s" return - [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded] + [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Show, ''Read] , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.WildP, TH.ConP n []] From f6f04bf5c133ba8c9c06a1b8c4907a397180dc93 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 12 Jan 2015 21:48:31 -0500 Subject: [PATCH 117/306] Rename simpleFlags to simpleQueryFlags --- Database/PostgreSQL/Typed/Query.hs | 8 ++++---- Database/PostgreSQL/Typed/TemplatePG.hs | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 8c785d8..81d28a4 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -6,7 +6,7 @@ module Database.PostgreSQL.Typed.Query , rawPGSimpleQuery , rawPGPreparedQuery , QueryFlags(..) - , simpleFlags + , simpleQueryFlags , makePGQuery , pgSQL , pgExecute @@ -139,8 +139,8 @@ data QueryFlags = QueryFlags } -- |'QueryFlags' for a default (simple) query. -simpleFlags :: QueryFlags -simpleFlags = QueryFlags True False Nothing +simpleQueryFlags :: QueryFlags +simpleQueryFlags = QueryFlags True False Nothing -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ @@ -224,7 +224,7 @@ qqTop err sql = do -- Here the query can only be prefixed with @!@ to make errors non-fatal. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter - { quoteExp = qqQuery simpleFlags + { quoteExp = qqQuery simpleQueryFlags , 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/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index c89d9bf..e3b2918 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -46,7 +46,7 @@ querySQL "" = "" -- -- > $(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) |] +queryTuples sql = [| \c -> pgQuery c $(makePGQuery simpleQueryFlags $ querySQL sql) |] -- |@queryTuple :: String -> (PGConnection -> IO (Maybe (column1, column2, ...)))@ -- @@ -66,7 +66,7 @@ queryTuple sql = [| liftM listToMaybe . $(queryTuples sql) |] -- -- Example (where @h@ is a handle from 'pgConnect'): execute :: String -> TH.ExpQ -execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleFlags $ querySQL sql) |] +execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleQueryFlags $ querySQL sql) |] -- |Run a sequence of IO actions (presumably SQL statements) wrapped in a -- transaction. Unfortunately you're restricted to using this in the 'IO' From afb7a6966979fa9c811767567ec8133ef2e90bd2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 13 Jan 2015 21:36:57 -0500 Subject: [PATCH 118/306] Minor haddock formatting fix --- Database/PostgreSQL/Typed/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index e914bcd..4041060 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -69,7 +69,7 @@ data PGState -- |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\"@ + , 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 From 0d7bf8fe4fa5b16e245a3b778c78460db57e183f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 17 Jan 2015 15:27:28 -0500 Subject: [PATCH 119/306] Released 0.3.1, bump version for next release --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 498c4d4..611998c 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.3.1 +Version: 0.3.2 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From f747838dce44a7ade9478fe7fe19ef042ced0cc1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 17 Jan 2015 15:41:53 -0500 Subject: [PATCH 120/306] Add '!' query flag to force not-null assumptions --- Database/PostgreSQL/Typed/Query.hs | 17 ++++++++++------- Database/PostgreSQL/Typed/TH.hs | 6 +++--- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 81d28a4..3d740cf 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -20,6 +20,7 @@ import Control.Exception (try) import Control.Monad (when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) import Data.Char (isDigit, isSpace) +import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing) import Data.Word (Word32) @@ -133,20 +134,20 @@ trim = dropWhileEnd isSpace . dropWhile isSpace -- |Flags affecting how and what type of query to build with 'makePGQuery'. data QueryFlags = QueryFlags - { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment) - , flagNullable :: Bool -- ^ Assume all results are nullable and don't try to guess. + { flagQuery :: Bool -- ^ Create a query -- otherwise just call 'pgSubstituteLiterals' to create a string (SQL fragment). + , flagNullable :: Maybe Bool -- ^ Disable nullability inference, treating all values as nullable (if 'True') or not (if 'False'). , flagPrepare :: Maybe [String] -- ^ Prepare and re-use query, binding parameters of the given types (inferring the rest, like PREPARE). } -- |'QueryFlags' for a default (simple) query. simpleQueryFlags :: QueryFlags -simpleQueryFlags = QueryFlags True False Nothing +simpleQueryFlags = QueryFlags True Nothing Nothing -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do - (pt, rt) <- TH.runIO $ tpgDescribe sqlp (fromMaybe [] prep) (not nulls) + (pt, rt) <- TH.runIO $ tpgDescribe sqlp (fromMaybe [] prep) (isNothing 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" @@ -160,7 +161,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do v <- TH.newName $ 'c':tpgValueName t return ( TH.VarP v - , tpgTypeDecoder t e `TH.AppE` TH.VarE v + , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v , tpgTypeBinary t e )) rt foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser @@ -186,7 +187,8 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do qqQuery :: QueryFlags -> String -> TH.ExpQ qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = qqQuery f{ flagQuery = False } q -qqQuery f@QueryFlags{ flagQuery = True, flagNullable = False } ('?':q) = qqQuery f{ flagNullable = True } q +qqQuery f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('?':q) = qqQuery f{ flagNullable = Just True } q +qqQuery f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('!':q) = qqQuery f{ flagNullable = Just False } q qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = qqQuery f{ flagPrepare = Just args } =<< sql r where args = map trim $ splitCommas arg @@ -215,7 +217,8 @@ qqTop err sql = do -- -- 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 disable nullability inference, treating all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. This makes unexpected NULL errors impossible. +-- [@!@] To disable nullability inference, treating all result values as /not/ nullable, thus only returning 'Maybe' where requested. This is makes unexpected NULL errors more likely. -- [@$@] To create a 'PGPreparedQuery' rather than a 'PGSimpleQuery', by default inferring parameter types. -- [@$(type,...)@] To specify specific types to a prepared query (see for details). -- [@#@] Only do literal @${}@ substitution using 'pgSubstituteLiterals' and return a string, not a query. diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 293cdf7..cb55abd 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -169,9 +169,9 @@ tpgTypeEncoder lit v = typeApply (tpgValueType v) $ else 'pgEncodeParameter -- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value. -tpgTypeDecoder :: TPGValueInfo -> TH.Name -> TH.Exp -tpgTypeDecoder v = typeApply (tpgValueType v) $ - if tpgValueNullable v +tpgTypeDecoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp +tpgTypeDecoder nulls v = typeApply (tpgValueType v) $ + if nulls && tpgValueNullable v then 'pgDecodeColumn else 'pgDecodeColumnNotNull From abb75f8a9b772d287576eb7da0e838f6b8044e9b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 18 Jan 2015 19:58:18 -0500 Subject: [PATCH 121/306] Add partial inet interface --- Database/PostgreSQL/Typed/Inet.hs | 47 +++++++++++++++++++++++++++++++ postgresql-typed.cabal | 1 + 2 files changed, 48 insertions(+) create mode 100644 Database/PostgreSQL/Typed/Inet.hs diff --git a/Database/PostgreSQL/Typed/Inet.hs b/Database/PostgreSQL/Typed/Inet.hs new file mode 100644 index 0000000..5cdc1c3 --- /dev/null +++ b/Database/PostgreSQL/Typed/Inet.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module: Database.PostgreSQL.Typed.Inet +-- Copyright: 2015 Dylan Simon +-- +-- Representaion of PostgreSQL's inet/cidr types using "Network.Socket". +-- We don't (yet) supply PGColumn (parsing) instances. + +module Database.PostgreSQL.Typed.Inet where + +import qualified Data.ByteString.Char8 as BSC +import Data.Maybe (fromJust) +import qualified Network.Socket as Net +import System.IO.Unsafe (unsafeDupablePerformIO) + +import Database.PostgreSQL.Typed.Types + +data PGInet + = PGInet + { pgInetAddr :: !Net.HostAddress + , pgInetMask :: !Int + } + | PGInet6 + { pgInetAddr6 :: !Net.HostAddress6 + , pgInetMask :: !Int + } + +sockAddrPGInet :: Net.SockAddr -> Maybe PGInet +sockAddrPGInet (Net.SockAddrInet _ a) = Just $ PGInet a 32 +sockAddrPGInet (Net.SockAddrInet6 _ _ a _) = Just $ PGInet6 a 128 +sockAddrPGInet _ = Nothing + +instance Show PGInet where + -- This is how Network.Socket's Show SockAddr does it: + show (PGInet a 32) = unsafeDupablePerformIO $ Net.inet_ntoa a + show (PGInet a m) = show (PGInet a 32) ++ '/' : show m + show (PGInet6 a 128) = fromJust $ fst $ unsafeDupablePerformIO $ + Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet6 0 0 a 0) + show (PGInet6 a m) = show (PGInet6 a 128) ++ '/' : show m + +instance PGType "inet" +instance PGType "cidr" +instance PGParameter "inet" PGInet where + pgEncode _ = BSC.pack . show +instance PGParameter "cidr" PGInet where + pgEncode _ = BSC.pack . show diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 611998c..9ea1a94 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -62,6 +62,7 @@ Library Database.PostgreSQL.Typed.Enum Database.PostgreSQL.Typed.Array Database.PostgreSQL.Typed.Range + Database.PostgreSQL.Typed.Inet Database.PostgreSQL.Typed.Dynamic Database.PostgreSQL.Typed.TemplatePG Other-Modules: From 0625c4ae6585d737901dd18fc26a79933502da96 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 24 Jan 2015 00:26:35 -0500 Subject: [PATCH 122/306] More stack-efficient handling of (large) responses --- Database/PostgreSQL/Typed/Protocol.hs | 38 +++++++++++++-------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 4041060..d99c8b5 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -540,14 +540,14 @@ pgSimpleQuery h sql = do pgFlush h go start where go = (pgReceive h >>=) - start (RowDescription rd) = go (row (map colBinary rd)) - start (CommandComplete c) = got c + start (RowDescription rd) = go $ row (map colBinary rd) id + start (CommandComplete c) = got c [] start EmptyQueryResponse = return (0, []) start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m - row bc (DataRow fs) = second (fixBinary bc fs :) <$> go (row bc) - row _ (CommandComplete c) = got c - row _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m - got c = return (rowsAffected c, []) + row bc r (DataRow fs) = go $ row bc (r . (fixBinary bc fs :)) + row _ r (CommandComplete c) = got c (r []) + row _ _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m + got c r = return (rowsAffected c, r) pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do @@ -583,13 +583,13 @@ pgPreparedQuery c sql types bind bc = do pgSend c Sync pgFlush c start - go + go id where - go = pgReceive c >>= row - row (DataRow fs) = second (fixBinary bc fs :) <$> go - row (CommandComplete r) = return (rowsAffected r, []) - row EmptyQueryResponse = return (0, []) - row m = fail $ "pgPreparedQuery: unexpected row: " ++ show m + go r = pgReceive c >>= row r + row r (DataRow fs) = go (r . (fixBinary bc fs :)) + row r (CommandComplete d) = return (rowsAffected d, r []) + row r EmptyQueryResponse = return (0, r []) + row _ m = fail $ "pgPreparedQuery: unexpected row: " ++ show m -- |Like 'pgPreparedQuery' but requests results lazily in chunks of the given size. -- Does not use a named portal, so other requests may not intervene. @@ -600,18 +600,18 @@ pgPreparedLazyQuery c sql types bind bc count = do unsafeInterleaveIO $ do execute start - go + go id where execute = do pgSend c $ Execute count pgSend c $ Flush pgFlush c - go = pgReceive c >>= row - row (DataRow fs) = (fixBinary bc fs :) <$> go - row PortalSuspended = unsafeInterleaveIO (execute >> go) - row (CommandComplete _) = return [] - row EmptyQueryResponse = return [] - row m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m + go r = pgReceive c >>= row r + row r (DataRow fs) = go (r . (fixBinary bc fs :)) + row r PortalSuspended = r <$> unsafeInterleaveIO (execute >> go id) + row r (CommandComplete _) = return (r []) + row r EmptyQueryResponse = return (r []) + row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m -- |Close a previously prepared query (if necessary). pgCloseStatement :: PGConnection -> String -> [OID] -> IO () From 4a3b430e9c5af2493ddca4d58d5f634f541e8365 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 25 Jan 2015 21:11:44 -0500 Subject: [PATCH 123/306] Expose parseQueryFlags, generally useful (if ugly) --- Database/PostgreSQL/Typed/Query.hs | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 3d740cf..5c912f8 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -7,6 +7,7 @@ module Database.PostgreSQL.Typed.Query , rawPGPreparedQuery , QueryFlags(..) , simpleQueryFlags + , parseQueryFlags , makePGQuery , pgSQL , pgExecute @@ -185,17 +186,22 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do (sqlp, exprs) = sqlPlaceholders sqle parse e = either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e -qqQuery :: QueryFlags -> String -> TH.ExpQ -qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = qqQuery f{ flagQuery = False } q -qqQuery f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('?':q) = qqQuery f{ flagNullable = Just True } q -qqQuery f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('!':q) = qqQuery f{ flagNullable = Just False } q -qqQuery f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = qqQuery f{ flagPrepare = Just [] } q -qqQuery f@QueryFlags{ flagQuery = True, 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 +-- |Parse flags off the beginning of a query string, returning the flags and the remaining string. +parseQueryFlags :: String -> (QueryFlags, String) +parseQueryFlags = pqf simpleQueryFlags where + pqf f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('#':q) = pqf f{ flagQuery = False } q + pqf f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('?':q) = pqf f{ flagNullable = Just True } q + pqf f@QueryFlags{ flagQuery = True, flagNullable = Nothing } ('!':q) = pqf f{ flagNullable = Just False } q + pqf f@QueryFlags{ flagQuery = True, flagPrepare = Nothing } ('$':q) = pqf f{ flagPrepare = Just [] } q + pqf f@QueryFlags{ flagQuery = True, flagPrepare = Just [] } ('(':s) = pqf f{ flagPrepare = Just args } (sql r) where + args = map trim $ splitCommas arg + (arg, r) = break (')' ==) s + sql (')':q) = q + sql _ = error "pgSQL: unterminated argument list" + pqf f q = (f, q) + +qqQuery :: String -> TH.ExpQ +qqQuery = uncurry makePGQuery . parseQueryFlags qqTop :: Bool -> String -> TH.DecsQ qqTop True ('!':sql) = qqTop False sql @@ -227,7 +233,7 @@ qqTop err sql = do -- Here the query can only be prefixed with @!@ to make errors non-fatal. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter - { quoteExp = qqQuery simpleQueryFlags + { quoteExp = qqQuery , quoteType = const $ fail "pgSQL not supported in types" , quotePat = const $ fail "pgSQL not supported in patterns" , quoteDec = qqTop True From 1f1fb838d1653fc32ae43e106953485e4a117325 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 31 Jan 2015 10:38:16 -0500 Subject: [PATCH 124/306] Overload string literals as simple queries --- Database/PostgreSQL/Typed/Query.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 5c912f8..9c5de8a 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -24,6 +24,7 @@ import Data.Char (isDigit, isSpace) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing) +import Data.String (IsString(..)) import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH @@ -51,11 +52,13 @@ pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] pgQuery c q = snd <$> pgRunQuery c q -data SimpleQuery = SimpleQuery String +newtype SimpleQuery = SimpleQuery String instance PGQuery SimpleQuery PGValues where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql instance PGRawQuery SimpleQuery where +instance IsString SimpleQuery where + fromString = SimpleQuery data PreparedQuery = PreparedQuery String [OID] PGValues [Bool] instance PGQuery PreparedQuery PGValues where @@ -82,6 +85,9 @@ type PGPreparedQuery = QueryParser PreparedQuery rawPGSimpleQuery :: String -> PGSimpleQuery PGValues rawPGSimpleQuery = rawParser . SimpleQuery +instance IsString (PGSimpleQuery PGValues) where + fromString = rawPGSimpleQuery + -- |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 [] From 8b6adb8d7a7c961adaac0f92b1fc61288771c66f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 31 Jan 2015 15:34:37 -0500 Subject: [PATCH 125/306] More practical tweak to previous string overloads --- Database/PostgreSQL/Typed/Query.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 9c5de8a..b0bffe9 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -51,19 +51,18 @@ pgExecute c q = fst <$> pgRunQuery c q pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] pgQuery c q = snd <$> pgRunQuery c q +instance PGQuery String PGValues where + pgRunQuery c sql = pgSimpleQuery c sql newtype SimpleQuery = SimpleQuery String instance PGQuery SimpleQuery PGValues where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql -instance PGRawQuery SimpleQuery where - -instance IsString SimpleQuery where - fromString = SimpleQuery +instance PGRawQuery SimpleQuery 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 +instance PGRawQuery PreparedQuery data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a) From 6a32ac53cdf4c9ece3741e36cd64de0f31bf94c3 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 3 Feb 2015 00:45:41 -0500 Subject: [PATCH 126/306] Tighten down dependencies Due to cross-dependency incompatibilities --- postgresql-typed.cabal | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 9ea1a94..ff03c16 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -46,7 +46,11 @@ Flag scientific Library Build-Depends: base >= 4.7 && < 5, - array, binary, containers, old-locale, time, + array, + binary, + containers < 0.5.6, + old-locale, + time < 1.5, bytestring >= 0.10.2, template-haskell, haskell-src-meta, From 6e5a00155f547494fef6bb648739e76c683ff5b5 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 6 Feb 2015 17:16:08 -0500 Subject: [PATCH 127/306] Add PGQuery.unsafeModifyQuery to support some dynamic queries --- Database/PostgreSQL/Typed/Query.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index b0bffe9..cb7e384 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -40,6 +40,10 @@ 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, [a]) + -- |Change the raw SQL query stored within this query. + -- This is unsafe because the query has already been type-checked, so any change must not change the number or type of results or placeholders (so adding additional static WHERE or ORDER BY clauses is generally safe). + -- This is useful in cases where you need to construct some part of the query dynamically, but still want to infer the result types. + unsafeModifyQuery :: q -> (String -> String) -> q class PGQuery q PGValues => PGRawQuery q -- |Execute a query that does not return results. @@ -53,21 +57,25 @@ pgQuery c q = snd <$> pgRunQuery c q instance PGQuery String PGValues where pgRunQuery c sql = pgSimpleQuery c sql + unsafeModifyQuery q f = f q newtype SimpleQuery = SimpleQuery String instance PGQuery SimpleQuery PGValues where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql + unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql instance PGRawQuery SimpleQuery 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 + unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc instance PGRawQuery PreparedQuery data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a) instance PGRawQuery q => PGQuery (QueryParser q a) a where pgRunQuery c (QueryParser q p) = second (fmap $ p e) <$> pgRunQuery c (q e) where e = pgTypeEnv c + unsafeModifyQuery (QueryParser q p) f = QueryParser (\e -> unsafeModifyQuery (q e) f) p instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) From 8acdc1bf5c80aeee3fd4d0791ceda262f7d16166 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 6 Feb 2015 23:44:05 -0500 Subject: [PATCH 128/306] Correct makePGEnum documentation --- Database/PostgreSQL/Typed/Dynamic.hs | 24 ++++++++++++------------ Database/PostgreSQL/Typed/Enum.hs | 6 ++++-- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 673932e..f9718ba 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -62,17 +62,17 @@ instance PGRep t a => PGRep t (Maybe a) where pgDecodeRep PGNullValue = Nothing pgDecodeRep v = Just (pgDecodeRep v) -instance PGRep "boolean" Bool where -instance PGRep "oid" OID where -instance PGRep "smallint" Int16 where -instance PGRep "integer" Int32 where -instance PGRep "bigint" Int64 where -instance PGRep "real" Float where -instance PGRep "double precision" Double where -instance PGRep "\"char\"" Char where -instance PGRep "text" String where +instance PGRep "boolean" Bool +instance PGRep "oid" OID +instance PGRep "smallint" Int16 +instance PGRep "integer" Int32 +instance PGRep "bigint" Int64 +instance PGRep "real" Float +instance PGRep "double precision" Double +instance PGRep "\"char\"" Char +instance PGRep "text" String #ifdef USE_TEXT -instance PGRep "text" T.Text where +instance PGRep "text" T.Text #endif instance PGRep "date" Time.Day instance PGRep "time without time zone" Time.TimeOfDay @@ -81,10 +81,10 @@ instance PGRep "timestamp with time zone" Time.UTCTime instance PGRep "interval" Time.DiffTime instance PGRep "numeric" Rational #ifdef USE_SCIENTIFIC -instance PGRep "numeric" Scientific where +instance PGRep "numeric" Scientific #endif #ifdef USE_UUID -instance PGRep "uuid" UUID.UUID where +instance PGRep "uuid" UUID.UUID #endif -- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@. diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index c4bc537..6896417 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -25,8 +25,10 @@ import Database.PostgreSQL.Typed.Dynamic -- -- @ -- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read) --- instance PGType Foo where ... --- registerPGType \"foo\" (ConT ''Foo) +-- instance PGType \"foo\" +-- instance PGParameter \"foo\" Foo where ... +-- instance PGColumn \"foo\" Foo where ... +-- instance PGRep \"foo\" Foo -- @ -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds From c188d2c8551a07c74ab55964678483690ecca688 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Feb 2015 00:09:05 -0500 Subject: [PATCH 129/306] Derive Typeable instance for PGEnum --- Database/PostgreSQL/Typed/Enum.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 6896417..76027c3 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -12,6 +12,7 @@ module Database.PostgreSQL.Typed.Enum import Control.Monad (when) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.UTF8 as U +import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH import Database.PostgreSQL.Typed.Protocol @@ -24,14 +25,14 @@ import Database.PostgreSQL.Typed.Dynamic -- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: -- -- @ --- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read) +-- data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable) -- instance PGType \"foo\" -- instance PGParameter \"foo\" Foo where ... -- instance PGColumn \"foo\" Foo where ... -- instance PGRep \"foo\" Foo -- @ -- --- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, 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_\"++)@ @@ -45,7 +46,7 @@ makePGEnum name typs valnf = do dv <- TH.newName "x" ds <- TH.newName "s" return - [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Show, ''Read] + [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Show, ''Read, ''Typeable] , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgEncode $ map (\(l, n) -> TH.Clause [TH.WildP, TH.ConP n []] From f2cdcd9387ac02534d666862afce4275d42da292 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Feb 2015 01:11:55 -0500 Subject: [PATCH 130/306] Add PGEnum.pgEnumValues --- Database/PostgreSQL/Typed/Enum.hs | 32 +++++++++++++++++++++---------- test/Main.hs | 4 +++- 2 files changed, 25 insertions(+), 11 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 76027c3..ee5248c 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -6,7 +6,8 @@ -- Support for PostgreSQL enums. module Database.PostgreSQL.Typed.Enum - ( makePGEnum + ( PGEnum(..) + , makePGEnum ) where import Control.Monad (when) @@ -20,17 +21,21 @@ import Database.PostgreSQL.Typed.TH import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic +-- |A type based on a PostgreSQL enum. Automatically instantiated by 'makePGEnum'. +class (Eq a, Ord a, Enum a, Bounded a) => PGEnum a where + -- |List of all the values in this enum along with their database names. + pgEnumValues :: [(a, String)] + -- |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, Show, Read, Typeable) --- instance PGType \"foo\" --- instance PGParameter \"foo\" Foo where ... --- instance PGColumn \"foo\" Foo where ... --- instance PGRep \"foo\" Foo --- @ +-- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable) +-- > instance PGType "foo" +-- > instance PGParameter "foo" Foo where ... +-- > instance PGColumn "foo" Foo where ... +-- > instance PGRep "foo" Foo +-- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds makePGEnum :: String -- ^ PostgreSQL enum type name @@ -50,7 +55,8 @@ makePGEnum name typs valnf = do , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `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.NormalB $ TH.VarE 'BSC.pack `TH.AppE` TH.LitE l) []) valn + ] , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `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) -> @@ -58,8 +64,14 @@ makePGEnum name typs valnf = do [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)) []]) - []] ] + []] + ] , TH.InstanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) [] + , TH.InstanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) + [ TH.ValD (TH.VarP 'pgEnumValues) + (TH.NormalB $ TH.ListE $ map (\(v, n) -> TH.ConE '(,) `TH.AppE` TH.ConE n `TH.AppE` TH.LitE v) valn) + [] + ] ] where typn = TH.mkName typs diff --git a/test/Main.hs b/test/Main.hs index 6700769..89e1cc8 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where @@ -61,5 +61,7 @@ main = do assert $ [pgSQL|#abc${f}def|] == "abc3.14::realdef" + assert $ pgEnumValues == [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] + pgDisconnect c exitSuccess From 21f22a902fee1d92c81cda20380a83e5b7f73430 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Feb 2015 20:05:08 -0500 Subject: [PATCH 131/306] Improve parse errors to help debugging Should have no performance impact, as SourceName is lazy --- Database/PostgreSQL/Typed/Array.hs | 2 +- Database/PostgreSQL/Typed/Range.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 920c552..767b11b 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -38,7 +38,7 @@ instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where el Nothing = BSB.string7 "null" el (Just e) = pgDQuote (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 + pgDecode ta a = either (error . ("pgDecode array: " ++) . show) id $ P.parse pa (BSC.unpack a) a where pa = do l <- P.between (P.char '{') (P.char '}') $ P.sepBy nel (P.char (pgArrayDelim ta)) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 1d1612e..d569e05 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -167,7 +167,7 @@ instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range a) where pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b pc c o b = BSB.char7 $ if boundClosed b then c else o instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where - pgDecode tr = either (error . ("pgDecode range: " ++) . show) id . P.parse per "range" where + pgDecode tr a = either (error . ("pgDecode range: " ++) . show) id $ P.parse per (BSC.unpack a) a where per = 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 <$> parsePGDQuote "(),[]" diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index be003b7..69f327f 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -455,7 +455,7 @@ instance PGParameter "interval" Time.DiffTime where -- 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 + pgDecode _ a = either (error . ("pgDecode interval: " ++) . show) id $ P.parse ps (BSC.unpack a) a where ps = do _ <- P.char 'P' d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)] @@ -547,7 +547,7 @@ instance PGRecordType t => PGParameter t [Maybe PGTextValue] where pgLiteral _ l = "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where instance PGRecordType t => PGColumn t [Maybe PGTextValue] where - pgDecode _ = either (error . ("pgDecode record: " ++) . show) id . P.parse pa "record" where + pgDecode _ a = either (error . ("pgDecode record: " ++) . show) id $ P.parse pa (BSC.unpack a) a where pa = do l <- P.between (P.char '(') (P.char ')') $ P.sepBy nel (P.char ',') From 3e5080b7fe6b4d3a15ad31e848b259a76073bbe1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Feb 2015 20:28:42 -0500 Subject: [PATCH 132/306] Fix parsing of nulls in arrays and records --- Database/PostgreSQL/Typed/Array.hs | 10 +++++----- Database/PostgreSQL/Typed/Range.hs | 3 +-- Database/PostgreSQL/Typed/Types.hs | 14 ++++++++------ test/Main.hs | 2 +- 4 files changed, 15 insertions(+), 14 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 767b11b..1463cde 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -10,9 +10,10 @@ module Database.PostgreSQL.Typed.Array where -import Control.Applicative ((<$>), (<$)) +import Control.Applicative ((<$>)) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC +import Data.Char (toLower) import Data.List (intersperse) import Data.Monoid ((<>), mconcat) import qualified Text.Parsec as P @@ -41,12 +42,11 @@ instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where pgDecode ta a = either (error . ("pgDecode array: " ++) . show) id $ P.parse pa (BSC.unpack a) a where pa = do l <- P.between (P.char '{') (P.char '}') $ - P.sepBy nel (P.char (pgArrayDelim ta)) + P.sepBy el (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 <$> parsePGDQuote (pgArrayDelim ta : "{}") + el = P.between P.spaces P.spaces $ fmap (pgDecode (pgArrayElementType ta) . BSC.pack) <$> + parsePGDQuote (pgArrayDelim ta : "{}") (("null" ==) . map toLower) -- Just a dump of pg_type: instance PGType "boolean" => PGType "boolean[]" diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index d569e05..324e184 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -170,9 +170,8 @@ instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where pgDecode tr a = either (error . ("pgDecode range: " ++) . show) id $ P.parse per (BSC.unpack a) a where per = 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 <$> parsePGDQuote "(),[]" + pb = fmap (pgDecode (pgRangeElementType tr) . BSC.pack) <$> parsePGDQuote "(),[]" null pc c o = True <$ P.char c P.<|> False <$ P.char o - pb = P.optionMaybe $ P.between P.spaces P.spaces $ pp mb = maybe Unbounded . Bounded pr = do lc <- pc '[' '(' diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 69f327f..434879c 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -192,11 +192,14 @@ pgDQuote unsafe s bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) -- |Parse double-quoted values ala 'pgDQuote'. -parsePGDQuote :: P.Stream s m Char => String -> P.ParsecT s u m String -parsePGDQuote unsafe = (q P.<|> uq) where +parsePGDQuote :: P.Stream s m Char => String -> (String -> Bool) -> P.ParsecT s u m (Maybe String) +parsePGDQuote unsafe isnul = (Just <$> q P.<|> mnul <$> uq) where q = P.between (P.char '"') (P.char '"') $ P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" - uq = P.many1 (P.noneOf ('"':'\\':unsafe)) + uq = P.many (P.noneOf ('"':'\\':unsafe)) + mnul s + | isnul s = Nothing + | otherwise = Just s #ifdef USE_BINARY binDec :: PGType t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a @@ -550,11 +553,10 @@ instance PGRecordType t => PGColumn t [Maybe PGTextValue] where pgDecode _ a = either (error . ("pgDecode record: " ++) . show) id $ P.parse pa (BSC.unpack a) a where pa = do l <- P.between (P.char '(') (P.char ')') $ - P.sepBy nel (P.char ',') + P.sepBy el (P.char ',') _ <- P.eof return l - nel = P.optionMaybe $ P.between P.spaces P.spaces el - el = BSC.pack <$> parsePGDQuote "()," + el = fmap BSC.pack <$> parsePGDQuote "()," null instance PGType "record" -- |The generic anonymous record type, as created by @ROW@. diff --git a/test/Main.hs b/test/Main.hs index 89e1cc8..aa79e9c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -45,7 +45,7 @@ main = do d = Time.localDay t p = -34881559 :: Time.DiffTime s = "\"hel\\o'" - l = [Just "a\\\"b,c", Nothing] + l = [Just "a\\\"b,c", Nothing, Just "null", Just "nullish"] 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 From 7072060d291548c0ca955d311955a0e49dbfc56a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Feb 2015 21:18:18 -0500 Subject: [PATCH 133/306] Make PGEnum Show instance use database values Remove Read instance for now, mainly lazy --- Database/PostgreSQL/Typed/Enum.hs | 42 +++++++++++++++++-------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index ee5248c..30f6b44 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -6,11 +6,13 @@ -- Support for PostgreSQL enums. module Database.PostgreSQL.Typed.Enum - ( PGEnum(..) + ( PGEnum + , pgEnumValues , makePGEnum ) where import Control.Monad (when) +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.UTF8 as U import Data.Typeable (Typeable) @@ -22,15 +24,18 @@ import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic -- |A type based on a PostgreSQL enum. Automatically instantiated by 'makePGEnum'. -class (Eq a, Ord a, Enum a, Bounded a) => PGEnum a where - -- |List of all the values in this enum along with their database names. - pgEnumValues :: [(a, String)] +class (Eq a, Ord a, Enum a, Bounded a, Show a) => PGEnum a + +-- |List of all the values in the enum along with their database names. +pgEnumValues :: PGEnum a => [(a, String)] +pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- |Create a new enum type corresponding to the given PostgreSQL enum type. -- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\');@, then -- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: -- --- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable) +-- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable) +-- > instance Show Foo where show Foo_abc = "abc" ... -- > instance PGType "foo" -- > instance PGParameter "foo" Foo where ... -- > instance PGColumn "foo" Foo where ... @@ -47,31 +52,30 @@ makePGEnum name typs valnf = do 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 (null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let - valn = map (\[PGTextValue v] -> (TH.StringL (BSC.unpack v), TH.mkName $ valnf (U.toString v))) vals + valn = map (\[PGTextValue v] -> let u = U.toString v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals dv <- TH.newName "x" - ds <- TH.newName "s" return - [ TH.DataD [] typn [] (map (\(_, n) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Show, ''Read, ''Typeable] + [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Typeable] + , TH.InstanceD [] (TH.ConT ''Show `TH.AppT` typt) + [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []] + (TH.NormalB $ TH.LitE v) []) valn + ] , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `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.FunD 'pgEncode $ map (\(n, l, _) -> TH.Clause [TH.WildP, TH.ConP n []] + (TH.NormalB $ TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) []) valn ] , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `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)) + (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l, _) -> + TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE n) []) valn ++ + [TH.Match TH.WildP (TH.NormalB $ TH.AppE (TH.VarE 'error) $ + TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) []]) []] ] , TH.InstanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) [] - , TH.InstanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) - [ TH.ValD (TH.VarP 'pgEnumValues) - (TH.NormalB $ TH.ListE $ map (\(v, n) -> TH.ConE '(,) `TH.AppE` TH.ConE n `TH.AppE` TH.LitE v) valn) - [] - ] + , TH.InstanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) [] ] where typn = TH.mkName typs From 94b662a028872c1bbe6462576104d64e5e4fd620 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Feb 2015 21:51:54 -0500 Subject: [PATCH 134/306] Wrap PGRecord in newtype To avoid interfering with PGArray --- Database/PostgreSQL/Typed/Types.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 434879c..48e9a11 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -14,6 +14,7 @@ module Database.PostgreSQL.Typed.Types , PGTypeName(..) , PGTypeEnv(..) , unknownPGTypeEnv + , PGRecord(..) -- * Marshalling classes , PGType(..) @@ -543,14 +544,15 @@ instance PGColumn "uuid" UUID.UUID where #endif -- |Generic class of composite (row or record) types. +newtype PGRecord = PGRecord [Maybe PGTextValue] class PGType t => PGRecordType t -instance PGRecordType t => PGParameter t [Maybe PGTextValue] where - pgEncode _ l = +instance PGRecordType t => PGParameter t PGRecord where + pgEncode _ (PGRecord l) = buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where - pgLiteral _ l = + pgLiteral _ (PGRecord l) = "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where -instance PGRecordType t => PGColumn t [Maybe PGTextValue] where - pgDecode _ a = either (error . ("pgDecode record: " ++) . show) id $ P.parse pa (BSC.unpack a) a where +instance PGRecordType t => PGColumn t PGRecord where + pgDecode _ a = either (error . ("pgDecode record: " ++) . show) PGRecord $ P.parse pa (BSC.unpack a) a where pa = do l <- P.between (P.char '(') (P.char ')') $ P.sepBy el (P.char ',') From 651654c114017aa0680f552ea077ca8331bf856e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 9 Feb 2015 22:50:47 -0500 Subject: [PATCH 135/306] Update maintainer --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index ff03c16..ab45c71 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -5,7 +5,7 @@ License: BSD3 License-File: COPYING Copyright: 2010-2013 Chris Forno, 2014-2015 Dylan Simon Author: Dylan Simon -Maintainer: dylan@dylex.net +Maintainer: Dylan Simon Stability: alpha Bug-Reports: https://github.com/dylex/postgresql-typed/issues Homepage: https://github.com/dylex/postgresql-typed From 10290b0aa09243333409d170a333f00814abea5c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 22 Feb 2015 11:38:49 -0500 Subject: [PATCH 136/306] Add support for JSON types via aeson --- Database/PostgreSQL/Typed/Types.hs | 19 ++++++++++++++++++- postgresql-typed.cabal | 9 ++++++++- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 48e9a11..b0f58f9 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -36,6 +36,10 @@ module Database.PostgreSQL.Typed.Types import Control.Applicative ((<$>), (<$)) import Control.Monad (mzero) +#ifdef USE_AESON +import qualified Data.Aeson as JSON +import qualified Data.Attoparsec.ByteString as JSONP +#endif import Data.Bits (shiftL, (.|.)) import Data.ByteString.Internal (w2c) import qualified Data.ByteString as BS @@ -565,8 +569,21 @@ instance PGType "record" -- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). instance PGRecordType "record" +#ifdef USE_AESON +instance PGType "json" +instance PGParameter "json" JSON.Value where + pgEncode _ = BSL.toStrict . JSON.encode +instance PGColumn "json" JSON.Value where + pgDecode _ j = either (error . ("pgDecode json: " ++)) id $ JSONP.parseOnly JSON.json j + +instance PGType "jsonb" +instance PGParameter "jsonb" JSON.Value where + pgEncode _ = BSL.toStrict . JSON.encode +instance PGColumn "jsonb" JSON.Value where + pgDecode _ j = either (error . ("pgDecode json: " ++)) id $ JSONP.parseOnly JSON.json j +#endif + {- ---, ( 114, 199, "json", ?) --, ( 142, 143, "xml", ?) --, ( 600, 1017, "point", ?) --, ( 650, 651, "cidr", ?) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index ab45c71..257c73c 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.3.2 +Version: 0.3.3 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING @@ -43,6 +43,10 @@ Flag scientific Description: Support decoding numeric via scientific (implied by binary). Default: True +Flag aeson + Description: Support decoding json via aeson. + Default: True + Library Build-Depends: base >= 4.7 && < 5, @@ -88,6 +92,9 @@ Library if flag(scientific) Build-Depends: scientific >= 0.3 CPP-options: -DUSE_SCIENTIFIC + if flag(aeson) + Build-Depends: aeson >= 0.7, attoparsec >= 0.10 + CPP-options: -DUSE_AESON test-suite test build-depends: base, network, time, postgresql-typed From 11f936ede1c15ec3390910f41e987251587942f9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 23 Feb 2015 00:26:45 -0500 Subject: [PATCH 137/306] Fix insertIgnore error code --- Database/PostgreSQL/Typed/TemplatePG.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index e3b2918..f5c2721 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -87,7 +87,7 @@ 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") + uniquenessError (PG.PGError m) = guard (PG.pgMessageCode m == "23505") type PGException = PG.PGError From 219d34914d69a9d6fa7604a082ec19c03fd13eae Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 7 Mar 2015 22:54:34 -0500 Subject: [PATCH 138/306] Add Range field accessors --- Database/PostgreSQL/Typed/Query.hs | 2 ++ Database/PostgreSQL/Typed/Range.hs | 25 +++++++++++++++---------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index cb7e384..f8bacfd 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -94,6 +94,8 @@ rawPGSimpleQuery = rawParser . SimpleQuery instance IsString (PGSimpleQuery PGValues) where fromString = rawPGSimpleQuery +instance IsString (PGSimpleQuery ()) where + fromString = fmap (const ()) . rawPGSimpleQuery -- |Make a prepared query directly from a query string and bind parameters, with no type inference rawPGPreparedQuery :: String -> PGValues -> PGPreparedQuery PGValues diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 324e184..00af00b 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range @@ -28,10 +28,7 @@ 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) +newtype LowerBound a = Lower { boundLower :: Bound a } deriving (Eq, Functor) instance Ord a => Ord (LowerBound a) where compare (Lower Unbounded) (Lower Unbounded) = EQ @@ -39,10 +36,7 @@ instance Ord a => Ord (LowerBound a) where 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) +newtype UpperBound a = Upper { boundUpper :: Bound a } deriving (Eq, Functor) instance Ord a => Ord (UpperBound a) where compare (Upper Unbounded) (Upper Unbounded) = EQ @@ -52,7 +46,10 @@ instance Ord a => Ord (UpperBound a) where data Range a = Empty - | Range (LowerBound a) (UpperBound a) + | Range + { lower :: LowerBound a + , upper :: UpperBound a + } deriving (Eq) instance Functor Range where @@ -79,6 +76,14 @@ makeBound c (Just a) = Bounded c a makeBound False Nothing = Unbounded makeBound True Nothing = error "makeBound: unbounded may not be closed" +lowerBound :: Range a -> Bound a +lowerBound Empty = Unbounded +lowerBound (Range (Lower b) _) = b + +upperBound :: Range a -> Bound a +upperBound Empty = Unbounded +upperBound (Range _ (Upper b)) = b + lowerClosed :: Range a -> Bool lowerClosed Empty = False lowerClosed (Range (Lower b) _) = boundClosed b From 86cf59974fd888045bfc4d774f3d8bc61b19749f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 10 Mar 2015 21:24:40 -0400 Subject: [PATCH 139/306] Add PGColumn "void" () instance Arises in "SELECT function_returning_void()" statements. --- Database/PostgreSQL/Typed/Types.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index b0f58f9..ce73c78 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -219,6 +219,12 @@ binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ #define BIN_DEC(F) #endif +instance PGType "void" +instance PGColumn "void" () where + pgDecode _ _ = () + pgDecodeBinary _ _ _ = () + pgDecodeValue _ _ _ = () + instance PGType "boolean" where BIN_COL instance PGParameter "boolean" Bool where pgEncode _ False = BSC.singleton 'f' From 263c77fa5648ef5297dbfe56e8b8b192073dc70f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 10 Mar 2015 21:35:04 -0400 Subject: [PATCH 140/306] Special case "void" results to be not-nullable They are actually nullable, but assuming they're not is harmless since we don't use the returned value. --- Database/PostgreSQL/Typed/TH.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index cb55abd..ff82d74 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -151,7 +151,7 @@ tpgDescribe sql types nulls = withTPGState $ \tpg -> do { tpgValueName = c , tpgValueTypeOID = o , tpgValueType = tpgType tpg o - , tpgValueNullable = n + , tpgValueNullable = n && o /= 2278 -- "void" }) rt ) From 9518768d49af8148a1338ce78ceff1401bbbda78 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 12 Mar 2015 00:16:30 -0400 Subject: [PATCH 141/306] Change pgMessageCode to pgErrorCode --- Database/PostgreSQL/Typed/Protocol.hs | 8 ++++---- Database/PostgreSQL/Typed/TemplatePG.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index d99c8b5..1675cab 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -11,7 +11,7 @@ module Database.PostgreSQL.Typed.Protocol ( , defaultPGDatabase , PGConnection , PGError(..) - , pgMessageCode + , pgErrorCode , pgTypeEnv , pgConnect , pgDisconnect @@ -170,7 +170,7 @@ data PGBackendMessage -- |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 +data PGError = PGError { pgErrorFields :: MessageFields } deriving (Typeable) instance Show PGError where @@ -188,8 +188,8 @@ makeMessage m d = Map.fromAscList [('D', d), ('M', m)] -- |Message SQLState code. -- See . -pgMessageCode :: MessageFields -> String -pgMessageCode = Map.findWithDefault "" 'C' +pgErrorCode :: PGError -> String +pgErrorCode (PGError e) = Map.findWithDefault "" 'C' e defaultLogMessage :: MessageFields -> IO () defaultLogMessage = hPutStrLn stderr . displayMessage diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index f5c2721..20671b4 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -87,7 +87,7 @@ 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 == "23505") + uniquenessError e = guard (PG.pgErrorCode e == "23505") type PGException = PG.PGError From 896f9386e97b9cf59a050839fec18f9f9e97b607 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 13 Mar 2015 23:24:44 -0400 Subject: [PATCH 142/306] Add Monoid Range instance --- Database/PostgreSQL/Typed/Range.hs | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 00af00b..aabbe90 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range @@ -14,7 +14,7 @@ import Control.Applicative ((<$>), (<$)) import Control.Monad (guard) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC -import Data.Monoid ((<>), mempty) +import Data.Monoid (Monoid(..), (<>)) import qualified Text.Parsec as P import Database.PostgreSQL.Typed.Types @@ -44,6 +44,14 @@ instance Ord a => Ord (UpperBound a) where compare _ (Upper Unbounded) = LT compare (Upper (Bounded ac a)) (Upper (Bounded bc b)) = compare a b <> compare ac bc +compareBounds :: Ord a => LowerBound a -> UpperBound a -> Bound Bool +compareBounds (Lower (Bounded lc l)) (Upper (Bounded uc u)) = + case compare l u of + LT -> Bounded True True + EQ -> Bounded (lc /= uc) (lc && uc) + GT -> Bounded False False +compareBounds _ _ = Unbounded + data Range a = Empty | Range @@ -94,9 +102,9 @@ 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 +isEmpty (Range l u) + | Bounded _ n <- compareBounds l u = not n + | otherwise = False full :: Range a full = Range (Lower Unbounded) (Upper Unbounded) @@ -152,6 +160,18 @@ 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 +instance Ord a => Monoid (Range a) where + mempty = Empty + -- |Union ranges. Fails if ranges are disjoint. + mappend Empty r = r + mappend r Empty = r + mappend _ra@(Range la ua) _rb@(Range lb ub) + -- | isEmpty _ra = _rb + -- | isEmpty _rb = _ra + | Bounded False False <- compareBounds lb ua = error "mappend: disjoint Ranges" + | Bounded False False <- compareBounds la ub = error "mappend: disjoint Ranges" + | otherwise = Range (min la lb) (max ua ub) + -- |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. From 3d4a42d5074d68f80c7c4f64260758ebe19de792 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 14 Mar 2015 16:12:14 -0400 Subject: [PATCH 143/306] Make Range.normal return point if bounds are equal --- Database/PostgreSQL/Typed/Range.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index aabbe90..7e2a693 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -124,11 +124,11 @@ 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 +normal l u = range (mb True l) (mb (l == u) u) where mb = maybe Unbounded . Bounded bounded :: Ord a => a -> a -> Range a -bounded l u = range (Bounded True l) (Bounded False u) +bounded l u = normal (Just l) (Just u) normalize :: Ord a => Range a -> Range a normalize r From fe932bc5450f60f59e8762838855d2e97907b419 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 14 Mar 2015 16:16:47 -0400 Subject: [PATCH 144/306] Add Range.empty for completeness --- Database/PostgreSQL/Typed/Range.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 7e2a693..173126a 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -100,6 +100,9 @@ upperClosed :: Range a -> Bool upperClosed Empty = False upperClosed (Range _ (Upper b)) = boundClosed b +empty :: Range a +empty = Empty + isEmpty :: Ord a => Range a -> Bool isEmpty Empty = True isEmpty (Range l u) From f750b28a26e0fcd06f3e1fce172792e58254d7ea Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 5 Apr 2015 13:50:27 -0400 Subject: [PATCH 145/306] More documentation for Range --- Database/PostgreSQL/Typed/Range.hs | 34 +++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 173126a..ad83b02 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -19,9 +19,13 @@ import qualified Text.Parsec as P import Database.PostgreSQL.Typed.Types +-- |A end-point for a range, which may be nothing (infinity, NULL in PostgreSQL), open (inclusive), or closed (exclusive) data Bound a - = Unbounded - | Bounded Bool a + = Unbounded -- ^ Equivalent to @Bounded False ±Infinity@ + | Bounded + { _boundClosed :: Bool -- ^ @True@ if the range includes this bound + , _bound :: a + } deriving (Eq) instance Functor Bound where @@ -30,20 +34,32 @@ instance Functor Bound where newtype LowerBound a = Lower { boundLower :: Bound a } deriving (Eq, Functor) +-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds) instance Ord a => Ord (LowerBound a) where compare (Lower Unbounded) (Lower Unbounded) = EQ compare (Lower Unbounded) _ = LT compare _ (Lower Unbounded) = GT compare (Lower (Bounded ac a)) (Lower (Bounded bc b)) = compare a b <> compare bc ac +-- |The constraint is only necessary for @maxBound@, unfortunately +instance Bounded a => Bounded (LowerBound a) where + minBound = Lower Unbounded + maxBound = Lower (Bounded False maxBound) + newtype UpperBound a = Upper { boundUpper :: Bound a } deriving (Eq, Functor) +-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds) instance Ord a => Ord (UpperBound a) where compare (Upper Unbounded) (Upper Unbounded) = EQ compare (Upper Unbounded) _ = GT compare _ (Upper Unbounded) = LT compare (Upper (Bounded ac a)) (Upper (Bounded bc b)) = compare a b <> compare ac bc +-- |The constraint is only necessary for @minBound@, unfortunately +instance Bounded a => Bounded (UpperBound a) where + minBound = Upper (Bounded False minBound) + maxBound = Upper Unbounded + compareBounds :: Ord a => LowerBound a -> UpperBound a -> Bound Bool compareBounds (Lower (Bounded lc l)) (Upper (Bounded uc u)) = case compare l u of @@ -75,27 +91,33 @@ bound :: Bound a -> Maybe a bound Unbounded = Nothing bound (Bounded _ b) = Just b +-- |Unbounded endpoints are always open. boundClosed :: Bound a -> Bool boundClosed Unbounded = False boundClosed (Bounded c _) = c +-- |Construct from parts: @makeBound (boundClosed b) (bound b) == b@ makeBound :: Bool -> Maybe a -> Bound a makeBound c (Just a) = Bounded c a makeBound False Nothing = Unbounded makeBound True Nothing = error "makeBound: unbounded may not be closed" +-- |Empty ranges treated as 'Unbounded' lowerBound :: Range a -> Bound a lowerBound Empty = Unbounded lowerBound (Range (Lower b) _) = b +-- |Empty ranges treated as 'Unbounded' upperBound :: Range a -> Bound a upperBound Empty = Unbounded upperBound (Range _ (Upper b)) = b +-- |Equivalent to @boundClosed . lowerBound@ lowerClosed :: Range a -> Bool lowerClosed Empty = False lowerClosed (Range (Lower b) _) = boundClosed b +-- |Equivalent to @boundClosed . upperBound@ upperClosed :: Range a -> Bool upperClosed Empty = False upperClosed (Range _ (Upper b)) = boundClosed b @@ -116,23 +138,29 @@ isFull :: Range a -> Bool isFull (Range (Lower Unbounded) (Upper Unbounded)) = True isFull _ = False +-- |Create a point range @[x,x]@ point :: Eq a => a -> Range a point a = Range (Lower (Bounded True a)) (Upper (Bounded True a)) +-- |Extract a point: @getPoint (point x) == Just x@ getPoint :: Eq a => Range a -> Maybe a getPoint (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = u <$ guard (u == l) getPoint _ = Nothing +-- Construct a range from endpoints and normalize it. range :: Ord a => Bound a -> Bound a -> Range a range l u = normalize $ Range (Lower l) (Upper u) +-- Construct a standard range (@[l,u)@ or 'point') from bounds (like 'bound') and normalize it. normal :: Ord a => Maybe a -> Maybe a -> Range a normal l u = range (mb True l) (mb (l == u) u) where mb = maybe Unbounded . Bounded +-- Construct a bounded range like 'normal'. bounded :: Ord a => a -> a -> Range a bounded l u = normal (Just l) (Just u) +-- Fold empty ranges to 'Empty'. normalize :: Ord a => Range a -> Range a normalize r | isEmpty r = Empty @@ -141,7 +169,7 @@ normalize 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' +normalize' (Range (Lower l) (Upper u)) = normalize $ range l' u' where l' = case l of Bounded False b -> Bounded True (succ b) From bd08191bd21cc24b12cf1ae9935a38067e84c040 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 12 Apr 2015 00:09:19 -0400 Subject: [PATCH 146/306] Add Range.overlaps Should I have more postgresql-like operators for these things? Many conflict... --- Database/PostgreSQL/Typed/Range.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index ad83b02..fd52059 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -178,15 +178,20 @@ normalize' (Range (Lower l) (Upper u)) = normalize $ range l' u' Bounded True b -> Bounded False (succ b) _ -> l +-- |Contains range (@>), (<@) :: Ord a => Range a -> Range a -> Bool _ @> Empty = True Empty @> r = isEmpty r Range la ua @> Range lb ub = la <= lb && ua >= ub a <@ b = b @> a +-- |Contains element (@>.) :: Ord a => Range a -> a -> Bool r @>. a = r @> point a +overlaps :: Ord a => Range a -> Range a -> Bool +overlaps a b = intersect a b /= Empty + intersect :: Ord a => Range a -> Range a -> Range a intersect (Range la ua) (Range lb ub) = normalize $ Range (max la lb) (min ua ub) intersect _ _ = Empty From 326afe9cf3994b4b8f160098404c8f32fc98f651 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 12 Apr 2015 01:15:13 -0400 Subject: [PATCH 147/306] Fix haddock errors from commented code --- Database/PostgreSQL/Typed/Range.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index fd52059..6fffa44 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -202,8 +202,8 @@ instance Ord a => Monoid (Range a) where mappend Empty r = r mappend r Empty = r mappend _ra@(Range la ua) _rb@(Range lb ub) - -- | isEmpty _ra = _rb - -- | isEmpty _rb = _ra + -- isEmpty _ra = _rb + -- isEmpty _rb = _ra | Bounded False False <- compareBounds lb ua = error "mappend: disjoint Ranges" | Bounded False False <- compareBounds la ub = error "mappend: disjoint Ranges" | otherwise = Range (min la lb) (max ua ub) From 0e0144e9f4e6fdcf44968d19193a3a189292ad42 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 17 May 2015 22:26:50 -0400 Subject: [PATCH 148/306] Add pgSimpleQueries_ --- Database/PostgreSQL/Typed/Protocol.hs | 17 +++++++++++++++++ postgresql-typed.cabal | 2 +- 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 1675cab..7623b7c 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -18,6 +18,7 @@ module Database.PostgreSQL.Typed.Protocol ( , pgReconnect , pgDescribe , pgSimpleQuery + , pgSimpleQueries_ , pgPreparedQuery , pgPreparedLazyQuery , pgCloseStatement @@ -549,6 +550,22 @@ pgSimpleQuery h sql = do row _ _ m = fail $ "pgSimpleQuery: unexpected row: " ++ show m got c r = return (rowsAffected c, r) +-- |A simple query which may contain multiple queries (separated by semi-colons) whose results are all ignored. +pgSimpleQueries_ :: PGConnection -> String -- ^ SQL string + -> IO () +pgSimpleQueries_ h sql = do + pgSync h + pgSend h $ SimpleQuery sql + pgFlush h + go where + go = pgReceive h >>= res + res (RowDescription _) = go + res (CommandComplete _) = go + res EmptyQueryResponse = go + res (DataRow _) = go + res (ReadyForQuery _) = return () + res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m + pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do pgSync c diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 257c73c..8134f07 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.3.3 +Version: 0.3.4 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From 7a0ee2ea1d4baac70a46d5fe8ec5ad8018d0172d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 18 May 2015 22:28:37 -0400 Subject: [PATCH 149/306] Convert many String interfaces to ByteString Bump version to 0.4.0 to reflect significant incompatibility --- Database/PostgreSQL/Typed/Dynamic.hs | 32 +++--- Database/PostgreSQL/Typed/Enum.hs | 7 +- Database/PostgreSQL/Typed/Internal.hs | 46 +++++---- Database/PostgreSQL/Typed/Protocol.hs | 128 +++++++++++------------- Database/PostgreSQL/Typed/Query.hs | 69 ++++++------- Database/PostgreSQL/Typed/TH.hs | 20 ++-- Database/PostgreSQL/Typed/TemplatePG.hs | 23 +++-- Database/PostgreSQL/Typed/Types.hs | 63 ++++++------ postgresql-typed.cabal | 4 +- test/Connect.hs | 1 + test/Main.hs | 7 +- 11 files changed, 208 insertions(+), 192 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index f9718ba..f4850ca 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, TemplateHaskell #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, GADTs, TemplateHaskell #-} -- | -- Module: Database.PostgreSQL.Typed.Dynamic -- Copyright: 2015 Dylan Simon @@ -13,10 +13,14 @@ module Database.PostgreSQL.Typed.Dynamic ) where import Control.Applicative ((<$>)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Monoid ((<>)) import Data.Int #ifdef USE_SCIENTIFIC import Data.Scientific (Scientific) #endif +import Data.String (fromString) #ifdef USE_TEXT import qualified Data.Text as T #endif @@ -37,8 +41,8 @@ class PGType t => PGRep t a | a -> t where pgEncodeRep :: a -> PGValue default pgEncodeRep :: PGParameter t a => a -> PGValue pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x - pgLiteralRep :: a -> String - default pgLiteralRep :: PGParameter t a => a -> String + pgLiteralRep :: a -> BS.ByteString + default pgLiteralRep :: PGParameter t a => a -> BS.ByteString pgLiteralRep x = pgLiteral (pgTypeOf x) x pgDecodeRep :: PGValue -> a #ifdef USE_BINARY_XXX @@ -51,13 +55,13 @@ class PGType t => PGRep t a | a -> t where pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue" -- |Produce a safely type-cast literal value for interpolation in a SQL statement. -pgSafeLiteral :: PGRep t a => a -> String -pgSafeLiteral x = pgLiteralRep x ++ "::" ++ pgTypeName (pgTypeOf x) +pgSafeLiteral :: PGRep t a => a -> BS.ByteString +pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) instance PGRep t a => PGRep t (Maybe a) where pgEncodeRep Nothing = PGNullValue pgEncodeRep (Just x) = pgEncodeRep x - pgLiteralRep Nothing = "NULL" + pgLiteralRep Nothing = BSC.pack "NULL" pgLiteralRep (Just x) = pgLiteralRep x pgDecodeRep PGNullValue = Nothing pgDecodeRep v = Just (pgDecodeRep v) @@ -71,6 +75,7 @@ instance PGRep "real" Float instance PGRep "double precision" Double instance PGRep "\"char\"" Char instance PGRep "text" String +instance PGRep "text" BS.ByteString #ifdef USE_TEXT instance PGRep "text" T.Text #endif @@ -91,11 +96,12 @@ instance PGRep "uuid" UUID.UUID -- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries. -- Unlike most other TH functions, this does not require any database connection. pgSubstituteLiterals :: String -> TH.ExpQ -pgSubstituteLiterals ('$':'$':'{':s) = (++$) "${" <$> pgSubstituteLiterals s -pgSubstituteLiterals ('$':'{':s) - | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = do +pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BS.concat) . TH.ListE <$> ssl (sqlSplitExprs sql) where + ssl :: SQLSplit String True -> TH.Q [TH.Exp] + ssl (SQLLiteral s l) = (TH.VarE 'fromString `TH.AppE` stringE s :) <$> ssp l + ssl SQLSplitEnd = return [] + ssp :: SQLSplit String False -> TH.Q [TH.Exp] + ssp (SQLPlaceholder e l) = do v <- either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e - ($++$) (TH.VarE 'pgSafeLiteral `TH.AppE` v) <$> pgSubstituteLiterals r - | otherwise = fail $ "Error parsing SQL: could not find end of expression: ${" ++ s -pgSubstituteLiterals (c:r) = (++$) [c] <$> pgSubstituteLiterals r -pgSubstituteLiterals "" = return $ stringE "" + (TH.VarE 'pgSafeLiteral `TH.AppE` v :) <$> ssl l + ssp SQLSplitEnd = return [] diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 30f6b44..199e3a2 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -14,7 +14,8 @@ module Database.PostgreSQL.Typed.Enum import Control.Monad (when) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.UTF8 as U +import qualified Data.ByteString.Lazy as BSL +import Data.String (fromString) import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH @@ -49,10 +50,10 @@ makePGEnum :: String -- ^ PostgreSQL enum type name -> 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" + pgSimpleQuery c $ BSL.fromChunks [BSC.pack "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 (fromString name), BSC.pack " ORDER BY enumsortorder"] when (null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" let - valn = map (\[PGTextValue v] -> let u = U.toString v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals + valn = map (\[PGTextValue v] -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals dv <- TH.newName "x" return [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Typeable] diff --git a/Database/PostgreSQL/Typed/Internal.hs b/Database/PostgreSQL/Typed/Internal.hs index ef5dca7..9ed17ae 100644 --- a/Database/PostgreSQL/Typed/Internal.hs +++ b/Database/PostgreSQL/Typed/Internal.hs @@ -1,33 +1,45 @@ -{-# LANGUAGE PatternSynonyms, TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms, PatternGuards, TemplateHaskell, GADTs, KindSignatures, DataKinds #-} module Database.PostgreSQL.Typed.Internal ( stringE , pattern StringE - , ($++$) - , (++$) + , SQLSplit(..) + , sqlSplitExprs + , sqlSplitParams ) where +import Data.Char (isDigit) import Data.String (IsString(..)) import qualified Language.Haskell.TH as TH +import Numeric (readDec) stringE :: String -> TH.Exp stringE = TH.LitE . TH.StringL pattern StringE s = TH.LitE (TH.StringL s) -pattern InfixE l o r = TH.InfixE (Just l) (TH.VarE o) (Just r) instance IsString TH.Exp where fromString = stringE -($++$) :: TH.Exp -> TH.Exp -> TH.Exp -infixr 5 $++$ -StringE s $++$ r = s ++$ r -l $++$ StringE "" = l -InfixE ll pp (StringE lr) $++$ StringE r | pp == '(++) = ll $++$ StringE (lr ++ r) -l $++$ r = InfixE l '(++) r - -(++$) :: String -> TH.Exp -> TH.Exp -infixr 5 ++$ -"" ++$ r = r -l ++$ StringE r = StringE (l ++ r) -l ++$ InfixE (StringE rl) pp rr | pp == '(++) = (l ++ rl) ++$ rr -l ++$ r = InfixE (StringE l) '(++) r +data SQLSplit a (literal :: Bool) where + SQLLiteral :: String -> SQLSplit a False -> SQLSplit a True + SQLPlaceholder :: a -> SQLSplit a True -> SQLSplit a False + SQLSplitEnd :: SQLSplit a any + +sqlCons :: Char -> SQLSplit a True -> SQLSplit a True +sqlCons c (SQLLiteral s l) = SQLLiteral (c : s) l +sqlCons c SQLSplitEnd = SQLLiteral [c] SQLSplitEnd + +sqlSplitExprs :: String -> SQLSplit String True +sqlSplitExprs ('$':'$':'{':s) = sqlCons '$' $ sqlCons '{' $ sqlSplitExprs s +sqlSplitExprs ('$':'{':s) + | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = SQLLiteral "" $ SQLPlaceholder e $ sqlSplitExprs r + | otherwise = error $ "Error parsing SQL: could not find end of expression: ${" ++ s +sqlSplitExprs (c:s) = sqlCons c $ sqlSplitExprs s +sqlSplitExprs [] = SQLSplitEnd + +sqlSplitParams :: String -> SQLSplit Int True +sqlSplitParams ('$':'$':d:s) | isDigit d = sqlCons '$' $ sqlCons d $ sqlSplitParams s +sqlSplitParams ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = SQLLiteral "" $ SQLPlaceholder n $ sqlSplitParams r +sqlSplitParams (c:s) = sqlCons c $ sqlSplitParams s +sqlSplitParams [] = SQLSplitEnd + diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 7623b7c..4aa27a7 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -38,8 +38,6 @@ 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 Data.Int (Int32, Int16) @@ -71,8 +69,8 @@ data PGState 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 + , pgDBName :: BS.ByteString -- ^ The name of the database + , pgDBUser, pgDBPass :: BS.ByteString , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) } @@ -88,15 +86,15 @@ data PGConnection = PGConnection , connDatabase :: !PGDatabase , connPid :: !Word32 -- unused , connKey :: !Word32 -- unused - , connParameters :: Map.Map String String + , connParameters :: Map.Map BS.ByteString BS.ByteString , connTypeEnv :: PGTypeEnv - , connPreparedStatements :: IORef (Integer, Map.Map (String, [OID]) Integer) + , connPreparedStatements :: IORef (Integer, Map.Map (BS.ByteString, [OID]) Integer) , connState :: IORef PGState , connInput :: IORef (G.Decoder PGBackendMessage) } data ColDescription = ColDescription - { colName :: String + { colName :: BS.ByteString , colTable :: !OID , colNumber :: !Int16 , colType :: !OID @@ -104,26 +102,26 @@ data ColDescription = ColDescription , colBinary :: !Bool } deriving (Show) -type MessageFields = Map.Map Char String +type MessageFields = Map.Map Char BS.ByteString -- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. -- See . data PGFrontendMessage - = StartupMessage [(String, String)] -- only sent first + = StartupMessage [(BS.ByteString, BS.ByteString)] -- only sent first | CancelRequest !Word32 !Word32 -- sent first on separate connection - | Bind { statementName :: String, bindParameters :: PGValues, binaryColumns :: [Bool] } - | Close { statementName :: String } + | Bind { statementName :: BS.ByteString, bindParameters :: PGValues, binaryColumns :: [Bool] } + | Close { statementName :: BS.ByteString } -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). - | Describe { statementName :: String } + | Describe { statementName :: BS.ByteString } | Execute !Word32 | Flush -- |Parse SQL Destination (prepared statement) - | Parse { statementName :: String, queryString :: String, parseTypes :: [OID] } + | Parse { statementName :: BS.ByteString, queryString :: BSL.ByteString, parseTypes :: [OID] } | PasswordMessage BS.ByteString -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2, -- etc.) aren't allowed. - | SimpleQuery { queryString :: String } + | SimpleQuery { queryString :: BSL.ByteString } | Sync | Terminate deriving (Show) @@ -138,14 +136,8 @@ data PGBackendMessage | 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'. + -- |Each DataRow (result of a query) is a list of 'PGValue', which are assumed to be text unless known to be otherwise. | DataRow PGValues | EmptyQueryResponse -- |An ErrorResponse contains the severity, "SQLSTATE", and @@ -159,7 +151,7 @@ data PGBackendMessage -- PostgreSQL does not give us nullability information for the -- parameter. | ParameterDescription [OID] - | ParameterStatus String String + | ParameterStatus BS.ByteString BS.ByteString | ParseComplete | PortalSuspended | ReadyForQuery PGState @@ -182,15 +174,15 @@ 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 + where f c = BSC.unpack $ Map.findWithDefault BS.empty c m -makeMessage :: String -> String -> MessageFields +makeMessage :: BS.ByteString -> BS.ByteString -> MessageFields makeMessage m d = Map.fromAscList [('D', d), ('M', m)] -- |Message SQLState code. -- See . -pgErrorCode :: PGError -> String -pgErrorCode (PGError e) = Map.findWithDefault "" 'C' e +pgErrorCode :: PGError -> BS.ByteString +pgErrorCode (PGError e) = Map.findWithDefault BS.empty 'C' e defaultLogMessage :: MessageFields -> IO () defaultLogMessage = hPutStrLn stderr . displayMessage @@ -198,7 +190,7 @@ defaultLogMessage = hPutStrLn stderr . displayMessage -- |A database connection with sane defaults: -- localhost:5432:postgres defaultPGDatabase :: PGDatabase -defaultPGDatabase = PGDatabase "localhost" (PortNumber 5432) "postgres" "postgres" "" False defaultLogMessage +defaultPGDatabase = PGDatabase "localhost" (PortNumber 5432) (BSC.pack "postgres") (BSC.pack "postgres") BS.empty False defaultLogMessage connDebug :: PGConnection -> Bool connDebug = pgDBDebug . connDatabase @@ -218,19 +210,20 @@ md5 = Hash.digestToHexByteString . (Hash.hash :: BS.ByteString -> Hash.Digest Ha 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 +byteStringNul :: BS.ByteString -> B.Builder +byteStringNul s = B.byteString s <> nul --- |Given a message, determinal the (optional) type ID and the body +lazyByteStringNul :: BSL.ByteString -> B.Builder +lazyByteStringNul s = B.lazyByteString s <> nul + +-- |Given a message, determin 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) + <> Fold.foldMap (\(k, v) -> byteStringNul k <> byteStringNul v) kv <> nul) messageBody (CancelRequest pid key) = (Nothing, B.word32BE 80877102 <> B.word32BE pid <> B.word32BE key) messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = (Just 'B', - nul <> pgString n + nul <> byteStringNul n <> (if any fmt p then B.word16BE (fromIntegral $ length p) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum . fmt) p else B.word16BE 0) @@ -245,19 +238,19 @@ messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = 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) + B.char7 'S' <> byteStringNul n) messageBody Describe{ statementName = n } = (Just 'D', - B.char7 'S' <> pgString n) + B.char7 'S' <> byteStringNul 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 + byteStringNul n <> lazyByteStringNul s <> B.word16BE (fromIntegral $ length t) <> Fold.foldMap B.word32BE t) messageBody (PasswordMessage s) = (Just 'p', B.byteString s <> nul) messageBody SimpleQuery{ queryString = s } = (Just 'Q', - pgString s) + lazyByteStringNul s) messageBody Sync = (Just 'S', mempty) messageBody Terminate = (Just 'X', mempty) @@ -274,16 +267,13 @@ 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 + g f = liftM2 (Map.insert f) getByteStringNul getMessageFields -- |Parse an incoming message. getMessageBody :: Char -> G.Get PGBackendMessage @@ -299,7 +289,7 @@ getMessageBody 'T' = do numFields <- G.getWord16be RowDescription <$> replicateM (fromIntegral numFields) getField where getField = do - name <- getPGString + name <- getByteStringNul oid <- G.getWord32be -- table OID col <- G.getWord16be -- column number typ' <- G.getWord32be -- type @@ -323,7 +313,7 @@ getMessageBody '1' = return ParseComplete getMessageBody '2' = return BindComplete getMessageBody '3' = return CloseComplete getMessageBody 'C' = CommandComplete <$> getByteStringNul -getMessageBody 'S' = liftM2 ParameterStatus getPGString getPGString +getMessageBody 'S' = liftM2 ParameterStatus getByteStringNul getByteStringNul getMessageBody 'D' = do numFields <- G.getWord16be DataRow <$> replicateM (fromIntegral numFields) (getField =<< G.getWord32be) where @@ -402,13 +392,13 @@ pgConnect db = do , 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") + [ (BSC.pack "user", pgDBUser db) + , (BSC.pack "database", pgDBName db) + , (BSC.pack "client_encoding", BSC.pack "UTF8") + , (BSC.pack "standard_conforming_strings", BSC.pack "on") + , (BSC.pack "bytea_output", BSC.pack "hex") + , (BSC.pack "DateStyle", BSC.pack "ISO, YMD") + , (BSC.pack "IntervalStyle", BSC.pack "iso_8601") ] pgFlush c conn c @@ -416,19 +406,19 @@ pgConnect db = do conn c = pgReceive c >>= msg c msg c (ReadyForQuery _) = return c { connTypeEnv = PGTypeEnv - { pgIntegerDatetimes = fmap ("on" ==) $ Map.lookup "integer_datetimes" (connParameters c) + { pgIntegerDatetimes = fmap (BSC.pack "on" ==) $ Map.lookup (BSC.pack "integer_datetimes") (connParameters c) } } 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 + pgSend c $ PasswordMessage $ 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) + pgSend c $ PasswordMessage $ BSC.pack "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) pgFlush c conn c #endif @@ -474,21 +464,21 @@ pgSync c@PGConnection{ connState = sr } = do wait s (Just (ReadyForQuery _)) -> return () (Just m) -> do - connLogMessage c $ makeMessage ("Unexpected server message: " ++ show m) "Each statement should only contain a single query" + connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) $ BSC.pack "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 +pgDescribe :: PGConnection -> BSL.ByteString -- ^ 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. + -> IO ([OID], [(BS.ByteString, OID, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. pgDescribe h sql types nulls = do pgSync h - pgSend h $ Parse{ queryString = sql, statementName = "", parseTypes = types } - pgSend h $ Describe "" + pgSend h $ Parse{ queryString = sql, statementName = BS.empty, parseTypes = types } + pgSend h $ Describe BS.empty pgSend h Flush pgSend h Sync pgFlush h @@ -510,7 +500,7 @@ pgDescribe h sql types nulls = do | nulls && oid /= 0 = do -- In cases where the resulting field is tracable to the column of a -- table, we can check there. - (_, r) <- pgPreparedQuery h "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] + (_, r) <- pgPreparedQuery h (BSC.pack "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2") [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] case r of [[s]] -> return $ not $ pgDecodeRep s [] -> return True @@ -533,7 +523,7 @@ fixBinary _ l = l -- 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 +pgSimpleQuery :: PGConnection -> BSL.ByteString -- ^ SQL string -> IO (Int, [PGValues]) -- ^ The number of rows affected and a list of result rows pgSimpleQuery h sql = do pgSync h @@ -551,7 +541,7 @@ pgSimpleQuery h sql = do got c r = return (rowsAffected c, r) -- |A simple query which may contain multiple queries (separated by semi-colons) whose results are all ignored. -pgSimpleQueries_ :: PGConnection -> String -- ^ SQL string +pgSimpleQueries_ :: PGConnection -> BSL.ByteString -- ^ SQL string -> IO () pgSimpleQueries_ h sql = do pgSync h @@ -566,14 +556,14 @@ pgSimpleQueries_ h sql = do res (ReadyForQuery _) = return () res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m -pgPreparedBind :: PGConnection -> String -> [OID] -> PGValues -> [Bool] -> IO (IO ()) +pgPreparedBind :: PGConnection -> BS.ByteString -> [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 + let sn = BSC.pack $ show n unless p $ - pgSend c $ Parse{ queryString = sql, statementName = sn, parseTypes = types } + pgSend c $ Parse{ queryString = BSL.fromStrict sql, statementName = sn, parseTypes = types } pgSend c $ Bind{ statementName = sn, bindParameters = bind, binaryColumns = bc } let go = pgReceive c >>= start @@ -588,7 +578,7 @@ pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc -- |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 +pgPreparedQuery :: PGConnection -> BS.ByteString -- ^ SQL statement with placeholders -> [OID] -- ^ Optional type specifications (only used for first call) -> PGValues -- ^ Paremeters to bind to placeholders -> [Bool] -- ^ Requested binary format for result columns @@ -610,7 +600,7 @@ pgPreparedQuery c sql types bind bc = do -- |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) +pgPreparedLazyQuery :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once) -> IO [PGValues] pgPreparedLazyQuery c sql types bind bc count = do start <- pgPreparedBind c sql types bind bc @@ -631,13 +621,13 @@ pgPreparedLazyQuery c sql types bind bc count = do row _ m = fail $ "pgPreparedLazyQuery: unexpected row: " ++ show m -- |Close a previously prepared query (if necessary). -pgCloseStatement :: PGConnection -> String -> [OID] -> IO () +pgCloseStatement :: PGConnection -> BS.ByteString -> [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 } + pgSend c $ Close{ statementName = BSC.pack $ show n } pgFlush c CloseComplete <- pgReceive c return () diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index f8bacfd..73dcb4c 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-} +{-# LANGUAGE CPP, PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, GADTs, DataKinds, TemplateHaskell #-} module Database.PostgreSQL.Typed.Query ( PGQuery(..) , PGSimpleQuery @@ -18,9 +18,12 @@ module Database.PostgreSQL.Typed.Query import Control.Applicative ((<$>)) import Control.Arrow ((***), first, second) import Control.Exception (try) -import Control.Monad (when, mapAndUnzipM) +import Control.Monad (void, when, mapAndUnzipM) import Data.Array (listArray, (!), inRange) -import Data.Char (isDigit, isSpace) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Char (isSpace) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing) @@ -29,7 +32,6 @@ 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.Internal import Database.PostgreSQL.Typed.Types @@ -43,7 +45,7 @@ class PGQuery q a | q -> a where -- |Change the raw SQL query stored within this query. -- This is unsafe because the query has already been type-checked, so any change must not change the number or type of results or placeholders (so adding additional static WHERE or ORDER BY clauses is generally safe). -- This is useful in cases where you need to construct some part of the query dynamically, but still want to infer the result types. - unsafeModifyQuery :: q -> (String -> String) -> q + unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q class PGQuery q PGValues => PGRawQuery q -- |Execute a query that does not return results. @@ -55,17 +57,17 @@ pgExecute c q = fst <$> pgRunQuery c q pgQuery :: PGQuery q a => PGConnection -> q -> IO [a] pgQuery c q = snd <$> pgRunQuery c q -instance PGQuery String PGValues where - pgRunQuery c sql = pgSimpleQuery c sql +instance PGQuery BS.ByteString PGValues where + pgRunQuery c sql = pgSimpleQuery c (BSL.fromStrict sql) unsafeModifyQuery q f = f q -newtype SimpleQuery = SimpleQuery String +newtype SimpleQuery = SimpleQuery BS.ByteString instance PGQuery SimpleQuery PGValues where - pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c sql + pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c (BSL.fromStrict sql) unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql instance PGRawQuery SimpleQuery -data PreparedQuery = PreparedQuery String [OID] PGValues [Bool] +data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool] instance PGQuery PreparedQuery PGValues where pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc @@ -89,16 +91,16 @@ type PGSimpleQuery = QueryParser SimpleQuery type PGPreparedQuery = QueryParser PreparedQuery -- |Make a simple query directly from a query string, with no type inference -rawPGSimpleQuery :: String -> PGSimpleQuery PGValues +rawPGSimpleQuery :: BS.ByteString -> PGSimpleQuery PGValues rawPGSimpleQuery = rawParser . SimpleQuery instance IsString (PGSimpleQuery PGValues) where - fromString = rawPGSimpleQuery + fromString = rawPGSimpleQuery . fromString instance IsString (PGSimpleQuery ()) where - fromString = fmap (const ()) . rawPGSimpleQuery + fromString = void . rawPGSimpleQuery . fromString -- |Make a prepared query directly from a query string and bind parameters, with no type inference -rawPGPreparedQuery :: String -> PGValues -> PGPreparedQuery PGValues +rawPGPreparedQuery :: BS.ByteString -> PGValues -> PGPreparedQuery PGValues rawPGPreparedQuery sql bind = rawParser $ PreparedQuery sql [] bind [] -- |Run a prepared query in lazy mode, where only chunk size rows are requested at a time. @@ -115,28 +117,27 @@ pgLazyQuery c (QueryParser q p) count = -- 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. +sqlPlaceholders = ssl 1 . sqlSplitExprs where + ssl :: Int -> SQLSplit String True -> (String, [String]) + ssl n (SQLLiteral s l) = first (s ++) $ ssp n l + ssl _ SQLSplitEnd = ("", []) + ssp :: Int -> SQLSplit String False -> (String, [String]) + ssp n (SQLPlaceholder e l) = (('$':show n) ++) *** (e :) $ ssl (succ n) l + ssp _ SQLSplitEnd = ("", []) + +-- |Given a SQL statement with placeholders of the form @$N@ and a list of TH 'ByteString' expressions, return a new 'ByteString' expression that substitutes the expressions for the placeholders. -- 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 = ss sql where +sqlSubstitute sql exprl = TH.AppE (TH.VarE 'BS.concat) $ TH.ListE $ ssl $ sqlSplitParams 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 '$$'" - ss ('$':'$':d:r) | isDigit d = ['$',d] ++$ ss r - ss ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = expr n $++$ ss r - ss (c:r) = [c] ++$ ss r - ss "" = stringE "" + ssl (SQLLiteral s l) = TH.VarE 'fromString `TH.AppE` stringE s : ssp l + ssl SQLSplitEnd = [] + ssp (SQLPlaceholder n l) = expr n : ssl l + ssp SQLSplitEnd = [] splitCommas :: String -> [String] splitCommas = spl where @@ -163,18 +164,18 @@ simpleQueryFlags = QueryFlags True Nothing Nothing makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do - (pt, rt) <- TH.runIO $ tpgDescribe sqlp (fromMaybe [] prep) (isNothing nulls) + (pt, rt) <- TH.runIO $ tpgDescribe (fromString sqlp) (fromMaybe [] prep) (isNothing 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 + v <- TH.newName $ 'p':BSC.unpack (tpgValueName t) return ( TH.VarP v , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v )) pt (pats, conv, bins) <- unzip3 <$> mapM (\t -> do - v <- TH.newName $ 'c':tpgValueName t + v <- TH.newName $ 'c':BSC.unpack (tpgValueName t) return ( TH.VarP v , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v @@ -185,7 +186,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do then TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals else TH.ConE 'PreparedQuery - `TH.AppE` stringE sqlp + `TH.AppE` (TH.VarE 'fromString `TH.AppE` stringE sqlp) `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID) pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE @@ -222,7 +223,7 @@ qqTop :: Bool -> String -> TH.DecsQ qqTop True ('!':sql) = qqTop False sql qqTop err sql = do r <- TH.runIO $ try $ withTPGConnection $ \c -> - pgSimpleQuery c sql + pgSimpleQuery c (fromString sql) either ((if err then TH.reportError else TH.reportWarning) . (show :: PGError -> String)) (const $ return ()) r return [] diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index ff82d74..84fa865 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -22,6 +22,10 @@ import Control.Applicative ((<$>), (<$), (<|>)) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, modifyMVar_) import Control.Exception (onException, finally) import Control.Monad (liftM2) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold import qualified Data.IntMap.Lazy as IntMap import Data.List (find) @@ -53,9 +57,9 @@ getTPGDatabase = do return $ defaultPGDatabase { pgDBHost = host , pgDBPort = port - , pgDBName = db - , pgDBUser = user - , pgDBPass = pass + , pgDBName = BSU.fromString db + , pgDBUser = BSU.fromString user + , pgDBPass = BSU.fromString pass , pgDBDebug = debug } @@ -73,7 +77,7 @@ data TPGState = TPGState 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" + tl <- unsafeInterleaveIO $ pgSimpleQuery (tpgConnection tpg) $ BSLC.pack "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 (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) $ snd tl } @@ -129,20 +133,20 @@ getTPGTypeOID TPGState{ tpgTypes = types } t = $ find ((==) t . snd) $ IntMap.toList types data TPGValueInfo = TPGValueInfo - { tpgValueName :: String + { tpgValueName :: BS.ByteString , tpgValueTypeOID :: !OID , tpgValueType :: TPGType , tpgValueNullable :: Bool } -- |A type-aware wrapper to 'pgDescribe' -tpgDescribe :: String -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo]) +tpgDescribe :: BS.ByteString -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo]) tpgDescribe sql types nulls = withTPGState $ \tpg -> do at <- mapM (getTPGTypeOID tpg) types - (pt, rt) <- pgDescribe (tpgConnection tpg) sql at nulls + (pt, rt) <- pgDescribe (tpgConnection tpg) (BSL.fromStrict sql) at nulls return ( map (\o -> TPGValueInfo - { tpgValueName = "" + { tpgValueName = BS.empty , tpgValueTypeOID = o , tpgValueType = tpgType tpg o , tpgValueNullable = True diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index 20671b4..c634ce6 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -24,6 +24,9 @@ module Database.PostgreSQL.Typed.TemplatePG import Control.Exception (onException, catchJust) import Control.Monad (liftM, void, guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe (listToMaybe, isJust) import qualified Language.Haskell.TH as TH import Network (HostName, PortID(..)) @@ -74,28 +77,28 @@ execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleQueryFlags $ query -- 'MonadPeelIO' version. withTransaction :: PG.PGConnection -> IO a -> IO a withTransaction h a = - onException (do void $ PG.pgSimpleQuery h "BEGIN" + onException (do void $ PG.pgSimpleQuery h $ BSLC.pack "BEGIN" c <- a - void $ PG.pgSimpleQuery h "COMMIT" + void $ PG.pgSimpleQuery h $ BSLC.pack "COMMIT" return c) - (void $ PG.pgSimpleQuery h "ROLLBACK") + (void $ PG.pgSimpleQuery h $ BSLC.pack "ROLLBACK") -- |Roll back a transaction. rollback :: PG.PGConnection -> IO () -rollback h = void $ PG.pgSimpleQuery h "ROLLBACK" +rollback h = void $ PG.pgSimpleQuery h $ BSLC.pack "ROLLBACK" -- |Ignore duplicate key errors. This is also limited to the 'IO' Monad. insertIgnore :: IO () -> IO () insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where - uniquenessError e = guard (PG.pgErrorCode e == "23505") + uniquenessError e = guard (PG.pgErrorCode e == BSC.pack "23505") 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 +pgConnect :: HostName -- ^ the host to connect to + -> PortID -- ^ the port to connect on + -> ByteString -- ^ the database to connect to + -> ByteString -- ^ the username to connect as + -> ByteString -- ^ the password to connect with -> IO PG.PGConnection -- ^ a handle to communicate with the PostgreSQL server on pgConnect h n d u p = do debug <- isJust `liftM` lookupEnv "TPG_DEBUG" diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index ce73c78..9ce6c10 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -51,7 +51,7 @@ 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, intercalate) +import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Monoid ((<>), mconcat, mempty) import Data.Ratio ((%), numerator, denominator) @@ -123,8 +123,8 @@ class PGType t => PGParameter t a where 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 + pgLiteral :: PGTypeName t -> a -> BS.ByteString + pgLiteral t = pgQuote . pgEncode t -- |Encode a value to a PostgreSQL representation. -- Defaults to the text representation by pgEncode pgEncodeValue :: PGTypeEnv -> PGTypeName t -> a -> PGValue @@ -145,7 +145,7 @@ class PGType t => PGColumn t a where instance PGParameter t a => PGParameter t (Maybe a) where pgEncode t = maybe (error $ "pgEncode " ++ pgTypeName t ++ ": Nothing") (pgEncode t) - pgLiteral = maybe "NULL" . pgLiteral + pgLiteral = maybe (BSC.pack "NULL") . pgLiteral pgEncodeValue e = maybe PGNullValue . pgEncodeValue e instance PGColumn t a => PGColumn t (Maybe a) where @@ -160,7 +160,7 @@ pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> PGValu pgEncodeParameter = pgEncodeValue -- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query. -pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> String +pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> BS.ByteString pgEscapeParameter _ = pgLiteral -- |Final column decoding function used for a nullable result value. @@ -172,15 +172,12 @@ pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> pgDecodeColumnNotNull = pgDecodeValue -pgQuoteUnsafe :: String -> String -pgQuoteUnsafe s = '\'' : s ++ "'" +pgQuoteUnsafe :: BS.ByteString -> BS.ByteString +pgQuoteUnsafe = (`BSC.snoc` '\'') . BSC.cons '\'' -- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes. -pgQuote :: String -> String -pgQuote = ('\'':) . es where - es "" = "'" - es (c@'\'':r) = c:c:es r - es (c:r) = c:es r +pgQuote :: BS.ByteString -> BS.ByteString +pgQuote = pgQuoteUnsafe . BSC.intercalate (BSC.pack "''") . BSC.split '\'' buildPGValue :: BSB.Builder -> BS.ByteString buildPGValue = BSL.toStrict . BSB.toLazyByteString @@ -229,8 +226,8 @@ instance PGType "boolean" where BIN_COL instance PGParameter "boolean" Bool where pgEncode _ False = BSC.singleton 'f' pgEncode _ True = BSC.singleton 't' - pgLiteral _ False = "false" - pgLiteral _ True = "true" + pgLiteral _ False = BSC.pack "false" + pgLiteral _ True = BSC.pack "true" BIN_ENC(BinE.bool) instance PGColumn "boolean" Bool where pgDecode _ s = case BSC.head s of @@ -243,7 +240,7 @@ type OID = Word32 instance PGType "oid" where BIN_COL instance PGParameter "oid" OID where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.int4 . Right) instance PGColumn "oid" OID where pgDecode _ = read . BSC.unpack @@ -252,7 +249,7 @@ instance PGColumn "oid" OID where instance PGType "smallint" where BIN_COL instance PGParameter "smallint" Int16 where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.int2. Left) instance PGColumn "smallint" Int16 where pgDecode _ = read . BSC.unpack @@ -261,7 +258,7 @@ instance PGColumn "smallint" Int16 where instance PGType "integer" where BIN_COL instance PGParameter "integer" Int32 where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.int4 . Left) instance PGColumn "integer" Int32 where pgDecode _ = read . BSC.unpack @@ -270,7 +267,7 @@ instance PGColumn "integer" Int32 where instance PGType "bigint" where BIN_COL instance PGParameter "bigint" Int64 where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.int8 . Left) instance PGColumn "bigint" Int64 where pgDecode _ = read . BSC.unpack @@ -279,7 +276,7 @@ instance PGColumn "bigint" Int64 where instance PGType "real" where BIN_COL instance PGParameter "real" Float where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.float4) instance PGColumn "real" Float where pgDecode _ = read . BSC.unpack @@ -288,7 +285,7 @@ instance PGColumn "real" Float where instance PGType "double precision" where BIN_COL instance PGParameter "double precision" Double where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.float8) instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack @@ -369,14 +366,14 @@ decodeBytea s instance PGType "bytea" where BIN_COL instance PGParameter "bytea" BSL.ByteString where pgEncode _ = encodeBytea . BSB.lazyByteStringHex - pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t + pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.bytea . Right) instance PGColumn "bytea" BSL.ByteString where pgDecode _ = BSL.pack . decodeBytea BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea) instance PGParameter "bytea" BS.ByteString where pgEncode _ = encodeBytea . BSB.byteStringHex - pgLiteral t = pgQuoteUnsafe . BSC.unpack . pgEncode t + pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.bytea . Left) instance PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea @@ -385,7 +382,7 @@ instance PGColumn "bytea" BS.ByteString where instance PGType "date" where BIN_COL instance PGParameter "date" Time.Day where pgEncode _ = BSC.pack . Time.showGregorian - pgLiteral _ = pgQuoteUnsafe . Time.showGregorian + pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.date) instance PGColumn "date" Time.Day where pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack @@ -409,7 +406,7 @@ instance PGType "time without time zone" where pgBinaryColumn = binColDatetime instance PGParameter "time without time zone" Time.TimeOfDay where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" - pgLiteral _ = pgQuoteUnsafe . Time.formatTime defaultTimeLocale "%T%Q" + pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY pgEncodeValue = binEncDatetime BinE.time #endif @@ -423,7 +420,7 @@ instance PGType "timestamp without time zone" where pgBinaryColumn = binColDatetime 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" + pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY pgEncodeValue = binEncDatetime BinE.timestamp #endif @@ -447,7 +444,7 @@ instance PGType "timestamp with time zone" where pgBinaryColumn = binColDatetime 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" + -- pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY pgEncodeValue = binEncDatetime BinE.timestamptz #endif @@ -461,7 +458,7 @@ instance PGType "interval" where pgBinaryColumn = binColDatetime instance PGParameter "interval" Time.DiffTime where pgEncode _ = BSC.pack . show - pgLiteral _ = pgQuoteUnsafe . show + pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY pgEncodeValue = binEncDatetime BinE.interval #endif @@ -510,8 +507,8 @@ instance PGParameter "numeric" Rational where | 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)" + | denominator r == 0 = BSC.pack "'NaN'" -- this can't happen + | otherwise = BSC.pack $ '(' : show (numerator r) ++ '/' : show (denominator r) ++ "::numeric)" BIN_ENC(BinE.numeric . realToFrac) -- |High-precision representation of Rational as numeric. -- Unfortunately, numeric has an NaN, while Rational does not. @@ -535,7 +532,7 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where #ifdef USE_SCIENTIFIC instance PGParameter "numeric" Scientific where pgEncode _ = BSC.pack . show - pgLiteral _ = show + pgLiteral = pgEncode BIN_ENC(BinE.numeric) instance PGColumn "numeric" Scientific where pgDecode _ = read . BSC.unpack @@ -546,7 +543,7 @@ instance PGColumn "numeric" Scientific where instance PGType "uuid" where BIN_COL instance PGParameter "uuid" UUID.UUID where pgEncode _ = UUID.toASCIIBytes - pgLiteral _ = pgQuoteUnsafe . UUID.toString + pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.uuid) instance PGColumn "uuid" UUID.UUID where pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u @@ -558,9 +555,9 @@ newtype PGRecord = PGRecord [Maybe PGTextValue] class PGType t => PGRecordType t instance PGRecordType t => PGParameter t PGRecord where pgEncode _ (PGRecord l) = - buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' where + buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' pgLiteral _ (PGRecord l) = - "ROW(" ++ intercalate "," (map (maybe "NULL" (pgQuote . BSU.toString)) l) ++ ")" where + BSC.pack "ROW(" <> BS.intercalate (BSC.singleton ',') (map (maybe (BSC.pack "NULL") pgQuote) l) `BSC.snoc` ')' instance PGRecordType t => PGColumn t PGRecord where pgDecode _ a = either (error . ("pgDecode record: " ++) . show) PGRecord $ P.parse pa (BSC.unpack a) a where pa = do diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 8134f07..2546f67 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.3.4 +Version: 0.4.0 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING @@ -97,7 +97,7 @@ Library CPP-options: -DUSE_AESON test-suite test - build-depends: base, network, time, postgresql-typed + build-depends: base, network, time, bytestring, postgresql-typed type: exitcode-stdio-1.0 main-is: Main.hs buildable: True diff --git a/test/Connect.hs b/test/Connect.hs index aeb0ff6..2c824b2 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Connect where import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase) diff --git a/test/Main.hs b/test/Main.hs index aa79e9c..f940a18 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where +import Data.ByteString (ByteString) import Data.Int (Int32) import qualified Data.Time as Time import System.Exit (exitSuccess, exitFailure) @@ -44,8 +45,8 @@ main = do t = Time.zonedTimeToLocalTime z d = Time.localDay t p = -34881559 :: Time.DiffTime - s = "\"hel\\o'" - l = [Just "a\\\"b,c", Nothing, Just "null", Just "nullish"] + s = "\"hel\\o'" :: String + l = [Just "a\\\"b,c", Nothing, Just "null", Just "nullish" :: Maybe ByteString] 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 From e98bad1445c3e9969bcc13b5b63c087035ea58e1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 18 May 2015 22:42:52 -0400 Subject: [PATCH 150/306] Add pgLiteralString for more backwards compatibility --- Database/PostgreSQL/Typed/Dynamic.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index f4850ca..45b612a 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -8,7 +8,9 @@ module Database.PostgreSQL.Typed.Dynamic ( PGRep(..) + , pgLiteralString , pgSafeLiteral + , pgSafeLiteralString , pgSubstituteLiterals ) where @@ -54,10 +56,16 @@ class PGType t => PGRep t a | a -> t where pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName t) v pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue" +pgLiteralString :: PGRep t a => a -> String +pgLiteralString = BSC.unpack . pgLiteralRep + -- |Produce a safely type-cast literal value for interpolation in a SQL statement. pgSafeLiteral :: PGRep t a => a -> BS.ByteString pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) +pgSafeLiteralString :: PGRep t a => a -> String +pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeName (pgTypeOf x) + instance PGRep t a => PGRep t (Maybe a) where pgEncodeRep Nothing = PGNullValue pgEncodeRep (Just x) = pgEncodeRep x From 0ca7571120ce0ce968ea8c55f2d1d078c677ca2c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 21 May 2015 18:23:34 -0400 Subject: [PATCH 151/306] Add my (c) to COPYING --- COPYING | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/COPYING b/COPYING index 8437b9f..a8ddaa4 100644 --- a/COPYING +++ b/COPYING @@ -1,4 +1,5 @@ -Copyright (c) 2010, 2011, Chris Forno +Copyright (c) 2014, 2015, Dylan Simon +Portions Copyright (c) 2010, 2011, Chris Forno All rights reserved. Redistribution and use in source and binary forms, with or without From 41bb56c1e706e0641bd5b624c540474159048194 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 29 May 2015 19:47:11 -0400 Subject: [PATCH 152/306] Properly handle empty arrays: elements may not be blank --- Database/PostgreSQL/Typed/Array.hs | 2 +- Database/PostgreSQL/Typed/Range.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 1463cde..2958e06 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -46,7 +46,7 @@ instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where _ <- P.eof return l el = P.between P.spaces P.spaces $ fmap (pgDecode (pgArrayElementType ta) . BSC.pack) <$> - parsePGDQuote (pgArrayDelim ta : "{}") (("null" ==) . map toLower) + parsePGDQuote False (pgArrayDelim ta : "{}") (("null" ==) . map toLower) -- Just a dump of pg_type: instance PGType "boolean" => PGType "boolean[]" diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 6fffa44..ec76a00 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -231,7 +231,7 @@ instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where pgDecode tr a = either (error . ("pgDecode range: " ++) . show) id $ P.parse per (BSC.unpack a) a where per = Empty <$ pe P.<|> pr pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy" - pb = fmap (pgDecode (pgRangeElementType tr) . BSC.pack) <$> parsePGDQuote "(),[]" null + pb = fmap (pgDecode (pgRangeElementType tr) . BSC.pack) <$> parsePGDQuote True "(),[]" null pc c o = True <$ P.char c P.<|> False <$ P.char o mb = maybe Unbounded . Bounded pr = do diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 9ce6c10..bd97929 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -194,11 +194,11 @@ pgDQuote unsafe s bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) -- |Parse double-quoted values ala 'pgDQuote'. -parsePGDQuote :: P.Stream s m Char => String -> (String -> Bool) -> P.ParsecT s u m (Maybe String) -parsePGDQuote unsafe isnul = (Just <$> q P.<|> mnul <$> uq) where +parsePGDQuote :: P.Stream s m Char => Bool -> String -> (String -> Bool) -> P.ParsecT s u m (Maybe String) +parsePGDQuote blank unsafe isnul = (Just <$> q P.<|> mnul <$> uq) where q = P.between (P.char '"') (P.char '"') $ P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" - uq = P.many (P.noneOf ('"':'\\':unsafe)) + uq = (if blank then P.many else P.many1) (P.noneOf ('"':'\\':unsafe)) mnul s | isnul s = Nothing | otherwise = Just s @@ -565,7 +565,7 @@ instance PGRecordType t => PGColumn t PGRecord where P.sepBy el (P.char ',') _ <- P.eof return l - el = fmap BSC.pack <$> parsePGDQuote "()," null + el = fmap BSC.pack <$> parsePGDQuote True "()," null instance PGType "record" -- |The generic anonymous record type, as created by @ROW@. From 52c5b0594d99d9a70da6a1a3f55ee6af627219e2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 30 May 2015 00:42:51 -0400 Subject: [PATCH 153/306] Switch from parsec to attoparsec --- Database/PostgreSQL/Typed/Array.hs | 18 +++---- Database/PostgreSQL/Typed/Range.hs | 14 +++--- Database/PostgreSQL/Typed/Types.hs | 76 ++++++++++++++---------------- postgresql-typed.cabal | 8 ++-- 4 files changed, 53 insertions(+), 63 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 2958e06..9816477 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Array @@ -10,13 +10,13 @@ module Database.PostgreSQL.Typed.Array where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (*>), (<*)) +import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC import Data.Char (toLower) import Data.List (intersperse) import Data.Monoid ((<>), mconcat) -import qualified Text.Parsec as P import Database.PostgreSQL.Typed.Types @@ -39,14 +39,10 @@ instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where el Nothing = BSB.string7 "null" el (Just e) = pgDQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where - pgDecode ta a = either (error . ("pgDecode array: " ++) . show) id $ P.parse pa (BSC.unpack a) a where - pa = do - l <- P.between (P.char '{') (P.char '}') $ - P.sepBy el (P.char (pgArrayDelim ta)) - _ <- P.eof - return l - el = P.between P.spaces P.spaces $ fmap (pgDecode (pgArrayElementType ta) . BSC.pack) <$> - parsePGDQuote False (pgArrayDelim ta : "{}") (("null" ==) . map toLower) + pgDecode ta a = either (error . ("pgDecode array (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly pa a where + pa = P.char '{' *> P.sepBy (P.skipSpace *> el <* P.skipSpace) (P.char (pgArrayDelim ta)) <* P.char '}' <* P.endOfInput + el = fmap (pgDecode (pgArrayElementType ta)) <$> + parsePGDQuote False (pgArrayDelim ta : "{}") (("null" ==) . BSC.map toLower) -- Just a dump of pg_type: instance PGType "boolean" => PGType "boolean[]" diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index ec76a00..c33c51c 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range @@ -12,10 +12,10 @@ module Database.PostgreSQL.Typed.Range where import Control.Applicative ((<$>), (<$)) import Control.Monad (guard) +import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC import Data.Monoid (Monoid(..), (<>)) -import qualified Text.Parsec as P import Database.PostgreSQL.Typed.Types @@ -228,11 +228,11 @@ instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range a) where pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b pc c o b = BSB.char7 $ if boundClosed b then c else o instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where - pgDecode tr a = either (error . ("pgDecode range: " ++) . show) id $ P.parse per (BSC.unpack a) a where - per = Empty <$ pe P.<|> pr - pe = P.oneOf "Ee" >> P.oneOf "Mm" >> P.oneOf "Pp" >> P.oneOf "Tt" >> P.oneOf "Yy" - pb = fmap (pgDecode (pgRangeElementType tr) . BSC.pack) <$> parsePGDQuote True "(),[]" null - pc c o = True <$ P.char c P.<|> False <$ P.char o + pgDecode tr a = either (error . ("pgDecode range (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly per a where + per = (Empty <$ pe) <> pr + pe = P.stringCI "empty" + pb = fmap (pgDecode (pgRangeElementType tr)) <$> parsePGDQuote True "(),[]" BSC.null + pc c o = (True <$ P.char c) <> (False <$ P.char o) mb = maybe Unbounded . Bounded pr = do lc <- pc '[' '(' diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index bd97929..a0ed2ae 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -34,12 +34,12 @@ module Database.PostgreSQL.Typed.Types , buildPGValue ) where -import Control.Applicative ((<$>), (<$)) -import Control.Monad (mzero) +import Control.Applicative ((<$>), (<$), (<*), (*>)) #ifdef USE_AESON import qualified Data.Aeson as JSON -import qualified Data.Attoparsec.ByteString as JSONP #endif +import qualified Data.Attoparsec.ByteString as P (anyWord8) +import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Bits (shiftL, (.|.)) import Data.ByteString.Internal (w2c) import qualified Data.ByteString as BS @@ -65,6 +65,11 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE #endif import qualified Data.Time as Time +#if MIN_VERSION_time(1,5,0) +import Data.Time (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif #ifdef USE_UUID import qualified Data.UUID as UUID #endif @@ -76,9 +81,6 @@ import Numeric (readFloat) 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(..)) type PGTextValue = BS.ByteString type PGBinaryValue = BS.ByteString @@ -184,7 +186,7 @@ buildPGValue = 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. -pgDQuote :: String -> BS.ByteString -> BSB.Builder +pgDQuote :: [Char] -> BS.ByteString -> BSB.Builder pgDQuote 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 @@ -194,11 +196,18 @@ pgDQuote unsafe s bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) -- |Parse double-quoted values ala 'pgDQuote'. -parsePGDQuote :: P.Stream s m Char => Bool -> String -> (String -> Bool) -> P.ParsecT s u m (Maybe String) -parsePGDQuote blank unsafe isnul = (Just <$> q P.<|> mnul <$> uq) where - q = P.between (P.char '"') (P.char '"') $ - P.many $ (P.char '\\' >> P.anyChar) P.<|> P.noneOf "\\\"" - uq = (if blank then P.many else P.many1) (P.noneOf ('"':'\\':unsafe)) +parsePGDQuote :: Bool -> [Char] -> (BS.ByteString -> Bool) -> P.Parser (Maybe BS.ByteString) +parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where + q = P.char '"' *> (BS.concat <$> qs) + qs = do + p <- P.takeTill (\c -> c == '"' || c == '\\') + e <- P.anyChar + if e == '"' + then return [p] + else do + c <- P.anyWord8 + (p :) . (BS.singleton c :) <$> qs + uq = (if blank then P.takeWhile else P.takeWhile1) (`notElem` ('"':'\\':unsafe)) mnul s | isnul s = Nothing | otherwise = Just s @@ -466,36 +475,25 @@ instance PGParameter "interval" Time.DiffTime where -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. -- We collapse all interval fields into seconds instance PGColumn "interval" Time.DiffTime where - pgDecode _ a = either (error . ("pgDecode interval: " ++) . show) id $ P.parse ps (BSC.unpack a) a where + pgDecode _ a = either (error . ("pgDecode interval (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly ps a where ps = do _ <- P.char 'P' d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)] - (d +) <$> pt P.<|> d <$ P.eof + ((d +) <$> pt) <> (d <$ P.endOfInput) pt = do _ <- P.char 'T' t <- units [('H', 3600), ('M', 60), ('S', 1)] - _ <- P.eof + P.endOfInput return t - units l = fmap sum $ P.many $ do - s <- negate <$ P.char '-' P.<|> id <$ P.char '+' P.<|> return id - x <- num + units l = fmap sum $ P.many' $ do + s <- (negate <$ P.char '-') <> (id <$ P.char '+') <> return id + x <- P.number u <- P.choice $ map (\(c, u) -> s u <$ P.char c) l - return $ either (Time.secondsToDiffTime . (* u)) (realToFrac . (* fromInteger u)) x + return $ case x of + P.I i -> Time.secondsToDiffTime (i * u) + P.D d -> realToFrac (d * fromInteger u) 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 - } #ifdef USE_BINARY pgDecodeBinary = binDecDatetime BinD.interval #endif @@ -559,13 +557,9 @@ instance PGRecordType t => PGParameter t PGRecord where pgLiteral _ (PGRecord l) = BSC.pack "ROW(" <> BS.intercalate (BSC.singleton ',') (map (maybe (BSC.pack "NULL") pgQuote) l) `BSC.snoc` ')' instance PGRecordType t => PGColumn t PGRecord where - pgDecode _ a = either (error . ("pgDecode record: " ++) . show) PGRecord $ P.parse pa (BSC.unpack a) a where - pa = do - l <- P.between (P.char '(') (P.char ')') $ - P.sepBy el (P.char ',') - _ <- P.eof - return l - el = fmap BSC.pack <$> parsePGDQuote True "()," null + pgDecode _ a = either (error . ("pgDecode record (" ++) . (++ ("): " ++ BSC.unpack a))) PGRecord $ P.parseOnly pa a where + pa = P.char '(' *> P.sepBy el (P.char ',') <* P.char ')' <* P.endOfInput + el = parsePGDQuote True "()," BS.null instance PGType "record" -- |The generic anonymous record type, as created by @ROW@. @@ -577,13 +571,13 @@ instance PGType "json" instance PGParameter "json" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode instance PGColumn "json" JSON.Value where - pgDecode _ j = either (error . ("pgDecode json: " ++)) id $ JSONP.parseOnly JSON.json j + pgDecode _ j = either (error . ("pgDecode json (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j instance PGType "jsonb" instance PGParameter "jsonb" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode instance PGColumn "jsonb" JSON.Value where - pgDecode _ j = either (error . ("pgDecode json: " ++)) id $ JSONP.parseOnly JSON.json j + pgDecode _ j = either (error . ("pgDecode jsonb (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j #endif {- diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 2546f67..4fb94c4 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -52,14 +52,14 @@ Library base >= 4.7 && < 5, array, binary, - containers < 0.5.6, + containers, old-locale, - time < 1.5, + time, bytestring >= 0.10.2, template-haskell, haskell-src-meta, network, - parsec, + attoparsec >= 0.10, utf8-string Exposed-Modules: Database.PostgreSQL.Typed @@ -93,7 +93,7 @@ Library Build-Depends: scientific >= 0.3 CPP-options: -DUSE_SCIENTIFIC if flag(aeson) - Build-Depends: aeson >= 0.7, attoparsec >= 0.10 + Build-Depends: aeson >= 0.7 CPP-options: -DUSE_AESON test-suite test From 56210d5deeb7cea279d83486e419bcddd04e719e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 4 Jun 2015 11:19:58 -0400 Subject: [PATCH 154/306] Register upper-bound for attoparsec due to deprecations --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 4fb94c4..5842600 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -59,7 +59,7 @@ Library template-haskell, haskell-src-meta, network, - attoparsec >= 0.10, + attoparsec >= 0.10 && < 0.14, utf8-string Exposed-Modules: Database.PostgreSQL.Typed From 11fc4835f5e018134649f8d7528a34d6bb2b7db0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 8 Jun 2015 22:33:13 -0400 Subject: [PATCH 155/306] Switch interval parsing to scientific Fixes numeric errors introduces by double parsing and deprecation warning. Bump attoparsec requirement accordingly. --- Database/PostgreSQL/Typed/Types.hs | 11 ++++------- postgresql-typed.cabal | 2 +- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index a0ed2ae..faa2feb 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -475,7 +475,7 @@ instance PGParameter "interval" Time.DiffTime where -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. -- We collapse all interval fields into seconds instance PGColumn "interval" Time.DiffTime where - pgDecode _ a = either (error . ("pgDecode interval (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly ps a where + pgDecode _ a = either (error . ("pgDecode interval (" ++) . (++ ("): " ++ BSC.unpack a))) realToFrac $ P.parseOnly ps a where ps = do _ <- P.char 'P' d <- units [('Y', 12*month), ('M', month), ('W', 7*day), ('D', day)] @@ -486,12 +486,9 @@ instance PGColumn "interval" Time.DiffTime where P.endOfInput return t units l = fmap sum $ P.many' $ do - s <- (negate <$ P.char '-') <> (id <$ P.char '+') <> return id - x <- P.number - u <- P.choice $ map (\(c, u) -> s u <$ P.char c) l - return $ case x of - P.I i -> Time.secondsToDiffTime (i * u) - P.D d -> realToFrac (d * fromInteger u) + x <- P.signed P.scientific + u <- P.choice $ map (\(c, u) -> u <$ P.char c) l + return $ x * u day = 86400 month = 2629746 #ifdef USE_BINARY diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 5842600..3c73728 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -59,7 +59,7 @@ Library template-haskell, haskell-src-meta, network, - attoparsec >= 0.10 && < 0.14, + attoparsec >= 0.12 && < 0.14, utf8-string Exposed-Modules: Database.PostgreSQL.Typed From dd510bb1c57ba8b5a887d73690c373c2db307d0f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 12 Jun 2015 21:31:22 -0400 Subject: [PATCH 156/306] Handle a "duplicate" ReadyForQuery after Sync This seems to happen after an ErrorResponse and explicit Sync, when the pending ReadyForQuery hasn't arrived yet for some reason. --- Database/PostgreSQL/Typed/Protocol.hs | 34 +++++++++++++++++---------- Database/PostgreSQL/Typed/Types.hs | 2 +- 2 files changed, 22 insertions(+), 14 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 4aa27a7..a143381 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -39,7 +39,7 @@ import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as BSL import Data.ByteString.Lazy.Internal (smallChunkSize) import qualified Data.Foldable as Fold -import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef) +import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef, modifyIORef') import Data.Int (Int32, Int16) import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe) @@ -56,6 +56,7 @@ import Database.PostgreSQL.Typed.Dynamic data PGState = StateUnknown -- no Sync + | StateCommand -- was Sync, sent command | StatePending -- Sync sent -- ReadyForQuery received: | StateIdle @@ -257,11 +258,17 @@ 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 (case msg of Sync -> StatePending ; _ -> StateUnknown) + modifyIORef' sr $ state msg 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 + where + (t, b) = second (BSL.toStrict . B.toLazyByteString) $ messageBody msg + state _ StateClosed = StateClosed + state Sync _ = StatePending + state Terminate _ = StateClosed + state _ StateUnknown = StateUnknown + state _ _ = StateCommand pgFlush :: PGConnection -> IO () pgFlush = hFlush . connHandle @@ -341,25 +348,27 @@ getMessage = G.runGetIncremental $ do return msg pgRecv :: Bool -> PGConnection -> IO (Maybe PGBackendMessage) -pgRecv block c@PGConnection{ connHandle = h, connInput = dr } = +pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = go =<< readIORef dr where next = writeIORef dr - state s d = writeIORef (connState c) s >> next d + state s d = writeIORef sr s >> next d new = G.pushChunk getMessage go (G.Done b _ m) = do when (connDebug c) $ putStrLn $ "< " ++ show m - got (new b) m + got (new b) m =<< readIORef sr 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 + got :: G.Decoder PGBackendMessage -> PGBackendMessage -> PGState -> IO (Maybe PGBackendMessage) + got d (NoticeResponse m) _ = connLogMessage c m >> go d + got d (ReadyForQuery _) StateCommand = go d + got d m@(ReadyForQuery s) _ = Just m <$ state s d + got d m@(ErrorResponse _) _ = Just m <$ state StateUnknown d + got d m StateCommand = 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. @@ -427,9 +436,8 @@ pgConnect db = do -- |Disconnect cleanly from the PostgreSQL server. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () -pgDisconnect c@PGConnection{ connHandle = h, connState = s } = do +pgDisconnect c@PGConnection{ connHandle = h } = 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. diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index faa2feb..da1a97c 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -98,7 +98,7 @@ type PGValues = [PGValue] -- Nothing values represent unknown. data PGTypeEnv = PGTypeEnv { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. - } + } deriving (Show) unknownPGTypeEnv :: PGTypeEnv unknownPGTypeEnv = PGTypeEnv From 1c05971c4cb660a957a59439cee206300a9188e3 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 15 Jun 2015 15:25:51 -0400 Subject: [PATCH 157/306] Only save explicitly specified type OIDs in prepared query Should be safe, as the others were inferred the first time anyway. Upside is more portability of code across databases. Downside is a bit more work by pg and potentially unsafe (even dangerous if binary) queries if types change enough to make inference different. --- Database/PostgreSQL/Typed/Query.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 73dcb4c..9783c99 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -182,12 +182,12 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do , tpgTypeBinary t e )) rt foldl TH.AppE (TH.LamE vars $ TH.ConE 'QueryParser - `TH.AppE` TH.LamE [TH.VarP e] (if isNothing prep - then TH.ConE 'SimpleQuery - `TH.AppE` sqlSubstitute sqlp vals - else TH.ConE 'PreparedQuery + `TH.AppE` TH.LamE [TH.VarP e] (maybe + (TH.ConE 'SimpleQuery + `TH.AppE` sqlSubstitute sqlp vals) + (\p -> TH.ConE 'PreparedQuery `TH.AppE` (TH.VarE 'fromString `TH.AppE` stringE sqlp) - `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID) pt) + `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID . snd) $ zip p pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE #ifdef USE_BINARY @@ -196,6 +196,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do [] #endif ) + prep) `TH.AppE` TH.LamE [TH.VarP e, TH.ListP pats] (TH.TupE conv)) <$> mapM parse exprs where From 739c085f2dc448f97f2ad643e0a3a8541c571c58 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 19 Jun 2015 01:27:18 -0400 Subject: [PATCH 158/306] Explicitly set block buffering on connections Despite documentation to the contrary, network handles actually start with NoBuffering. --- Database/PostgreSQL/Typed/Protocol.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index a143381..ea2db6b 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -47,7 +47,7 @@ import Data.Monoid (mempty, (<>)) import Data.Typeable (Typeable) import Data.Word (Word32) import Network (HostName, PortID(..), connectTo) -import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn) +import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) @@ -389,6 +389,7 @@ pgConnect db = do prep <- newIORef (0, Map.empty) input <- newIORef getMessage h <- connectTo (pgDBHost db) (pgDBPort db) + hSetBuffering h (BlockBuffering Nothing) let c = PGConnection { connHandle = h , connDatabase = db From 396214a493e9016c0e75a0a10ed703326d7a6a08 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 4 Jul 2015 12:42:59 -0400 Subject: [PATCH 159/306] Upgrade stability to beta for 0.4.0 release --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 3c73728..f9218e8 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -6,7 +6,7 @@ License-File: COPYING Copyright: 2010-2013 Chris Forno, 2014-2015 Dylan Simon Author: Dylan Simon Maintainer: Dylan Simon -Stability: alpha +Stability: beta Bug-Reports: https://github.com/dylex/postgresql-typed/issues Homepage: https://github.com/dylex/postgresql-typed Category: Database From 65539d4350de3e5d7357ec4004837919dbce2498 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 25 Aug 2015 11:45:42 -0400 Subject: [PATCH 160/306] Eliminate some (but not all) warnings on ghc 7.10 --- Database/PostgreSQL/Typed/Dynamic.hs | 4 ++-- Database/PostgreSQL/Typed/Internal.hs | 10 +++++----- Database/PostgreSQL/Typed/Query.hs | 4 ++-- Database/PostgreSQL/Typed/Types.hs | 16 ++++++++-------- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 45b612a..b814785 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -105,10 +105,10 @@ instance PGRep "uuid" UUID.UUID -- Unlike most other TH functions, this does not require any database connection. pgSubstituteLiterals :: String -> TH.ExpQ pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BS.concat) . TH.ListE <$> ssl (sqlSplitExprs sql) where - ssl :: SQLSplit String True -> TH.Q [TH.Exp] + ssl :: SQLSplit String 'True -> TH.Q [TH.Exp] ssl (SQLLiteral s l) = (TH.VarE 'fromString `TH.AppE` stringE s :) <$> ssp l ssl SQLSplitEnd = return [] - ssp :: SQLSplit String False -> TH.Q [TH.Exp] + ssp :: SQLSplit String 'False -> TH.Q [TH.Exp] ssp (SQLPlaceholder e l) = do v <- either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e (TH.VarE 'pgSafeLiteral `TH.AppE` v :) <$> ssl l diff --git a/Database/PostgreSQL/Typed/Internal.hs b/Database/PostgreSQL/Typed/Internal.hs index 9ed17ae..aff1b62 100644 --- a/Database/PostgreSQL/Typed/Internal.hs +++ b/Database/PostgreSQL/Typed/Internal.hs @@ -21,15 +21,15 @@ instance IsString TH.Exp where fromString = stringE data SQLSplit a (literal :: Bool) where - SQLLiteral :: String -> SQLSplit a False -> SQLSplit a True - SQLPlaceholder :: a -> SQLSplit a True -> SQLSplit a False + SQLLiteral :: String -> SQLSplit a 'False -> SQLSplit a 'True + SQLPlaceholder :: a -> SQLSplit a 'True -> SQLSplit a 'False SQLSplitEnd :: SQLSplit a any -sqlCons :: Char -> SQLSplit a True -> SQLSplit a True +sqlCons :: Char -> SQLSplit a 'True -> SQLSplit a 'True sqlCons c (SQLLiteral s l) = SQLLiteral (c : s) l sqlCons c SQLSplitEnd = SQLLiteral [c] SQLSplitEnd -sqlSplitExprs :: String -> SQLSplit String True +sqlSplitExprs :: String -> SQLSplit String 'True sqlSplitExprs ('$':'$':'{':s) = sqlCons '$' $ sqlCons '{' $ sqlSplitExprs s sqlSplitExprs ('$':'{':s) | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = SQLLiteral "" $ SQLPlaceholder e $ sqlSplitExprs r @@ -37,7 +37,7 @@ sqlSplitExprs ('$':'{':s) sqlSplitExprs (c:s) = sqlCons c $ sqlSplitExprs s sqlSplitExprs [] = SQLSplitEnd -sqlSplitParams :: String -> SQLSplit Int True +sqlSplitParams :: String -> SQLSplit Int 'True sqlSplitParams ('$':'$':d:s) | isDigit d = sqlCons '$' $ sqlCons d $ sqlSplitParams s sqlSplitParams ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = SQLLiteral "" $ SQLPlaceholder n $ sqlSplitParams r sqlSplitParams (c:s) = sqlCons c $ sqlSplitParams s diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 9783c99..4eb995b 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -118,10 +118,10 @@ pgLazyQuery c (QueryParser q p) count = -- Embedded expressions may not contain @{@ or @}@. sqlPlaceholders :: String -> (String, [String]) sqlPlaceholders = ssl 1 . sqlSplitExprs where - ssl :: Int -> SQLSplit String True -> (String, [String]) + ssl :: Int -> SQLSplit String 'True -> (String, [String]) ssl n (SQLLiteral s l) = first (s ++) $ ssp n l ssl _ SQLSplitEnd = ("", []) - ssp :: Int -> SQLSplit String False -> (String, [String]) + ssp :: Int -> SQLSplit String 'False -> (String, [String]) ssp n (SQLPlaceholder e l) = (('$':show n) ++) *** (e :) $ ssl (succ n) l ssp _ SQLSplitEnd = ("", []) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index da1a97c..24b5263 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -318,17 +318,17 @@ instance PGStringType t => PGColumn t String where pgDecode _ = BSU.toString BIN_DEC((T.unpack .) . binDec BinD.text) -instance PGStringType t => PGParameter t BS.ByteString where +instance {-# OVERLAPPABLE #-} PGStringType t => PGParameter t BS.ByteString where pgEncode _ = id BIN_ENC(BinE.text . Left . TE.decodeUtf8) -instance PGStringType t => PGColumn t BS.ByteString where +instance {-# OVERLAPPABLE #-} PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text) -instance PGStringType t => PGParameter t BSL.ByteString where +instance {-# OVERLAPPABLE #-} PGStringType t => PGParameter t BSL.ByteString where pgEncode _ = BSL.toStrict BIN_ENC(BinE.text . Right . TLE.decodeUtf8) -instance PGStringType t => PGColumn t BSL.ByteString where +instance {-# OVERLAPPABLE #-} PGStringType t => PGColumn t BSL.ByteString where pgDecode _ = BSL.fromStrict BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text) @@ -373,18 +373,18 @@ decodeBytea s unhex = fromIntegral . digitToInt . w2c instance PGType "bytea" where BIN_COL -instance PGParameter "bytea" BSL.ByteString where +instance {-# OVERLAPPING #-} PGParameter "bytea" BSL.ByteString where pgEncode _ = encodeBytea . BSB.lazyByteStringHex pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.bytea . Right) -instance PGColumn "bytea" BSL.ByteString where +instance {-# OVERLAPPING #-} PGColumn "bytea" BSL.ByteString where pgDecode _ = BSL.pack . decodeBytea BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea) -instance PGParameter "bytea" BS.ByteString where +instance {-# OVERLAPPING #-} PGParameter "bytea" BS.ByteString where pgEncode _ = encodeBytea . BSB.byteStringHex pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.bytea . Left) -instance PGColumn "bytea" BS.ByteString where +instance {-# OVERLAPPING #-} PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea BIN_DEC(binDec BinD.bytea) From e90ad5574d3a3e7086f1e87bc5f6aeadeb387ce7 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 11 Sep 2015 11:53:18 -0400 Subject: [PATCH 161/306] Fix race condition related to resolving types Don't bother deferring loading type map since we need it in most cases anyway. --- Database/PostgreSQL/Typed/TH.hs | 8 +++----- postgresql-typed.cabal | 2 +- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 84fa865..6e057a0 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -76,11 +76,9 @@ data TPGState = TPGState tpgLoadTypes :: TPGState -> IO TPGState tpgLoadTypes tpg = do - -- defer loading types until they're needed - tl <- unsafeInterleaveIO $ pgSimpleQuery (tpgConnection tpg) $ BSLC.pack "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 (\[to, tn] -> - (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) $ snd tl - } + t <- IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . + snd <$> pgSimpleQuery (tpgConnection tpg) (BSLC.pack "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 = t } tpgInit :: PGConnection -> IO TPGState tpgInit c = tpgLoadTypes TPGState{ tpgConnection = c, tpgTypes = undefined } diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index f9218e8..45b0829 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.0 +Version: 0.4.1 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From b801ca9fc59e9ebe2c7c9d82aba56ef90d18c625 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 18 Oct 2015 00:40:03 -0400 Subject: [PATCH 162/306] Don't generate invalid var name identifiers --- Database/PostgreSQL/Typed/Query.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 4eb995b..d6e1252 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -23,7 +23,7 @@ import Data.Array (listArray, (!), inRange) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL -import Data.Char (isSpace) +import Data.Char (isSpace, isAlphaNum) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing) @@ -160,6 +160,9 @@ data QueryFlags = QueryFlags simpleQueryFlags :: QueryFlags simpleQueryFlags = QueryFlags True Nothing Nothing +newName :: BS.ByteString -> TH.Q TH.Name +newName = TH.newName . filter (\c -> isAlphaNum c || c == '_') . BSC.unpack + -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle @@ -169,13 +172,13 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do e <- TH.newName "_tenv" (vars, vals) <- mapAndUnzipM (\t -> do - v <- TH.newName $ 'p':BSC.unpack (tpgValueName t) + v <- newName $ 'p' `BSC.cons` tpgValueName t return ( TH.VarP v , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v )) pt (pats, conv, bins) <- unzip3 <$> mapM (\t -> do - v <- TH.newName $ 'c':BSC.unpack (tpgValueName t) + v <- newName $ 'c' `BSC.cons` tpgValueName t return ( TH.VarP v , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v From 08927c7467113e951d6d826db31717e4f8b34c4f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 19 Oct 2015 12:56:00 -0400 Subject: [PATCH 163/306] Eliminate warnings for ghc 7.10 --- Database/PostgreSQL/Typed/Array.hs | 9 +++++++-- Database/PostgreSQL/Typed/Dynamic.hs | 2 ++ Database/PostgreSQL/Typed/Internal.hs | 1 + Database/PostgreSQL/Typed/Protocol.hs | 7 ++++++- Database/PostgreSQL/Typed/Query.hs | 2 ++ Database/PostgreSQL/Typed/Range.hs | 9 +++++++-- Database/PostgreSQL/Typed/TH.hs | 5 ++++- Database/PostgreSQL/Typed/Types.hs | 29 +++++++++++++++++++++------ 8 files changed, 52 insertions(+), 12 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 9816477..65b84da 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Array @@ -10,13 +10,18 @@ module Database.PostgreSQL.Typed.Array where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (*>), (<*)) +#endif import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC import Data.Char (toLower) import Data.List (intersperse) -import Data.Monoid ((<>), mconcat) +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat) +#endif import Database.PostgreSQL.Typed.Types diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index b814785..000f48a 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -14,7 +14,9 @@ module Database.PostgreSQL.Typed.Dynamic , pgSubstituteLiterals ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.Monoid ((<>)) diff --git a/Database/PostgreSQL/Typed/Internal.hs b/Database/PostgreSQL/Typed/Internal.hs index aff1b62..d2ba72c 100644 --- a/Database/PostgreSQL/Typed/Internal.hs +++ b/Database/PostgreSQL/Typed/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms, PatternGuards, TemplateHaskell, GADTs, KindSignatures, DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.PostgreSQL.Typed.Internal ( stringE , pattern StringE diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index ea2db6b..5c6ac1e 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -24,7 +24,9 @@ module Database.PostgreSQL.Typed.Protocol ( , pgCloseStatement ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) +#endif import Control.Arrow (second) import Control.Exception (Exception, throwIO) import Control.Monad (liftM2, replicateM, when, unless) @@ -43,7 +45,10 @@ import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, at import Data.Int (Int32, Int16) import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe) -import Data.Monoid (mempty, (<>)) +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty) +#endif import Data.Typeable (Typeable) import Data.Word (Word32) import Network (HostName, PortID(..), connectTo) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index d6e1252..6f7b4bd 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -15,7 +15,9 @@ module Database.PostgreSQL.Typed.Query , pgLazyQuery ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) +#endif import Control.Arrow ((***), first, second) import Control.Exception (try) import Control.Monad (void, when, mapAndUnzipM) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index c33c51c..c1a56c7 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range @@ -10,12 +10,17 @@ module Database.PostgreSQL.Typed.Range where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) +#endif import Control.Monad (guard) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC -import Data.Monoid (Monoid(..), (<>)) +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid(..)) +#endif import Database.PostgreSQL.Typed.Types diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 6e057a0..76370b9 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -18,7 +18,10 @@ module Database.PostgreSQL.Typed.TH , tpgTypeBinary ) where -import Control.Applicative ((<$>), (<$), (<|>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<$)) +#endif +import Control.Applicative ((<|>)) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, modifyMVar_) import Control.Exception (onException, finally) import Control.Monad (liftM2) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 24b5263..5f9b40c 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif -- | -- Module: Database.PostgreSQL.Typed.Types -- Copyright: 2015 Dylan Simon @@ -34,7 +37,9 @@ module Database.PostgreSQL.Typed.Types , buildPGValue ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$), (<*), (*>)) +#endif #ifdef USE_AESON import qualified Data.Aeson as JSON #endif @@ -53,7 +58,10 @@ 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.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat, mempty) +#endif import Data.Ratio ((%), numerator, denominator) #ifdef USE_SCIENTIFIC import Data.Scientific (Scientific) @@ -388,13 +396,22 @@ instance {-# OVERLAPPING #-} PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea BIN_DEC(binDec BinD.bytea) +readTime :: Time.ParseTime t => String -> String -> t +readTime = +#if MIN_VERSION_time(1,5,0) + Time.parseTimeOrError False +#else + Time.readTime +#endif + defaultTimeLocale + instance PGType "date" where BIN_COL instance PGParameter "date" Time.Day where pgEncode _ = BSC.pack . Time.showGregorian pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.date) instance PGColumn "date" Time.Day where - pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack + pgDecode _ = readTime "%F" . BSC.unpack BIN_DEC(binDec BinD.date) binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool @@ -420,7 +437,7 @@ instance PGParameter "time without time zone" Time.TimeOfDay where pgEncodeValue = binEncDatetime BinE.time #endif instance PGColumn "time without time zone" Time.TimeOfDay where - pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack + pgDecode _ = readTime "%T%Q" . BSC.unpack #ifdef USE_BINARY pgDecodeBinary = binDecDatetime BinD.time #endif @@ -434,7 +451,7 @@ instance PGParameter "timestamp without time zone" Time.LocalTime where pgEncodeValue = binEncDatetime BinE.timestamp #endif instance PGColumn "timestamp without time zone" Time.LocalTime where - pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack + pgDecode _ = readTime "%F %T%Q" . BSC.unpack #ifdef USE_BINARY pgDecodeBinary = binDecDatetime BinD.timestamp #endif @@ -458,7 +475,7 @@ instance PGParameter "timestamp with time zone" Time.UTCTime where pgEncodeValue = binEncDatetime BinE.timestamptz #endif instance PGColumn "timestamp with time zone" Time.UTCTime where - pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack + pgDecode _ = readTime "%F %T%Q%z" . fixTZ . BSC.unpack #ifdef USE_BINARY pgDecodeBinary = binDecDatetime BinD.timestamptz #endif From 59d52db296d99d63d0ba5934ebb3658cd2c7d97c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 19 Oct 2015 12:58:51 -0400 Subject: [PATCH 164/306] Eliminate resulting warnings on ghc 7.8 --- Database/PostgreSQL/Typed/Types.hs | 48 +++++++++++++++++++++++++----- 1 file changed, 40 insertions(+), 8 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 5f9b40c..d6b5b0a 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -326,17 +326,33 @@ instance PGStringType t => PGColumn t String where pgDecode _ = BSU.toString BIN_DEC((T.unpack .) . binDec BinD.text) -instance {-# OVERLAPPABLE #-} PGStringType t => PGParameter t BS.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGParameter t BS.ByteString where pgEncode _ = id BIN_ENC(BinE.text . Left . TE.decodeUtf8) -instance {-# OVERLAPPABLE #-} PGStringType t => PGColumn t BS.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text) -instance {-# OVERLAPPABLE #-} PGStringType t => PGParameter t BSL.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGParameter t BSL.ByteString where pgEncode _ = BSL.toStrict BIN_ENC(BinE.text . Right . TLE.decodeUtf8) -instance {-# OVERLAPPABLE #-} PGStringType t => PGColumn t BSL.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGColumn t BSL.ByteString where pgDecode _ = BSL.fromStrict BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text) @@ -381,18 +397,34 @@ decodeBytea s unhex = fromIntegral . digitToInt . w2c instance PGType "bytea" where BIN_COL -instance {-# OVERLAPPING #-} PGParameter "bytea" BSL.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGParameter "bytea" BSL.ByteString where pgEncode _ = encodeBytea . BSB.lazyByteStringHex pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.bytea . Right) -instance {-# OVERLAPPING #-} PGColumn "bytea" BSL.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGColumn "bytea" BSL.ByteString where pgDecode _ = BSL.pack . decodeBytea BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea) -instance {-# OVERLAPPING #-} PGParameter "bytea" BS.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGParameter "bytea" BS.ByteString where pgEncode _ = encodeBytea . BSB.byteStringHex pgLiteral t = pgQuoteUnsafe . pgEncode t BIN_ENC(BinE.bytea . Left) -instance {-# OVERLAPPING #-} PGColumn "bytea" BS.ByteString where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea BIN_DEC(binDec BinD.bytea) From f867781245a05d2d40889fddbc3d75a8cbe6b24c Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 19 Oct 2015 13:00:40 -0400 Subject: [PATCH 165/306] Annotate 7.10.2 compliance --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 45b0829..fb47666 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -16,7 +16,7 @@ Description: Automatically type-check SQL statements at compile time. 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 +Tested-With: GHC == 7.8.4, GHC == 7.10.2 Build-Type: Simple source-repository head From 71d672990eaf1f8f0b68fc6089ff57519bb2a5d5 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 23 Oct 2015 16:58:52 -0400 Subject: [PATCH 166/306] Add Show instances for Query types Can be helpful for debugging --- Database/PostgreSQL/Typed/Query.hs | 9 +++++++++ Database/PostgreSQL/Typed/Types.hs | 7 ++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 6f7b4bd..cc06357 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -29,6 +29,9 @@ import Data.Char (isSpace, isAlphaNum) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty) +#endif import Data.String (IsString(..)) import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) @@ -64,12 +67,14 @@ instance PGQuery BS.ByteString PGValues where unsafeModifyQuery q f = f q newtype SimpleQuery = SimpleQuery BS.ByteString + deriving (Show) instance PGQuery SimpleQuery PGValues where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c (BSL.fromStrict sql) unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql instance PGRawQuery SimpleQuery data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool] + deriving (Show) instance PGQuery PreparedQuery PGValues where pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc @@ -84,6 +89,10 @@ instance PGRawQuery q => PGQuery (QueryParser q a) a where instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) +instance Show q => Show (QueryParser q a) where + showsPrec p (QueryParser q _) = showParen (p > 10) $ + showString "QueryParser " . showsPrec 11 (q mempty) + rawParser :: q -> QueryParser q PGValues rawParser q = QueryParser (const q) (const id) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index d6b5b0a..fa19613 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -40,6 +40,7 @@ module Database.PostgreSQL.Typed.Types #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$), (<*), (*>)) #endif +import Control.Applicative ((<|>)) #ifdef USE_AESON import qualified Data.Aeson as JSON #endif @@ -60,7 +61,7 @@ import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mconcat, mempty) +import Data.Monoid (Monoid(..), mconcat) #endif import Data.Ratio ((%), numerator, denominator) #ifdef USE_SCIENTIFIC @@ -108,6 +109,10 @@ data PGTypeEnv = PGTypeEnv { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. } deriving (Show) +instance Monoid PGTypeEnv where + mempty = PGTypeEnv Nothing + mappend (PGTypeEnv i1) (PGTypeEnv i2) = PGTypeEnv (i1 <|> i2) + unknownPGTypeEnv :: PGTypeEnv unknownPGTypeEnv = PGTypeEnv { pgIntegerDatetimes = Nothing From 82779ee986c064753217c87400882e0856c74e5f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 23 Oct 2015 17:59:51 -0400 Subject: [PATCH 167/306] Add some stateful pgTransaction functions to Protocol --- Database/PostgreSQL/Typed/Protocol.hs | 50 +++++++++++++++++++++++-- Database/PostgreSQL/Typed/TemplatePG.hs | 9 +---- 2 files changed, 48 insertions(+), 11 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 5c6ac1e..9b5a03e 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -16,20 +16,26 @@ module Database.PostgreSQL.Typed.Protocol ( , pgConnect , pgDisconnect , pgReconnect + -- * Query operations , pgDescribe , pgSimpleQuery , pgSimpleQueries_ , pgPreparedQuery , pgPreparedLazyQuery , pgCloseStatement + -- * Transactions + , pgBegin + , pgCommit + , pgRollback + , pgTransaction ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) #endif -import Control.Arrow (second) -import Control.Exception (Exception, throwIO) -import Control.Monad (liftM2, replicateM, when, unless) +import Control.Arrow ((&&&), second) +import Control.Exception (Exception, throwIO, onException) +import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef USE_MD5 import qualified Crypto.Hash as Hash #endif @@ -39,6 +45,7 @@ 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 qualified Data.ByteString.Lazy.Char8 as BSLC import Data.ByteString.Lazy.Internal (smallChunkSize) import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef, modifyIORef') @@ -50,7 +57,7 @@ import Data.Monoid ((<>)) import Data.Monoid (mempty) #endif import Data.Typeable (Typeable) -import Data.Word (Word32) +import Data.Word (Word, Word32) import Network (HostName, PortID(..), connectTo) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) import System.IO.Unsafe (unsafeInterleaveIO) @@ -97,6 +104,7 @@ data PGConnection = PGConnection , connPreparedStatements :: IORef (Integer, Map.Map (BS.ByteString, [OID]) Integer) , connState :: IORef PGState , connInput :: IORef (G.Decoder PGBackendMessage) + , connTransaction :: IORef Word } data ColDescription = ColDescription @@ -393,6 +401,7 @@ pgConnect db = do state <- newIORef StateUnknown prep <- newIORef (0, Map.empty) input <- newIORef getMessage + tr <- newIORef 0 h <- connectTo (pgDBHost db) (pgDBPort db) hSetBuffering h (BlockBuffering Nothing) let c = PGConnection @@ -405,6 +414,7 @@ pgConnect db = do , connState = state , connTypeEnv = unknownPGTypeEnv , connInput = input + , connTransaction = tr } pgSend c $ StartupMessage [ (BSC.pack "user", pgDBUser db) @@ -645,3 +655,35 @@ pgCloseStatement c@PGConnection{ connPreparedStatements = psr } sql types = do pgFlush c CloseComplete <- pgReceive c return () + +-- |Begin a new transaction. If there is already a transaction in progress (created with 'pgBegin' or 'pgTransaction') instead creates a savepoint. +pgBegin :: PGConnection -> IO () +pgBegin c@PGConnection{ connTransaction = tr } = do + t <- atomicModifyIORef' tr (succ &&& id) + void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "BEGIN" else "SAVEPOINT pgt" ++ show t + +predTransaction :: Word -> (Word, Word) +predTransaction 0 = (0, error "pgTransaction: no transactions") +predTransaction x = (x', x') where x' = pred x + +-- |Rollback to the most recent 'pgBegin'. +pgRollback :: PGConnection -> IO () +pgRollback c@PGConnection{ connTransaction = tr } = do + t <- atomicModifyIORef' tr predTransaction + void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "ROLLBACK" else "ROLLBACK TO SAVEPOINT pgt" ++ show t + +-- |Commit the most recent 'pgBegin'. +pgCommit :: PGConnection -> IO () +pgCommit c@PGConnection{ connTransaction = tr } = do + t <- atomicModifyIORef' tr predTransaction + void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "COMMIT" else "RELEASE SAVEPOINT pgt" ++ show t + +-- |Wrap a computation in a 'pgBegin', 'pgCommit' block, or 'pgRollback' on exception. +pgTransaction :: PGConnection -> IO a -> IO a +pgTransaction c f = do + pgBegin c + onException (do + r <- f + pgCommit c + return r) + (pgRollback c) diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index c634ce6..5126644 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -22,7 +22,7 @@ module Database.PostgreSQL.Typed.TemplatePG , PG.pgDisconnect ) where -import Control.Exception (onException, catchJust) +import Control.Exception (catchJust) import Control.Monad (liftM, void, guard) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC @@ -76,12 +76,7 @@ execute sql = [| \c -> void $ pgExecute c $(makePGQuery simpleQueryFlags $ query -- 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 $ BSLC.pack "BEGIN" - c <- a - void $ PG.pgSimpleQuery h $ BSLC.pack "COMMIT" - return c) - (void $ PG.pgSimpleQuery h $ BSLC.pack "ROLLBACK") +withTransaction = PG.pgTransaction -- |Roll back a transaction. rollback :: PG.PGConnection -> IO () From 044bae9f50f71d7a1d2c82616a70cea205b0a1f6 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 23 Oct 2015 18:02:14 -0400 Subject: [PATCH 168/306] Fixup base 4.8 warning from last --- Database/PostgreSQL/Typed/Protocol.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 9b5a03e..9c9b9be 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -57,7 +57,10 @@ import Data.Monoid ((<>)) import Data.Monoid (mempty) #endif import Data.Typeable (Typeable) -import Data.Word (Word, Word32) +#if !MIN_VERSION_base(4,8,0) +import Data.Word (Word) +#endif +import Data.Word (Word32) import Network (HostName, PortID(..), connectTo) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) import System.IO.Unsafe (unsafeInterleaveIO) From 078687941c739a09ae1e89cc12784cc54593d648 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 25 Oct 2015 11:13:13 -0400 Subject: [PATCH 169/306] Avoid generating reserved-word variables By prefixing everything with '_'. The new newName behavior is a bit unpleasant. --- Database/PostgreSQL/Typed/Query.hs | 8 ++++---- Database/PostgreSQL/Typed/Types.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index cc06357..e64b85b 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -171,8 +171,8 @@ data QueryFlags = QueryFlags simpleQueryFlags :: QueryFlags simpleQueryFlags = QueryFlags True Nothing Nothing -newName :: BS.ByteString -> TH.Q TH.Name -newName = TH.newName . filter (\c -> isAlphaNum c || c == '_') . BSC.unpack +newName :: Char -> BS.ByteString -> TH.Q TH.Name +newName pre = TH.newName . ('_':) . (pre:) . filter (\c -> isAlphaNum c || c == '_') . BSC.unpack -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ @@ -183,13 +183,13 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do e <- TH.newName "_tenv" (vars, vals) <- mapAndUnzipM (\t -> do - v <- newName $ 'p' `BSC.cons` tpgValueName t + v <- newName 'p' $ tpgValueName t return ( TH.VarP v , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v )) pt (pats, conv, bins) <- unzip3 <$> mapM (\t -> do - v <- newName $ 'c' `BSC.cons` tpgValueName t + v <- newName 'c' $ tpgValueName t return ( TH.VarP v , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index fa19613..dc37c1f 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -440,7 +440,7 @@ readTime = #else Time.readTime #endif - defaultTimeLocale + defaultTimeLocale instance PGType "date" where BIN_COL instance PGParameter "date" Time.Day where From ed3bb9c21b2a7a2c54d5a7175526514b03ec8421 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 25 Oct 2015 11:18:28 -0400 Subject: [PATCH 170/306] Prepare for 0.4.2 release --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index fb47666..b8e6d38 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.1 +Version: 0.4.2 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From b2fa8d6ff975cd5023c53e13ef19d3906cd329d9 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 25 Oct 2015 11:38:08 -0400 Subject: [PATCH 171/306] Add some docs and remove useless Monoid instance --- Database/PostgreSQL/Typed.hs | 1 + Database/PostgreSQL/Typed/Dynamic.hs | 2 ++ Database/PostgreSQL/Typed/Internal.hs | 5 +++++ Database/PostgreSQL/Typed/Query.hs | 5 +---- Database/PostgreSQL/Typed/Types.hs | 8 ++------ 5 files changed, 11 insertions(+), 10 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index c27e6d7..7e3b71e 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -32,6 +32,7 @@ module Database.PostgreSQL.Typed -- $run , pgQuery , pgExecute + , pgTransaction -- **TemplatePG compatibility -- $templatepg diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 000f48a..1f5adac 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -58,6 +58,7 @@ class PGType t => PGRep t a | a -> t where pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName t) v pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue" +-- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement. pgLiteralString :: PGRep t a => a -> String pgLiteralString = BSC.unpack . pgLiteralRep @@ -65,6 +66,7 @@ pgLiteralString = BSC.unpack . pgLiteralRep pgSafeLiteral :: PGRep t a => a -> BS.ByteString pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) +-- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. pgSafeLiteralString :: PGRep t a => a -> String pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeName (pgTypeOf x) diff --git a/Database/PostgreSQL/Typed/Internal.hs b/Database/PostgreSQL/Typed/Internal.hs index d2ba72c..a94aa40 100644 --- a/Database/PostgreSQL/Typed/Internal.hs +++ b/Database/PostgreSQL/Typed/Internal.hs @@ -13,14 +13,17 @@ import Data.String (IsString(..)) import qualified Language.Haskell.TH as TH import Numeric (readDec) +-- |@'TH.LitE' . 'TH.stringL'@ stringE :: String -> TH.Exp stringE = TH.LitE . TH.StringL +-- |Pattern match for 'stringE'. pattern StringE s = TH.LitE (TH.StringL s) instance IsString TH.Exp where fromString = stringE +-- |Parsed representation of a SQL statement containing placeholders. data SQLSplit a (literal :: Bool) where SQLLiteral :: String -> SQLSplit a 'False -> SQLSplit a 'True SQLPlaceholder :: a -> SQLSplit a 'True -> SQLSplit a 'False @@ -30,6 +33,7 @@ sqlCons :: Char -> SQLSplit a 'True -> SQLSplit a 'True sqlCons c (SQLLiteral s l) = SQLLiteral (c : s) l sqlCons c SQLSplitEnd = SQLLiteral [c] SQLSplitEnd +-- |Parse a SQL stamement with ${string} placeholders into a 'SQLSplit'. sqlSplitExprs :: String -> SQLSplit String 'True sqlSplitExprs ('$':'$':'{':s) = sqlCons '$' $ sqlCons '{' $ sqlSplitExprs s sqlSplitExprs ('$':'{':s) @@ -38,6 +42,7 @@ sqlSplitExprs ('$':'{':s) sqlSplitExprs (c:s) = sqlCons c $ sqlSplitExprs s sqlSplitExprs [] = SQLSplitEnd +-- |Parse a SQL stamement with $numeric placeholders into a 'SQLSplit'. sqlSplitParams :: String -> SQLSplit Int 'True sqlSplitParams ('$':'$':d:s) | isDigit d = sqlCons '$' $ sqlCons d $ sqlSplitParams s sqlSplitParams ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = SQLLiteral "" $ SQLPlaceholder n $ sqlSplitParams r diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index e64b85b..ea7fa8b 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -29,9 +29,6 @@ import Data.Char (isSpace, isAlphaNum) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mempty) -#endif import Data.String (IsString(..)) import Data.Word (Word32) import Language.Haskell.Meta.Parse (parseExp) @@ -91,7 +88,7 @@ instance Functor (QueryParser q) where instance Show q => Show (QueryParser q a) where showsPrec p (QueryParser q _) = showParen (p > 10) $ - showString "QueryParser " . showsPrec 11 (q mempty) + showString "QueryParser " . showsPrec 11 (q unknownPGTypeEnv) rawParser :: q -> QueryParser q PGValues rawParser q = QueryParser (const q) (const id) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index dc37c1f..00da082 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -40,7 +40,6 @@ module Database.PostgreSQL.Typed.Types #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$), (<*), (*>)) #endif -import Control.Applicative ((<|>)) #ifdef USE_AESON import qualified Data.Aeson as JSON #endif @@ -61,7 +60,7 @@ import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..), mconcat) +import Data.Monoid (mempty, mconcat) #endif import Data.Ratio ((%), numerator, denominator) #ifdef USE_SCIENTIFIC @@ -109,10 +108,6 @@ data PGTypeEnv = PGTypeEnv { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. } deriving (Show) -instance Monoid PGTypeEnv where - mempty = PGTypeEnv Nothing - mappend (PGTypeEnv i1) (PGTypeEnv i2) = PGTypeEnv (i1 <|> i2) - unknownPGTypeEnv :: PGTypeEnv unknownPGTypeEnv = PGTypeEnv { pgIntegerDatetimes = Nothing @@ -194,6 +189,7 @@ pgQuoteUnsafe = (`BSC.snoc` '\'') . BSC.cons '\'' pgQuote :: BS.ByteString -> BS.ByteString pgQuote = pgQuoteUnsafe . BSC.intercalate (BSC.pack "''") . BSC.split '\'' +-- |Shorthand for @'BSL.toStrict' . 'BSB.toLazyByteString'@ buildPGValue :: BSB.Builder -> BS.ByteString buildPGValue = BSL.toStrict . BSB.toLazyByteString From 12083ad493eef604fe006c2346b41618476061c6 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 9 Nov 2015 17:42:16 -0500 Subject: [PATCH 172/306] Add Ix instance for PGEnum types --- Database/PostgreSQL/Typed/Enum.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 199e3a2..5c27a9e 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -15,6 +15,7 @@ import Control.Monad (when) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL +import Data.Ix (Ix) import Data.String (fromString) import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH @@ -56,7 +57,7 @@ makePGEnum name typs valnf = do valn = map (\[PGTextValue v] -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals dv <- TH.newName "x" return - [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Bounded, ''Typeable] + [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] , TH.InstanceD [] (TH.ConT ''Show `TH.AppT` typt) [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []] (TH.NormalB $ TH.LitE v) []) valn From 49ced119d7fa7eced59bac708159886dbd59afa5 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 9 Nov 2015 17:43:44 -0500 Subject: [PATCH 173/306] Bump version 0.4.2.1 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index b8e6d38..ff5c41b 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.2 +Version: 0.4.2.1 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From ba89e37530dc6919f168f0f375e54b33ae5f0fcd Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 17 Nov 2015 20:23:01 -0500 Subject: [PATCH 174/306] Add read/PGColumn instance for PGInet Short of unsafe exception catching(!) I couldn't think of anything better than just parsing myself. Not a perfect IP parser but should cover everything postgresql generates. --- Database/PostgreSQL/Typed/Inet.hs | 90 +++++++++++++++++++++++++++++-- 1 file changed, 87 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Inet.hs b/Database/PostgreSQL/Typed/Inet.hs index 5cdc1c3..f9785dd 100644 --- a/Database/PostgreSQL/Typed/Inet.hs +++ b/Database/PostgreSQL/Typed/Inet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Inet @@ -9,21 +9,31 @@ module Database.PostgreSQL.Typed.Inet where +import Control.Monad (void, guard, liftM2) import qualified Data.ByteString.Char8 as BSC +import Data.Bits (shiftL, (.|.)) import Data.Maybe (fromJust) +import Data.Word (Word8, Word16, Word32) +import Foreign.Marshal.Array (withArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek) import qualified Network.Socket as Net +import Numeric (readDec, readHex) import System.IO.Unsafe (unsafeDupablePerformIO) +import qualified Text.ParserCombinators.ReadP as RP +import qualified Text.ParserCombinators.ReadPrec as RP (lift) +import Text.Read (Read(readPrec)) import Database.PostgreSQL.Typed.Types data PGInet = PGInet { pgInetAddr :: !Net.HostAddress - , pgInetMask :: !Int + , pgInetMask :: !Word8 } | PGInet6 { pgInetAddr6 :: !Net.HostAddress6 - , pgInetMask :: !Int + , pgInetMask :: !Word8 } sockAddrPGInet :: Net.SockAddr -> Maybe PGInet @@ -31,6 +41,12 @@ sockAddrPGInet (Net.SockAddrInet _ a) = Just $ PGInet a 32 sockAddrPGInet (Net.SockAddrInet6 _ _ a _) = Just $ PGInet6 a 128 sockAddrPGInet _ = Nothing +-- |Convert four bytes to network byte order, using unsafe casting. +-- 'Data.Word.byteSwap32' would be better, but I couldn't find a good way to determine host byte order. +bton32 :: (Word8, Word8, Word8, Word8) -> Word32 +bton32 (b1, b2, b3, b4) = unsafeDupablePerformIO $ + withArray [b1, b2, b3, b4] (peek . castPtr) + instance Show PGInet where -- This is how Network.Socket's Show SockAddr does it: show (PGInet a 32) = unsafeDupablePerformIO $ Net.inet_ntoa a @@ -39,9 +55,77 @@ instance Show PGInet where Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet6 0 0 a 0) show (PGInet6 a m) = show (PGInet6 a 128) ++ '/' : show m +instance Read PGInet where + -- This is even less pleasant, but we only have to deal with representations pg generates + -- Not at all efficient, since in ReadP, but should get us by + readPrec = RP.lift $ r4 RP.+++ r6 where + r4i = do + o1 <- rdec + _ <- RP.char '.' + o2 <- rdec + _ <- RP.char '.' + o3 <- rdec + _ <- RP.char '.' + o4 <- rdec + return (o1, o2, o3, o4) + -- ipv4 + r4 = do + q <- r4i + m <- mask 32 + return $ PGInet (bton32 q) m + + -- trailing ipv4 in ipv6 + r64 = do + (b1, b2, b3, b4) <- r4i + return [jb b1 b2, jb b3 b4] + -- ipv6 pre-double-colon + r6l 0 = return [] + r6l 2 = colon >> r6lc 2 RP.+++ r64 + r6l n = colon >> r6lc n + r6lc n = r6lp n RP.+++ r6b n + r6lp n = r6w (r6l (pred n)) + -- ipv6 double-colon + r6b n = do + colon + r <- r6rp (pred n) RP.<++ return [] + let l = length r + return $ replicate (n - l) 0 ++ r + -- ipv6 post-double-colon + r6r 0 = return [] + r6r n = (colon >> r6rp n) RP.<++ return [] + r6rp n + | n >= 2 = r6rc n RP.+++ r64 + | otherwise = r6rc n + r6rc n = r6w (r6r (pred n)) + r6w = liftM2 (:) rhex + -- ipv6 + r6 = do + [w1, w2, w3, w4, w5, w6, w7, w8] <- r6lp 8 RP.<++ (colon >> r6b 8) + m <- mask 128 + return $ PGInet6 (jw w1 w2, jw w3 w4, jw w5 w6, jw w7 w8) m + + colon = void $ RP.char ':' + mask m = RP.option m $ do + _ <- RP.char '/' + n <- rdec + guard (n <= m) + return n + rdec :: RP.ReadP Word8 + rdec = RP.readS_to_P readDec + rhex :: RP.ReadP Word16 + rhex = RP.readS_to_P readHex + jw :: Word16 -> Word16 -> Word32 + jw x y = fromIntegral x `shiftL` 16 .|. fromIntegral y + jb :: Word8 -> Word8 -> Word16 + jb x y = fromIntegral x `shiftL` 8 .|. fromIntegral y + instance PGType "inet" instance PGType "cidr" instance PGParameter "inet" PGInet where pgEncode _ = BSC.pack . show instance PGParameter "cidr" PGInet where pgEncode _ = BSC.pack . show +instance PGColumn "inet" PGInet where + pgDecode _ = read . BSC.unpack +instance PGColumn "cidr" PGInet where + pgDecode _ = read . BSC.unpack From 3168750c90b67ef0bbe053e3fd362a57cba8701d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 17 Nov 2015 21:39:14 -0500 Subject: [PATCH 175/306] Add more exhaustive QuickCheck-based checks Fix uncovered critical bug in Range.normalize' --- Database/PostgreSQL/Typed/Inet.hs | 3 +- Database/PostgreSQL/Typed/Range.hs | 2 +- postgresql-typed.cabal | 4 +- test/Main.hs | 80 ++++++++++++++++++++++++------ 4 files changed, 69 insertions(+), 20 deletions(-) diff --git a/Database/PostgreSQL/Typed/Inet.hs b/Database/PostgreSQL/Typed/Inet.hs index f9785dd..983fedc 100644 --- a/Database/PostgreSQL/Typed/Inet.hs +++ b/Database/PostgreSQL/Typed/Inet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Inet @@ -35,6 +35,7 @@ data PGInet { pgInetAddr6 :: !Net.HostAddress6 , pgInetMask :: !Word8 } + deriving (Eq) sockAddrPGInet :: Net.SockAddr -> Maybe PGInet sockAddrPGInet (Net.SockAddrInet _ a) = Just $ PGInet a 32 diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index c1a56c7..05ee063 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -181,7 +181,7 @@ normalize' (Range (Lower l) (Upper u)) = normalize $ range l' u' _ -> l u' = case u of Bounded True b -> Bounded False (succ b) - _ -> l + _ -> u -- |Contains range (@>), (<@) :: Ord a => Range a -> Range a -> Bool diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index ff5c41b..583084c 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.2.1 +Version: 0.4.2.2 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING @@ -97,7 +97,7 @@ Library CPP-options: -DUSE_AESON test-suite test - build-depends: base, network, time, bytestring, postgresql-typed + build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck type: exitcode-stdio-1.0 main-is: Main.hs buildable: True diff --git a/test/Main.hs b/test/Main.hs index f940a18..d078e81 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,16 +2,20 @@ -- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where -import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import Data.Int (Int32) import qualified Data.Time as Time import System.Exit (exitSuccess, exitFailure) +import qualified Test.QuickCheck as Q +import Test.QuickCheck.Test (isSuccess) import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types (OID) import Database.PostgreSQL.Typed.Array () import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum +import Database.PostgreSQL.Typed.Inet import Connect @@ -26,6 +30,42 @@ useTPGDatabase db makePGEnum "myenum" "MyEnum" ("MyEnum_" ++) +instance Q.Arbitrary MyEnum where + arbitrary = Q.arbitraryBoundedEnum + +instance Q.Arbitrary Time.Day where + arbitrary = Time.ModifiedJulianDay <$> Q.arbitrary +instance Q.Arbitrary Time.DiffTime where + arbitrary = Time.picosecondsToDiffTime . (1000000 *) <$> Q.arbitrary +instance Q.Arbitrary Time.UTCTime where + arbitrary = Time.UTCTime <$> Q.arbitrary <*> ((Time.picosecondsToDiffTime . (1000000 *)) <$> Q.choose (0,86399999999)) +instance Q.Arbitrary Time.LocalTime where + arbitrary = Time.utcToLocalTime Time.utc <$> Q.arbitrary + +instance Q.Arbitrary a => Q.Arbitrary (Range.Bound a) where + arbitrary = do + u <- Q.arbitrary + if u + then return $ Range.Unbounded + else Range.Bounded <$> Q.arbitrary <*> Q.arbitrary +instance (Ord a, Q.Arbitrary a) => Q.Arbitrary (Range.Range a) where + arbitrary = Range.range <$> Q.arbitrary <*> Q.arbitrary + +instance Q.Arbitrary PGInet where + arbitrary = do + v6 <- Q.arbitrary + if v6 + then PGInet6 <$> Q.arbitrary <*> ((`mod` 129) <$> Q.arbitrary) + else PGInet <$> Q.arbitrary <*> ((`mod` 33) <$> Q.arbitrary) + +newtype Str = Str { strString :: [Char] } deriving (Eq, Show) +strByte :: Str -> BS.ByteString +strByte = BSC.pack . strString +byteStr :: BS.ByteString -> Str +byteStr = Str . BSC.unpack +instance Q.Arbitrary Str where + arbitrary = Str <$> Q.listOf (Q.choose (' ', '~')) + 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] @@ -35,23 +75,31 @@ prepared c t = pgQuery c . [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE preparedApply :: PGConnection -> Int32 -> IO [String] preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] +selectProp :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Str -> [Maybe Str] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp c b i f t z d p s l r e a = Q.ioProperty $ do + [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery c + [pgSQL|$SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + return $ Q.conjoin + [ i Q.=== i' + , b Q.=== b' + , strString s Q.=== s' + , f Q.=== f' + , d Q.=== d' + , t Q.=== t' + , z Q.=== z' + , p Q.=== p' + , l Q.=== map (fmap byteStr) l' + , Range.normalize' r Q.=== r' + , e Q.=== e' + , a Q.=== a' + ] + 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'" :: String - l = [Just "a\\\"b,c", Nothing, Just "null", Just "nullish" :: Maybe ByteString] - 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' + + r <- Q.quickCheckResult $ selectProp c + assert $ isSuccess r ["box"] <- simple c 603 [Just "box"] <- simpleApply c 603 @@ -60,7 +108,7 @@ main = do [Just "line"] <- prepared c 628 "line" ["line"] <- preparedApply c 628 - assert $ [pgSQL|#abc${f}def|] == "abc3.14::realdef" + assert $ [pgSQL|#abc${3.14 :: Float}def|] == "abc3.14::realdef" assert $ pgEnumValues == [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] From 73bdf68c2879b9b3dce25fd9f99bee10388ab707 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 17 Nov 2015 23:02:12 -0500 Subject: [PATCH 176/306] Add missing test module --- postgresql-typed.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 583084c..9452764 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -100,6 +100,7 @@ test-suite test build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck type: exitcode-stdio-1.0 main-is: Main.hs + Other-Modules: Connect buildable: True hs-source-dirs: test Extensions: TemplateHaskell, QuasiQuotes From 88372630f2122e3446c0f08c724dbfcac3eaf4fe Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 18 Nov 2015 11:37:15 -0500 Subject: [PATCH 177/306] Add instance Ord Range Just based on default lexical ordering --- Database/PostgreSQL/Typed/Range.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 05ee063..2fad763 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -79,7 +79,7 @@ data Range a { lower :: LowerBound a , upper :: UpperBound a } - deriving (Eq) + deriving (Eq, Ord) instance Functor Range where fmap _ Empty = Empty From d36b04ec6246fadb0e67f4db5004a12315c9be92 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 15 Jan 2016 14:20:10 -0500 Subject: [PATCH 178/306] Update crypto and postgresql-binary dependencies --- Database/PostgreSQL/Typed/Protocol.hs | 3 +- Database/PostgreSQL/Typed/Types.hs | 75 ++++++++++++++------------- postgresql-typed.cabal | 4 +- 3 files changed, 43 insertions(+), 39 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 9c9b9be..933b10e 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -38,6 +38,7 @@ import Control.Exception (Exception, throwIO, onException) import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef USE_MD5 import qualified Crypto.Hash as Hash +import qualified Data.ByteArray.Encoding as BA #endif import qualified Data.Binary.Get as G import qualified Data.ByteString as BS @@ -220,7 +221,7 @@ pgTypeEnv = connTypeEnv #ifdef USE_MD5 md5 :: BS.ByteString -> BS.ByteString -md5 = Hash.digestToHexByteString . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) +md5 = BA.convertToBase BA.Base16 . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) #endif diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 00da082..c580401 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -85,9 +85,8 @@ 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 +import qualified PostgreSQL.Binary.Decoder as BinD +import qualified PostgreSQL.Binary.Encoder as BinE #endif type PGTextValue = BS.ByteString @@ -222,11 +221,11 @@ parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where | otherwise = Just s #ifdef USE_BINARY -binDec :: PGType t => BinD.D a -> PGTypeName t -> PGBinaryValue -> a -binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . d +binDec :: PGType t => BinD.Decoder a -> PGTypeName t -> PGBinaryValue -> a +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . BinD.run d #define BIN_COL pgBinaryColumn _ _ = True -#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . F +#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . F #define BIN_DEC(F) pgDecodeBinary _ = F #else #define BIN_COL @@ -259,7 +258,7 @@ instance PGType "oid" where BIN_COL instance PGParameter "oid" OID where pgEncode _ = BSC.pack . show pgLiteral = pgEncode - BIN_ENC(BinE.int4 . Right) + BIN_ENC(BinE.int4_word32) instance PGColumn "oid" OID where pgDecode _ = read . BSC.unpack BIN_DEC(binDec BinD.int) @@ -268,7 +267,7 @@ instance PGType "smallint" where BIN_COL instance PGParameter "smallint" Int16 where pgEncode _ = BSC.pack . show pgLiteral = pgEncode - BIN_ENC(BinE.int2. Left) + BIN_ENC(BinE.int2_int16) instance PGColumn "smallint" Int16 where pgDecode _ = read . BSC.unpack BIN_DEC(binDec BinD.int) @@ -277,7 +276,7 @@ instance PGType "integer" where BIN_COL instance PGParameter "integer" Int32 where pgEncode _ = BSC.pack . show pgLiteral = pgEncode - BIN_ENC(BinE.int4 . Left) + BIN_ENC(BinE.int4_int32) instance PGColumn "integer" Int32 where pgDecode _ = read . BSC.unpack BIN_DEC(binDec BinD.int) @@ -286,7 +285,7 @@ instance PGType "bigint" where BIN_COL instance PGParameter "bigint" Int64 where pgEncode _ = BSC.pack . show pgLiteral = pgEncode - BIN_ENC(BinE.int8 . Left) + BIN_ENC(BinE.int8_int64) instance PGColumn "bigint" Int64 where pgDecode _ = read . BSC.unpack BIN_DEC(binDec BinD.int) @@ -322,10 +321,10 @@ class PGType t => PGStringType t instance PGStringType t => PGParameter t String where pgEncode _ = BSU.fromString - BIN_ENC(BinE.text . Left . T.pack) + BIN_ENC(BinE.text_strict . T.pack) instance PGStringType t => PGColumn t String where pgDecode _ = BSU.toString - BIN_DEC((T.unpack .) . binDec BinD.text) + BIN_DEC((T.unpack .) . binDec BinD.text_strict) instance #if __GLASGOW_HASKELL__ >= 710 @@ -333,14 +332,14 @@ instance #endif PGStringType t => PGParameter t BS.ByteString where pgEncode _ = id - BIN_ENC(BinE.text . Left . TE.decodeUtf8) + BIN_ENC(BinE.text_strict . TE.decodeUtf8) instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-} #endif PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id - BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text) + BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text_strict) instance #if __GLASGOW_HASKELL__ >= 710 @@ -348,29 +347,29 @@ instance #endif PGStringType t => PGParameter t BSL.ByteString where pgEncode _ = BSL.toStrict - BIN_ENC(BinE.text . Right . TLE.decodeUtf8) + BIN_ENC(BinE.text_lazy . TLE.decodeUtf8) instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-} #endif PGStringType t => PGColumn t BSL.ByteString where pgDecode _ = BSL.fromStrict - BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text) + BIN_DEC((TLE.encodeUtf8 .) . binDec BinD.text_lazy) #ifdef USE_TEXT instance PGStringType t => PGParameter t T.Text where pgEncode _ = TE.encodeUtf8 - BIN_ENC(BinE.text . Left) + BIN_ENC(BinE.text_strict) instance PGStringType t => PGColumn t T.Text where pgDecode _ = TE.decodeUtf8 - BIN_DEC(binDec BinD.text) + BIN_DEC(binDec BinD.text_strict) instance PGStringType t => PGParameter t TL.Text where pgEncode _ = BSL.toStrict . TLE.encodeUtf8 - BIN_ENC(BinE.text . Right) + BIN_ENC(BinE.text_lazy) instance PGStringType t => PGColumn t TL.Text where pgDecode _ = TL.fromStrict . TE.decodeUtf8 - BIN_DEC((TL.fromStrict .) . binDec BinD.text) + BIN_DEC(binDec BinD.text_lazy) #endif instance PGType "text" where BIN_COL @@ -405,14 +404,14 @@ instance PGParameter "bytea" BSL.ByteString where pgEncode _ = encodeBytea . BSB.lazyByteStringHex pgLiteral t = pgQuoteUnsafe . pgEncode t - BIN_ENC(BinE.bytea . Right) + BIN_ENC(BinE.bytea_lazy) instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} #endif PGColumn "bytea" BSL.ByteString where pgDecode _ = BSL.pack . decodeBytea - BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea) + BIN_DEC(binDec BinD.bytea_lazy) instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} @@ -420,14 +419,14 @@ instance PGParameter "bytea" BS.ByteString where pgEncode _ = encodeBytea . BSB.byteStringHex pgLiteral t = pgQuoteUnsafe . pgEncode t - BIN_ENC(BinE.bytea . Left) + BIN_ENC(BinE.bytea_strict) instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} #endif PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea - BIN_DEC(binDec BinD.bytea) + BIN_DEC(binDec BinD.bytea_strict) readTime :: Time.ParseTime t => String -> String -> t readTime = @@ -454,11 +453,15 @@ binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True binColDatetime _ _ = False #ifdef USE_BINARY -binEncDatetime :: PGParameter t a => (Bool -> a -> PGBinaryValue) -> PGTypeEnv -> PGTypeName t -> a -> PGValue -binEncDatetime f e t = maybe (PGTextValue . pgEncode t) ((PGBinaryValue .) . f) (pgIntegerDatetimes e) +binEncDatetime :: PGParameter t a => BinE.Encoder a -> BinE.Encoder a -> PGTypeEnv -> PGTypeName t -> a -> PGValue +binEncDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } _ = PGBinaryValue . buildPGValue . ff +binEncDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } _ = PGBinaryValue . buildPGValue . fi +binEncDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } t = PGTextValue . pgEncode t -binDecDatetime :: PGColumn t a => (Bool -> BinD.D a) -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a -binDecDatetime f e = binDec $ f $ fromMaybe (error "pgDecodeBinary: unknown integer_datetimes value") $ pgIntegerDatetimes e +binDecDatetime :: PGColumn t a => BinD.Decoder a -> BinD.Decoder a -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a +binDecDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } = binDec ff +binDecDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } = binDec fi +binDecDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } = error "pgDecodeBinary: unknown integer_datetimes value" #endif instance PGType "time without time zone" where @@ -467,12 +470,12 @@ instance PGParameter "time without time zone" Time.TimeOfDay where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY - pgEncodeValue = binEncDatetime BinE.time + pgEncodeValue = binEncDatetime BinE.time_int BinE.time_float #endif instance PGColumn "time without time zone" Time.TimeOfDay where pgDecode _ = readTime "%T%Q" . BSC.unpack #ifdef USE_BINARY - pgDecodeBinary = binDecDatetime BinD.time + pgDecodeBinary = binDecDatetime BinD.time_int BinD.time_float #endif instance PGType "timestamp without time zone" where @@ -481,12 +484,12 @@ instance PGParameter "timestamp without time zone" Time.LocalTime where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY - pgEncodeValue = binEncDatetime BinE.timestamp + pgEncodeValue = binEncDatetime BinE.timestamp_int BinE.timestamp_float #endif instance PGColumn "timestamp without time zone" Time.LocalTime where pgDecode _ = readTime "%F %T%Q" . BSC.unpack #ifdef USE_BINARY - pgDecodeBinary = binDecDatetime BinD.timestamp + pgDecodeBinary = binDecDatetime BinD.timestamp_int BinD.timestamp_float #endif -- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. @@ -505,12 +508,12 @@ instance PGParameter "timestamp with time zone" Time.UTCTime where pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" -- pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY - pgEncodeValue = binEncDatetime BinE.timestamptz + pgEncodeValue = binEncDatetime BinE.timestamptz_int BinE.timestamptz_float #endif instance PGColumn "timestamp with time zone" Time.UTCTime where pgDecode _ = readTime "%F %T%Q%z" . fixTZ . BSC.unpack #ifdef USE_BINARY - pgDecodeBinary = binDecDatetime BinD.timestamptz + pgDecodeBinary = binDecDatetime BinD.timestamptz_int BinD.timestamptz_float #endif instance PGType "interval" where @@ -519,7 +522,7 @@ instance PGParameter "interval" Time.DiffTime where pgEncode _ = BSC.pack . show pgLiteral t = pgQuoteUnsafe . pgEncode t #ifdef USE_BINARY - pgEncodeValue = binEncDatetime BinE.interval + pgEncodeValue = binEncDatetime BinE.interval_int BinE.interval_float #endif -- |Representation of DiffTime as interval. -- PostgreSQL stores months and days separately in intervals, but DiffTime does not. @@ -542,7 +545,7 @@ instance PGColumn "interval" Time.DiffTime where day = 86400 month = 2629746 #ifdef USE_BINARY - pgDecodeBinary = binDecDatetime BinD.interval + pgDecodeBinary = binDecDatetime BinD.interval_int BinD.interval_float #endif instance PGType "numeric" where BIN_COL diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 9452764..1269c8f 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -77,10 +77,10 @@ Library Database.PostgreSQL.Typed.Internal GHC-Options: -Wall if flag(md5) - Build-Depends: cryptohash >= 0.5 + Build-Depends: cryptonite >= 0.5, memory >= 0.5 CPP-options: -DUSE_MD5 if flag(binary) - Build-Depends: postgresql-binary >= 0.5.0, text >= 1, uuid >= 1.3, scientific >= 0.3 + Build-Depends: postgresql-binary >= 0.7, text >= 1, uuid >= 1.3, scientific >= 0.3 CPP-options: -DUSE_BINARY -DUSE_TEXT -DUSE_UUID -DUSE_SCIENTIFIC else if flag(text) From 5db81f453f7b5b6e275b04f6f2bfd77d0b56267b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 15 Jan 2016 14:47:58 -0500 Subject: [PATCH 179/306] Bump version to 0.4.3 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 1269c8f..01d27dd 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.2.2 +Version: 0.4.3 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From b93cdb9512ae4b8315e0ee3ff1bf13bbe8be4f2a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 4 Apr 2016 11:27:09 -0400 Subject: [PATCH 180/306] Add a bit more to the docs around unsafeModifyQuery --- Database/PostgreSQL/Typed/Dynamic.hs | 3 ++- Database/PostgreSQL/Typed/Query.hs | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 1f5adac..b125e63 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -45,6 +45,7 @@ class PGType t => PGRep t a | a -> t where pgEncodeRep :: a -> PGValue default pgEncodeRep :: PGParameter t a => a -> PGValue pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x + -- |Produce a literal value for interpolation in a SQL statement. Using 'pgSafeLiteral' is usually safer as it includes type cast. pgLiteralRep :: a -> BS.ByteString default pgLiteralRep :: PGParameter t a => a -> BS.ByteString pgLiteralRep x = pgLiteral (pgTypeOf x) x @@ -62,7 +63,7 @@ class PGType t => PGRep t a | a -> t where pgLiteralString :: PGRep t a => a -> String pgLiteralString = BSC.unpack . pgLiteralRep --- |Produce a safely type-cast literal value for interpolation in a SQL statement. +-- |Produce a safely type-cast literal value for interpolation in a SQL statement, e.g., "'123'::integer". pgSafeLiteral :: PGRep t a => a -> BS.ByteString pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index ea7fa8b..0b94c0b 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -47,6 +47,10 @@ class PGQuery q a | q -> a where -- |Change the raw SQL query stored within this query. -- This is unsafe because the query has already been type-checked, so any change must not change the number or type of results or placeholders (so adding additional static WHERE or ORDER BY clauses is generally safe). -- This is useful in cases where you need to construct some part of the query dynamically, but still want to infer the result types. + -- If you want to add dynamic values to the query, it's best to use 'Database.PostgreSQL.Typed.Dynamic.pgSafeLiteral'. + -- For example: + -- + -- > [pgSQL|SELECT a FROM t|] `unsafeModifyQuery` (<> (" WHERE a = " <> pgSafeLiteral x)) unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q class PGQuery q PGValues => PGRawQuery q From f691d83fc4ed64d4f587c0bf25a33d2bfee555e1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 5 Apr 2016 09:22:15 -0400 Subject: [PATCH 181/306] Allow non-NULL lists as input on ghc 7.10 Should allow more convenient array input, hopefully without causing any ambiguity. --- Database/PostgreSQL/Typed/Array.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 65b84da..5608cc1 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -39,10 +39,20 @@ class (PGType ta, PGType t) => PGArrayType ta t | ta -> t, t -> ta where pgArrayDelim :: PGTypeName ta -> Char pgArrayDelim _ = ',' -instance (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where pgEncode ta l = buildPGValue $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where el Nothing = BSB.string7 "null" el (Just e) = pgDQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e +#if __GLASGOW_HASKELL__ >= 710 +-- |Allow entirely non-null arrays as parameter inputs only. +-- (Only supported on ghc >= 7.10 due to instance overlap.) +instance {-# OVERLAPPABLE #-} (PGArrayType ta t, PGParameter t a) => PGParameter ta [a] where + pgEncode ta = pgEncode ta . map Just +#endif instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where pgDecode ta a = either (error . ("pgDecode array (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly pa a where pa = P.char '{' *> P.sepBy (P.skipSpace *> el <* P.skipSpace) (P.char (pgArrayDelim ta)) <* P.char '}' <* P.endOfInput From 64929c85f50f75b6ef280e134b2e9672c2ac7f1b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 5 Apr 2016 09:42:38 -0400 Subject: [PATCH 182/306] Add pgDBParams, and use it to set TimeZone UTC for test Fixes timezone conversion test failures. --- Database/PostgreSQL/Typed/Protocol.hs | 13 ++++++++----- test/Connect.hs | 1 + 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 933b10e..83df270 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -88,13 +88,14 @@ data PGDatabase = PGDatabase , pgDBPort :: PortID -- ^ The port, likely either @PortNumber 5432@ or @UnixSocket \"\/tmp\/.s.PGSQL.5432\"@ , pgDBName :: BS.ByteString -- ^ The name of the database , pgDBUser, pgDBPass :: BS.ByteString + , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) } 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 + PGDatabase h1 s1 n1 u1 p1 l1 _ _ == PGDatabase h2 s2 n2 u2 p2 l2 _ _ = + h1 == h2 && s1 == s2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 -- |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. @@ -208,7 +209,7 @@ defaultLogMessage = hPutStrLn stderr . displayMessage -- |A database connection with sane defaults: -- localhost:5432:postgres defaultPGDatabase :: PGDatabase -defaultPGDatabase = PGDatabase "localhost" (PortNumber 5432) (BSC.pack "postgres") (BSC.pack "postgres") BS.empty False defaultLogMessage +defaultPGDatabase = PGDatabase "localhost" (PortNumber 5432) (BSC.pack "postgres") (BSC.pack "postgres") BS.empty [] False defaultLogMessage connDebug :: PGConnection -> Bool connDebug = pgDBDebug . connDatabase @@ -420,7 +421,7 @@ pgConnect db = do , connInput = input , connTransaction = tr } - pgSend c $ StartupMessage + pgSend c $ StartupMessage $ [ (BSC.pack "user", pgDBUser db) , (BSC.pack "database", pgDBName db) , (BSC.pack "client_encoding", BSC.pack "UTF8") @@ -428,7 +429,7 @@ pgConnect db = do , (BSC.pack "bytea_output", BSC.pack "hex") , (BSC.pack "DateStyle", BSC.pack "ISO, YMD") , (BSC.pack "IntervalStyle", BSC.pack "iso_8601") - ] + ] ++ pgDBParams db pgFlush c conn c where @@ -569,6 +570,7 @@ pgSimpleQuery h sql = do got c r = return (rowsAffected c, r) -- |A simple query which may contain multiple queries (separated by semi-colons) whose results are all ignored. +-- This function can also be used for \"SET\" parameter queries if necessary, but it's safer better to use 'pgDBParams'. pgSimpleQueries_ :: PGConnection -> BSL.ByteString -- ^ SQL string -> IO () pgSimpleQueries_ h sql = do @@ -581,6 +583,7 @@ pgSimpleQueries_ h sql = do res (CommandComplete _) = go res EmptyQueryResponse = go res (DataRow _) = go + res (ParameterStatus _ _) = go res (ReadyForQuery _) = return () res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m diff --git a/test/Connect.hs b/test/Connect.hs index 2c824b2..213867a 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -10,5 +10,6 @@ db = defaultPGDatabase , pgDBName = "templatepg" , pgDBUser = "templatepg" , pgDBDebug = True + , pgDBParams = [("TimeZone", "UTC")] } From 9d870b146f35df50e1faf42800271d0483c64564 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 11 Apr 2016 16:11:02 -0400 Subject: [PATCH 183/306] Improve documentation about '$' and '$('. --- Database/PostgreSQL/Typed/Query.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 0b94c0b..9ccc27d 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -257,8 +257,8 @@ qqTop err sql = do -- -- [@?@] To disable nullability inference, treating all result values as nullable, thus returning 'Maybe' values regardless of inferred nullability. This makes unexpected NULL errors impossible. -- [@!@] To disable nullability inference, treating all result values as /not/ nullable, thus only returning 'Maybe' where requested. This is makes unexpected NULL errors more likely. --- [@$@] To create a 'PGPreparedQuery' rather than a 'PGSimpleQuery', by default inferring parameter types. --- [@$(type,...)@] To specify specific types to a prepared query (see for details). +-- [@$@] To create a 'PGPreparedQuery' (using placeholder parameters) rather than the default 'PGSimpleQuery' (using literal substitution). +-- [@$(type,...)@] To specify specific types for a prepared query (see for details), rather than inferring parameter types by default. -- [@#@] Only do literal @${}@ substitution using 'pgSubstituteLiterals' and return a string, not a query. -- -- 'pgSQL' can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results). From 2b4cd2ba41b062058665d168c9ddf4dfe663f39f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 21 Apr 2016 13:05:15 -0400 Subject: [PATCH 184/306] Bump version to 0.4.4 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 01d27dd..573e2ce 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.3 +Version: 0.4.4 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From d88e3f1b48b53118abdc80419dcebb575112c18b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 27 Apr 2016 11:38:15 -0400 Subject: [PATCH 185/306] Make pgSubstituteLiterals evaluate to a lazy bytestring For better compatibility with pgSimpleQuery and maybe efficiency. This is a breaking change, but hopefully not a very drastic one. --- Database/PostgreSQL/Typed/Dynamic.hs | 7 ++++--- Database/PostgreSQL/Typed/Enum.hs | 3 ++- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index b125e63..91cee6e 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -19,6 +19,7 @@ import Control.Applicative ((<$>)) #endif import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL import Data.Monoid ((<>)) import Data.Int #ifdef USE_SCIENTIFIC @@ -105,11 +106,11 @@ instance PGRep "numeric" Scientific instance PGRep "uuid" UUID.UUID #endif --- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@. --- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries. +-- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@, producing a lazy 'BSL.ByteString'. +-- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries, for example when using 'Database.PostgreSQL.Typed.Protocol.pgSimpleQuery' or 'Database.PostgreSQL.Typed.Protocol.pgSimpleQueries_'. -- Unlike most other TH functions, this does not require any database connection. pgSubstituteLiterals :: String -> TH.ExpQ -pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BS.concat) . TH.ListE <$> ssl (sqlSplitExprs sql) where +pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BSL.fromChunks) . TH.ListE <$> ssl (sqlSplitExprs sql) where ssl :: SQLSplit String 'True -> TH.Q [TH.Exp] ssl (SQLLiteral s l) = (TH.VarE 'fromString `TH.AppE` stringE s :) <$> ssp l ssl SQLSplitEnd = return [] diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 5c27a9e..a8ae44e 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -57,7 +57,8 @@ makePGEnum name typs valnf = do valn = map (\[PGTextValue v] -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals dv <- TH.newName "x" return - [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] + [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) + [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] , TH.InstanceD [] (TH.ConT ''Show `TH.AppT` typt) [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []] (TH.NormalB $ TH.LitE v) []) valn From c39e616ab9134c0d6866e7aaf2d03a4a012a578f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 2 Aug 2016 16:48:17 -0400 Subject: [PATCH 186/306] Allow raw decoding of anything to PGValue --- Database/PostgreSQL/Typed/Types.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index c580401..db99e2e 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -163,6 +163,10 @@ instance PGColumn t a => PGColumn t (Maybe a) where pgDecodeValue _ _ PGNullValue = Nothing pgDecodeValue e t v = Just $ pgDecodeValue e t v +instance PGType t => PGColumn t PGValue where + pgDecode _ = PGTextValue + pgDecodeBinary _ _ = PGBinaryValue + pgDecodeValue _ _ = id -- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> PGValue From 37744360536506d3baf3e676879029d34c019439 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 4 Aug 2016 20:17:11 -0400 Subject: [PATCH 187/306] Update SQL parser to match postgresql Eliminate escaping -- should no longer be necessary. Underlying support for '?' is provided for future HDBC compatibility. --- Database/PostgreSQL/Typed/Dynamic.hs | 14 +-- Database/PostgreSQL/Typed/Internal.hs | 51 ----------- Database/PostgreSQL/Typed/Query.hs | 36 +++----- Database/PostgreSQL/Typed/SQLToken.hs | 126 ++++++++++++++++++++++++++ postgresql-typed.cabal | 5 +- test/Main.hs | 19 +++- 6 files changed, 163 insertions(+), 88 deletions(-) delete mode 100644 Database/PostgreSQL/Typed/Internal.hs create mode 100644 Database/PostgreSQL/Typed/SQLToken.hs diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 91cee6e..f045fa2 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -36,8 +36,8 @@ import qualified Data.UUID as UUID import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH -import Database.PostgreSQL.Typed.Internal import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.SQLToken -- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling. class PGType t => PGRep t a | a -> t where @@ -110,12 +110,8 @@ instance PGRep "uuid" UUID.UUID -- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries, for example when using 'Database.PostgreSQL.Typed.Protocol.pgSimpleQuery' or 'Database.PostgreSQL.Typed.Protocol.pgSimpleQueries_'. -- Unlike most other TH functions, this does not require any database connection. pgSubstituteLiterals :: String -> TH.ExpQ -pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BSL.fromChunks) . TH.ListE <$> ssl (sqlSplitExprs sql) where - ssl :: SQLSplit String 'True -> TH.Q [TH.Exp] - ssl (SQLLiteral s l) = (TH.VarE 'fromString `TH.AppE` stringE s :) <$> ssp l - ssl SQLSplitEnd = return [] - ssp :: SQLSplit String 'False -> TH.Q [TH.Exp] - ssp (SQLPlaceholder e l) = do +pgSubstituteLiterals sql = TH.AppE (TH.VarE 'BSL.fromChunks) . TH.ListE <$> mapM sst (sqlTokens sql) where + sst (SQLExpr e) = do v <- either (fail . (++) ("Failed to parse expression {" ++ e ++ "}: ")) return $ parseExp e - (TH.VarE 'pgSafeLiteral `TH.AppE` v :) <$> ssl l - ssp SQLSplitEnd = return [] + return $ TH.VarE 'pgSafeLiteral `TH.AppE` v + sst t = return $ TH.VarE 'fromString `TH.AppE` TH.LitE (TH.StringL $ show t) diff --git a/Database/PostgreSQL/Typed/Internal.hs b/Database/PostgreSQL/Typed/Internal.hs deleted file mode 100644 index a94aa40..0000000 --- a/Database/PostgreSQL/Typed/Internal.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE PatternSynonyms, PatternGuards, TemplateHaskell, GADTs, KindSignatures, DataKinds #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Database.PostgreSQL.Typed.Internal - ( stringE - , pattern StringE - , SQLSplit(..) - , sqlSplitExprs - , sqlSplitParams - ) where - -import Data.Char (isDigit) -import Data.String (IsString(..)) -import qualified Language.Haskell.TH as TH -import Numeric (readDec) - --- |@'TH.LitE' . 'TH.stringL'@ -stringE :: String -> TH.Exp -stringE = TH.LitE . TH.StringL - --- |Pattern match for 'stringE'. -pattern StringE s = TH.LitE (TH.StringL s) - -instance IsString TH.Exp where - fromString = stringE - --- |Parsed representation of a SQL statement containing placeholders. -data SQLSplit a (literal :: Bool) where - SQLLiteral :: String -> SQLSplit a 'False -> SQLSplit a 'True - SQLPlaceholder :: a -> SQLSplit a 'True -> SQLSplit a 'False - SQLSplitEnd :: SQLSplit a any - -sqlCons :: Char -> SQLSplit a 'True -> SQLSplit a 'True -sqlCons c (SQLLiteral s l) = SQLLiteral (c : s) l -sqlCons c SQLSplitEnd = SQLLiteral [c] SQLSplitEnd - --- |Parse a SQL stamement with ${string} placeholders into a 'SQLSplit'. -sqlSplitExprs :: String -> SQLSplit String 'True -sqlSplitExprs ('$':'$':'{':s) = sqlCons '$' $ sqlCons '{' $ sqlSplitExprs s -sqlSplitExprs ('$':'{':s) - | (e, '}':r) <- break (\c -> c == '{' || c == '}') s = SQLLiteral "" $ SQLPlaceholder e $ sqlSplitExprs r - | otherwise = error $ "Error parsing SQL: could not find end of expression: ${" ++ s -sqlSplitExprs (c:s) = sqlCons c $ sqlSplitExprs s -sqlSplitExprs [] = SQLSplitEnd - --- |Parse a SQL stamement with $numeric placeholders into a 'SQLSplit'. -sqlSplitParams :: String -> SQLSplit Int 'True -sqlSplitParams ('$':'$':d:s) | isDigit d = sqlCons '$' $ sqlCons d $ sqlSplitParams s -sqlSplitParams ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = SQLLiteral "" $ SQLPlaceholder n $ sqlSplitParams r -sqlSplitParams (c:s) = sqlCons c $ sqlSplitParams s -sqlSplitParams [] = SQLSplitEnd - diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 9ccc27d..833c533 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -35,11 +35,11 @@ import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Database.PostgreSQL.Typed.Internal import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.SQLToken class PGQuery q a | q -> a where -- |Execute a query and return the number of rows affected (or -1 if not known) and a list of results. @@ -126,30 +126,24 @@ pgLazyQuery c (QueryParser q p) count = 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 @}@. +-- This does its best to understand SQL syntax, so placeholders are only interpreted in places postgres would understand them (i.e., not in quoted strings). Since this is not valid SQL otherwise, there is never reason to escape a literal @${@. +-- You can use @$N@ placeholders in the query otherwise to refer to the N-th index placeholder expression. sqlPlaceholders :: String -> (String, [String]) -sqlPlaceholders = ssl 1 . sqlSplitExprs where - ssl :: Int -> SQLSplit String 'True -> (String, [String]) - ssl n (SQLLiteral s l) = first (s ++) $ ssp n l - ssl _ SQLSplitEnd = ("", []) - ssp :: Int -> SQLSplit String 'False -> (String, [String]) - ssp n (SQLPlaceholder e l) = (('$':show n) ++) *** (e :) $ ssl (succ n) l - ssp _ SQLSplitEnd = ("", []) +sqlPlaceholders = sst (1 :: Int) . sqlTokens where + sst n (SQLExpr e : l) = (('$':show n) ++) *** (e :) $ sst (succ n) l + sst n (t : l) = first (show t ++) $ sst n l + sst _ [] = ("", []) -- |Given a SQL statement with placeholders of the form @$N@ and a list of TH 'ByteString' expressions, return a new 'ByteString' expression that substitutes the expressions for the placeholders. --- 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 = TH.AppE (TH.VarE 'BS.concat) $ TH.ListE $ ssl $ sqlSplitParams sql where +sqlSubstitute sql exprl = TH.AppE (TH.VarE 'BS.concat) $ TH.ListE $ map sst $ sqlTokens sql where bnds = (1, length exprl) exprs = listArray bnds exprl expr n | inRange bnds n = exprs ! n - | otherwise = error $ "SQL placeholder '$" ++ show n ++ "' out of range (not recognized by PostgreSQL); literal occurrences may need to be escaped with '$$'" - ssl (SQLLiteral s l) = TH.VarE 'fromString `TH.AppE` stringE s : ssp l - ssl SQLSplitEnd = [] - ssp (SQLPlaceholder n l) = expr n : ssl l - ssp SQLSplitEnd = [] + | otherwise = error $ "SQL placeholder '$" ++ show n ++ "' out of range (not recognized by PostgreSQL)" + sst (SQLParam n) = expr n + sst t = TH.VarE 'fromString `TH.AppE` TH.LitE (TH.StringL $ show t) splitCommas :: String -> [String] splitCommas = spl where @@ -180,7 +174,7 @@ makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do (pt, rt) <- TH.runIO $ tpgDescribe (fromString sqlp) (fromMaybe [] prep) (isNothing nulls) - when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL; literal occurrences of '${' may need to be escaped with '$${'" + when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL" e <- TH.newName "_tenv" (vars, vals) <- mapAndUnzipM (\t -> do @@ -201,7 +195,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do (TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals) (\p -> TH.ConE 'PreparedQuery - `TH.AppE` (TH.VarE 'fromString `TH.AppE` stringE sqlp) + `TH.AppE` (TH.VarE 'fromString `TH.AppE` TH.LitE (TH.StringL sqlp)) `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID . snd) $ zip p pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE @@ -250,8 +244,8 @@ qqTop err sql = do -- 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 @$${@. +-- Ideally, this mimics postgres' SQL parsing, so that placeholders and expressions will only be expanded when they are in valid positions (i.e., not inside quoted strings). +-- Since @${@ is not valid SQL otherwise, there should be no need to escape it. -- -- The statement may start with one of more special flags affecting the interpretation: -- diff --git a/Database/PostgreSQL/Typed/SQLToken.hs b/Database/PostgreSQL/Typed/SQLToken.hs new file mode 100644 index 0000000..db1f40e --- /dev/null +++ b/Database/PostgreSQL/Typed/SQLToken.hs @@ -0,0 +1,126 @@ +-- | +-- Module: Database.PostgreSQL.Typed.SQLToken +-- Copyright: 2016 Dylan Simon +-- +-- Parsing of SQL statements to safely identify placeholders. +-- Supports both dollar-placeholders and question marks for HDBC. +{-# LANGUAGE PatternGuards #-} +module Database.PostgreSQL.Typed.SQLToken + ( SQLToken(..) + , sqlTokens + ) where + +import Control.Arrow (first) +import Data.Char (isDigit, isAsciiUpper, isAsciiLower) +import Data.List (stripPrefix) + +-- |A parsed SQL token. +data SQLToken + = SQLToken String -- ^Raw (non-markup) SQL string + | SQLParam Int -- ^A \"$N\" parameter placeholder (this is the only non-string-preserving token: \"$012\" becomes \"$12\") + | SQLExpr String -- ^A \"${expr}\" expression placeholder + | SQLQMark Bool -- ^A possibly-escaped question-mark: False for \"?\" or True for \"\\?\" + +-- |Produces the original SQL string +instance Show SQLToken where + showsPrec _ (SQLToken s) = showString s + showsPrec _ (SQLParam p) = showChar '$' . shows p + showsPrec _ (SQLExpr e) = showString "${" . showString e . showChar '}' + showsPrec _ (SQLQMark False) = showChar '?' + showsPrec _ (SQLQMark True) = showString "\\?" + showList = flip $ foldr shows + +type PH = String -> [SQLToken] + +infixr 4 ++:, +: + +(++:) :: String -> [SQLToken] -> [SQLToken] +p ++: (SQLToken q : l) = SQLToken (p ++ q) : l +p ++: l = SQLToken p : l + +(+:) :: Char -> [SQLToken] -> [SQLToken] +p +: (SQLToken q : l) = SQLToken (p : q) : l +p +: l = SQLToken [p] : l + +x :: PH +x ('-':'-':s) = "--" ++: comment s +x ('e':'\'':s) = "e'" ++: xe s +x ('E':'\'':s) = "E'" ++: xe s +x ('\'':s) = '\'' +: xq s +x ('$':'{':s) = expr s +x ('$':'$':s) = "$$" ++: xdolq "" s +x ('$':c:s) + | dolqStart c + , (t,'$':r) <- span dolqCont s + = '$' : c : t ++: '$' +: xdolq (c:t) r + | isDigit c + , (i,r) <- span isDigit s + = SQLParam (read $ c:i) : x r +x ('"':s) = '"' +: xd s +x ('/':'*':s) = "/*" ++: xc 1 s +x (c:s) + | identStart c + , (i,r) <- span identCont s + = c : i ++: x r +x ('\\':'?':s) = SQLQMark True : x s +x ('?':s) = SQLQMark False : x s +x (c:s) = c +: x s +x [] = [] + +xthru :: (Char -> Bool) -> PH +xthru f s = case break f s of + (p, c:r) -> p ++ [c] ++: x r + (p, []) -> [SQLToken p] + +comment :: PH +comment = xthru (\n -> '\n' == n || '\r' == n) + +xe :: PH +xe ('\\':c:s) = '\\' +: c +: xe s +xe ('\'':s) = '\'' +: x s +xe (c:s) = c +: xe s +xe [] = [] + +xq :: PH +xq = xthru ('\'' ==) +-- no need to handle xqdouble + +xd :: PH +xd = xthru ('\"' ==) +-- no need to handle xddouble + +identStart, identCont, dolqStart, dolqCont :: Char -> Bool +identStart c = isAsciiUpper c || isAsciiLower c || c >= '\128' && c <= '\255' || c == '_' +dolqStart = identStart +dolqCont c = dolqStart c || isDigit c +identCont c = dolqCont c || c == '$' + +xdolq :: String -> PH +xdolq t = dolq where + dolq ('$':s) + | Just r <- stripPrefix t' s = '$':t' ++: x r + dolq (c:s) = c +: dolq s + dolq [] = [] + t' = t ++ "$" + +xc :: Int -> PH +xc 0 s = x s +xc n ('/':'*':s) = "/*" ++: xc (succ n) s +xc n ('*':'/':s) = "*/" ++: xc (pred n) s +xc n (c:s) = c +: xc n s +xc _ [] = [] + +expr :: PH +expr = pr . ex (0 :: Int) where + pr (e, Nothing) = [SQLToken ("${" ++ e)] + pr (e, Just r) = SQLExpr e : r + ex 0 ('}':s) = ("", Just $ x s) + ex n ('}':s) = first ('}':) $ ex (pred n) s + ex n ('{':s) = first ('{':) $ ex (succ n) s + ex n (c:s) = first (c:) $ ex n s + ex _ [] = ("", Nothing) + +-- |Parse a SQL string into a series of tokens. +-- The 'showList' implementation for 'SQLToken' inverts this sequence back to a SQL string. +sqlTokens :: String -> [SQLToken] +sqlTokens = x diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 573e2ce..10218e0 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -16,7 +16,7 @@ Description: Automatically type-check SQL statements at compile time. 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, GHC == 7.10.2 +Tested-With: GHC == 7.10.3 Build-Type: Simple source-repository head @@ -73,8 +73,9 @@ Library Database.PostgreSQL.Typed.Inet Database.PostgreSQL.Typed.Dynamic Database.PostgreSQL.Typed.TemplatePG + Database.PostgreSQL.Typed.SQLToken Other-Modules: - Database.PostgreSQL.Typed.Internal + Paths_postgresql_typed GHC-Options: -Wall if flag(md5) Build-Depends: cryptonite >= 0.5, memory >= 0.5 diff --git a/test/Main.hs b/test/Main.hs index d078e81..28fec4c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ module Main (main) where import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC +import Data.Char (isDigit) import Data.Int (Int32) import qualified Data.Time as Time import System.Exit (exitSuccess, exitFailure) @@ -16,6 +17,7 @@ import Database.PostgreSQL.Typed.Array () import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum import Database.PostgreSQL.Typed.Inet +import Database.PostgreSQL.Typed.SQLToken import Connect @@ -94,11 +96,22 @@ selectProp c b i f t z d p s l r e a = Q.ioProperty $ do , a Q.=== a' ] +tokenProp :: String -> Q.Property +tokenProp s = + not (has0 s) Q.==> s Q.=== show (sqlTokens s) where + has0 ('$':'0':c:_) | isDigit c = True + has0 (_:r) = has0 r + has0 [] = False + main :: IO () main = do c <- pgConnect db - r <- Q.quickCheckResult $ selectProp c + r <- Q.quickCheckResult + $ selectProp c + Q..&&. tokenProp + Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" + Q..&&. pgEnumValues Q.=== [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] assert $ isSuccess r ["box"] <- simple c 603 @@ -108,9 +121,5 @@ main = do [Just "line"] <- prepared c 628 "line" ["line"] <- preparedApply c 628 - assert $ [pgSQL|#abc${3.14 :: Float}def|] == "abc3.14::realdef" - - assert $ pgEnumValues == [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] - pgDisconnect c exitSuccess From 01328ba653d2be293c038097a038f5fd0f329160 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Aug 2016 00:13:36 -0400 Subject: [PATCH 188/306] Add HDBC support, many protocol updates, tests --- Database/PostgreSQL/Typed/Dynamic.hs | 1 + Database/PostgreSQL/Typed/HDBC.hs | 341 ++++++++++++++++++++++++++ Database/PostgreSQL/Typed/Protocol.hs | 246 ++++++++++++++----- Database/PostgreSQL/Typed/SQLToken.hs | 5 + Database/PostgreSQL/Typed/TH.hs | 19 +- Database/PostgreSQL/Typed/Types.hs | 58 +++-- postgresql-typed.cabal | 26 +- test/Main.hs | 23 ++ test/hdbc/SpecificDB.hs | 27 ++ test/hdbc/TestMisc.hs | 181 ++++++++++++++ test/hdbc/TestSbasics.hs | 170 +++++++++++++ test/hdbc/TestTime.hs | 97 ++++++++ test/hdbc/TestUtils.hs | 29 +++ test/hdbc/Testbasics.hs | 168 +++++++++++++ test/hdbc/Tests.hs | 19 ++ test/hdbc/runtests.hs | 16 ++ 16 files changed, 1339 insertions(+), 87 deletions(-) create mode 100644 Database/PostgreSQL/Typed/HDBC.hs create mode 100644 test/hdbc/SpecificDB.hs create mode 100644 test/hdbc/TestMisc.hs create mode 100644 test/hdbc/TestSbasics.hs create mode 100644 test/hdbc/TestTime.hs create mode 100644 test/hdbc/TestUtils.hs create mode 100644 test/hdbc/Testbasics.hs create mode 100644 test/hdbc/Tests.hs create mode 100644 test/hdbc/runtests.hs diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index f045fa2..9533b28 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -95,6 +95,7 @@ instance PGRep "text" T.Text #endif instance PGRep "date" Time.Day instance PGRep "time without time zone" Time.TimeOfDay +instance PGRep "time with time zone" (Time.TimeOfDay, Time.TimeZone) instance PGRep "timestamp without time zone" Time.LocalTime instance PGRep "timestamp with time zone" Time.UTCTime instance PGRep "interval" Time.DiffTime diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs new file mode 100644 index 0000000..43a7624 --- /dev/null +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -0,0 +1,341 @@ +-- | +-- Module: Database.PostgreSQL.Typed.HDBC +-- Copyright: 2016 Dylan Simon +-- +-- Use postgresql-typed as a backend for HDBC. +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Database.PostgreSQL.Typed.HDBC + ( Connection, pgConnection + , connect + , reloadTypes + ) where + +import Control.Arrow ((&&&)) +import Control.Concurrent.MVar (MVar, newMVar, readMVar, withMVar) +import Control.Exception (handle, throwIO) +import Control.Monad (void, guard) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef') +import Data.Int (Int16) +import qualified Data.IntMap.Lazy as IntMap +import Data.List (uncons) +import qualified Data.Map.Lazy as Map +import Data.Maybe (fromMaybe, isNothing) +import Data.Time.Clock (DiffTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.LocalTime (zonedTimeToUTC) +import Data.Word (Word32) +import qualified Database.HDBC.Types as HDBC +import qualified Database.HDBC.ColTypes as HDBC +import System.Mem.Weak (addFinalizer) +import Text.Read (readMaybe) + +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.SQLToken +import Paths_postgresql_typed (version) + +-- |A wrapped 'PGConnection'. +-- This differs from a bare 'PGConnection' in two ways: +-- +-- 1) It always has exactly one active transaction (with 'pgBegin') +-- 2) It automatically disconnects on GC +-- +data Connection = Connection + { pgConnection :: MVar PGConnection -- ^Access the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. + , pgServerVer :: String + , pgTypes :: IntMap.IntMap SqlType + } + +sqlError :: IO a -> IO a +sqlError = handle $ \(PGError m) -> + let f c = BSC.unpack $ Map.findWithDefault BSC.empty c m + fC = f 'C' + fD = f 'D' in + throwIO HDBC.SqlError + { HDBC.seState = fC + , HDBC.seNativeError = if null fC then -1 else fromMaybe 0 $ readMaybe (f 'P') + , HDBC.seErrorMsg = f 'S' ++ ": " ++ f 'M' ++ if null fD then fD else '\n':fD + } + +withPG :: Connection -> (PGConnection -> IO a) -> IO a +withPG c = sqlError . withMVar (pgConnection c) + +connect_ :: PGDatabase -> IO PGConnection +connect_ d = sqlError $ do + pg <- pgConnect d + addFinalizer pg (pgDisconnectOnce pg) + pgBegin pg + return pg + +-- |Connect to a database for HDBC use (equivalent to 'pgConnect' and 'pgBegin'). +connect :: PGDatabase -> IO Connection +connect d = do + pg <- connect_ d + pgv <- newMVar pg + reloadTypes Connection + { pgConnection = pgv + , pgServerVer = maybe "" BSC.unpack $ pgServerVersion pg + , pgTypes = mempty + } + +-- |Reload the table of all types from the database. +-- This may be needed if you make structural changes to the database. +reloadTypes :: Connection -> IO Connection +reloadTypes c = withPG c $ \pg -> do + t <- pgLoadTypes pg + return c{ pgTypes = IntMap.map (sqlType $ pgTypeEnv pg) t } + +sqls :: String -> BSLC.ByteString +sqls = BSLC.pack + +placeholders :: Int -> [SQLToken] -> [SQLToken] +placeholders n (SQLQMark False : l) = SQLParam n : placeholders (succ n) l +placeholders n (SQLQMark True : l) = SQLQMark False : placeholders n l +placeholders n (t : l) = t : placeholders n l +placeholders _ [] = [] + +data ColDesc = ColDesc + { colDescName :: String + , colDesc :: HDBC.SqlColDesc + , colDescDecode :: PGValue -> HDBC.SqlValue + } + +data Cursor = Cursor + { cursorDesc :: [ColDesc] + , cursorRow :: [PGValues] + , cursorActive :: Bool + , _cursorStatement :: HDBC.Statement -- keep a handle to prevent GC + } + +noCursor :: HDBC.Statement -> Cursor +noCursor = Cursor [] [] False + +-- |Number of rows to retrieve (and cache) with each call to fetchRow. +-- Ideally this should be configurable, but it's not clear how. +fetchSize :: Word32 +fetchSize = 1 + +getType :: Connection -> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc +getType c pg nul PGColDescription{..} = ColDesc + { colDescName = BSC.unpack colName + , colDesc = HDBC.SqlColDesc + { HDBC.colType = sqlTypeId t + , HDBC.colSize = fromIntegral colModifier <$ guard (colModifier >= 0) + , HDBC.colOctetLength = fromIntegral colSize <$ guard (colSize >= 0) + , HDBC.colDecDigits = Nothing + , HDBC.colNullable = nul + } + , colDescDecode = sqlTypeDecode t + } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show colType) (fromIntegral colType) (pgTypes c) + +instance HDBC.IConnection Connection where + disconnect c = withPG c + pgDisconnectOnce + commit c = withPG c $ \pg -> do + pgCommit pg + pgBegin pg + rollback c = withPG c $ \pg -> do + pgRollback pg + pgBegin pg + runRaw c q = withPG c $ \pg -> + pgSimpleQueries_ pg $ sqls q + run c q v = withPG c $ \pg -> do + let q' = sqls $ show $ placeholders 1 $ sqlTokens q + v' = map encode v + fromMaybe 0 <$> pgRun pg q' [] v' + prepare c q = do + let q' = sqls $ show $ placeholders 1 $ sqlTokens q + n <- withPG c $ \pg -> pgPrepare pg q' [] + cr <- newIORef $ error "Cursor" + let + execute v = withPG c $ \pg -> do + d <- pgBind pg n (map encode v) + (r, e) <- pgFetch pg n fetchSize + modifyIORef' cr $ \p -> p + { cursorDesc = map (getType c pg Nothing) d + , cursorRow = r + , cursorActive = isNothing e + } + return $ fromMaybe 0 e + stmt = HDBC.Statement + { HDBC.execute = execute + , HDBC.executeRaw = void $ execute [] + , HDBC.executeMany = mapM_ execute + , HDBC.finish = withPG c $ \pg -> do + writeIORef cr $ noCursor stmt + pgClose pg n + , HDBC.fetchRow = withPG c $ \pg -> do + p <- readIORef cr + fmap (zipWith colDescDecode (cursorDesc p)) <$> case cursorRow p of + [] | True || cursorActive p -> do + (rl, e) <- pgFetch pg n fetchSize + let rl' = uncons rl + writeIORef cr p + { cursorRow = maybe [] snd rl' + , cursorActive = isNothing e + } + return $ fst <$> rl' + | otherwise -> + return Nothing + (r:l) -> do + writeIORef cr p{ cursorRow = l } + return $ Just r + , HDBC.getColumnNames = + map colDescName . cursorDesc <$> readIORef cr + , HDBC.originalQuery = q + , HDBC.describeResult = + map (colDescName &&& colDesc) . cursorDesc <$> readIORef cr + } + writeIORef cr $ noCursor stmt + addFinalizer stmt $ withPG c $ \pg -> pgClose pg n + return stmt + clone c = do + c' <- connect_ . pgConnectionDatabase =<< readMVar (pgConnection c) + cv <- newMVar c' + return c{ pgConnection = cv } + hdbcDriverName _ = "postgresql-typed" + hdbcClientVer _ = show version + proxiedClientName = HDBC.hdbcDriverName + proxiedClientVer = HDBC.hdbcClientVer + dbServerVer = pgServerVer + dbTransactionSupport _ = True + getTables c = withPG c $ \pg -> + map (pgDecodeRep . head) . snd <$> pgSimpleQuery pg (BSLC.fromChunks + [ "SELECT relname " + , "FROM pg_class " + , "JOIN pg_namespace " + , "ON relnamespace = pg_namespace.oid " + , "WHERE nspname = ANY (current_schemas(false)) " + , "AND relkind IN ('r','v','m','f')" + ]) + describeTable c t = withPG c $ \pg -> do + let makecol ~[attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull] = + colDescName &&& colDesc $ getType c pg (Just $ not $ pgDecodeRep attnotnull) PGColDescription + { colName = pgDecodeRep attname + , colTable = pgDecodeRep attrelid + , colNumber = pgDecodeRep attnum + , colType = pgDecodeRep atttypid + , colSize = pgDecodeRep attlen + , colModifier = pgDecodeRep atttypmod + , colBinary = False + } + map makecol . snd <$> pgSimpleQuery pg (BSLC.fromChunks + [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull " + , "FROM pg_attribute " + , "JOIN pg_class " + , "ON attrelid = pg_class.oid " + , "JOIN pg_namespace " + , "ON relnamespace = pg_namespace.oid " + , "WHERE nspname = ANY (current_schemas(false)) " + , "AND relkind IN ('r','v','m','f') " + , "AND relname = ", pgLiteralRep t + , " AND attnum > 0 AND NOT attisdropped " + , "ORDER BY attnum" + ]) + +encodeRep :: (PGParameter t a, PGRep t a) => a -> PGValue +encodeRep x = PGTextValue $ pgEncode (pgTypeOf x) x + +encode :: HDBC.SqlValue -> PGValue +encode (HDBC.SqlString x) = encodeRep x +encode (HDBC.SqlByteString x) = encodeRep x +encode (HDBC.SqlWord32 x) = encodeRep x +encode (HDBC.SqlWord64 x) = encodeRep (fromIntegral x :: Rational) +encode (HDBC.SqlInt32 x) = encodeRep x +encode (HDBC.SqlInt64 x) = encodeRep x +encode (HDBC.SqlInteger x) = encodeRep (fromInteger x :: Rational) +encode (HDBC.SqlChar x) = encodeRep x +encode (HDBC.SqlBool x) = encodeRep x +encode (HDBC.SqlDouble x) = encodeRep x +encode (HDBC.SqlRational x) = encodeRep x +encode (HDBC.SqlLocalDate x) = encodeRep x +encode (HDBC.SqlLocalTimeOfDay x) = encodeRep x +encode (HDBC.SqlZonedLocalTimeOfDay t z) = encodeRep (t, z) +encode (HDBC.SqlLocalTime x) = encodeRep x +encode (HDBC.SqlZonedTime x) = encodeRep (zonedTimeToUTC x) +encode (HDBC.SqlUTCTime x) = encodeRep x +encode (HDBC.SqlDiffTime x) = encodeRep (realToFrac x :: DiffTime) +encode (HDBC.SqlPOSIXTime x) = encodeRep (realToFrac x :: Rational) -- (posixSecondsToUTCTime x) +encode (HDBC.SqlEpochTime x) = encodeRep (posixSecondsToUTCTime (fromInteger x)) +encode (HDBC.SqlTimeDiff x) = encodeRep (fromIntegral x :: DiffTime) +encode HDBC.SqlNull = PGNullValue + +data SqlType = SqlType + { sqlTypeId :: HDBC.SqlTypeId + , sqlTypeDecode :: PGValue -> HDBC.SqlValue + } + +sqlType :: PGTypeEnv -> String -> SqlType +sqlType e t = SqlType + { sqlTypeId = typeId t + , sqlTypeDecode = decode t e + } + +typeId :: String -> HDBC.SqlTypeId +typeId "boolean" = HDBC.SqlBitT +typeId "bytea" = HDBC.SqlVarBinaryT +typeId "\"char\"" = HDBC.SqlCharT +typeId "name" = HDBC.SqlVarCharT +typeId "bigint" = HDBC.SqlBigIntT +typeId "smallint" = HDBC.SqlSmallIntT +typeId "integer" = HDBC.SqlIntegerT +typeId "text" = HDBC.SqlLongVarCharT +typeId "oid" = HDBC.SqlIntegerT +typeId "real" = HDBC.SqlFloatT +typeId "double precision" = HDBC.SqlDoubleT +typeId "abstime" = HDBC.SqlUTCDateTimeT +typeId "reltime" = HDBC.SqlIntervalT HDBC.SqlIntervalSecondT +typeId "tinterval" = HDBC.SqlIntervalT HDBC.SqlIntervalDayToSecondT +typeId "bpchar" = HDBC.SqlVarCharT +typeId "character varying" = HDBC.SqlVarCharT +typeId "date" = HDBC.SqlDateT +typeId "time without time zone" = HDBC.SqlTimeT +typeId "timestamp without time zone" = HDBC.SqlTimestampT +typeId "timestamp with time zone" = HDBC.SqlTimestampWithZoneT -- XXX really SQLUTCDateTimeT +typeId "interval" = HDBC.SqlIntervalT HDBC.SqlIntervalDayToSecondT +typeId "time with time zone" = HDBC.SqlTimeWithZoneT +typeId "numeric" = HDBC.SqlDecimalT +typeId "uuid" = HDBC.SqlGUIDT +typeId t = HDBC.SqlUnknownT t + +decodeRep :: PGColumn t a => PGTypeName t -> PGTypeEnv -> (a -> HDBC.SqlValue) -> PGValue -> HDBC.SqlValue +decodeRep t e f (PGBinaryValue v) = f $ pgDecodeBinary e t v +decodeRep t _ f (PGTextValue v) = f $ pgDecode t v +decodeRep _ _ _ PGNullValue = HDBC.SqlNull + +#define DECODE(T) \ + decode T e = decodeRep (PGTypeProxy :: PGTypeName T) e + +decode :: String -> PGTypeEnv -> PGValue -> HDBC.SqlValue +DECODE("boolean") HDBC.SqlBool +DECODE("\"char\"") HDBC.SqlChar +DECODE("name") HDBC.SqlString +DECODE("bigint") HDBC.SqlInt64 +DECODE("smallint") (HDBC.SqlInt32 . fromIntegral :: Int16 -> HDBC.SqlValue) +DECODE("integer") HDBC.SqlInt32 +DECODE("text") HDBC.SqlString +DECODE("oid") HDBC.SqlWord32 +DECODE("real") HDBC.SqlDouble +DECODE("double precision") HDBC.SqlDouble +DECODE("bpchar") HDBC.SqlString +DECODE("character varying") HDBC.SqlString +DECODE("date") HDBC.SqlLocalDate +DECODE("time without time zone") HDBC.SqlLocalTimeOfDay +DECODE("time with time zone") (uncurry HDBC.SqlZonedLocalTimeOfDay) +DECODE("timestamp without time zone") HDBC.SqlLocalTime +DECODE("timestamp with time zone") HDBC.SqlUTCTime +DECODE("interval") (HDBC.SqlDiffTime . realToFrac :: DiffTime -> HDBC.SqlValue) +DECODE("numeric") HDBC.SqlRational +decode _ _ = decodeRaw where + decodeRaw (PGBinaryValue v) = HDBC.SqlByteString v + decodeRaw (PGTextValue v) = HDBC.SqlByteString v + decodeRaw PGNullValue = HDBC.SqlNull diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 83df270..7a39076 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -12,7 +12,9 @@ module Database.PostgreSQL.Typed.Protocol ( , PGConnection , PGError(..) , pgErrorCode + , pgConnectionDatabase , pgTypeEnv + , pgServerVersion , pgConnect , pgDisconnect , pgReconnect @@ -28,12 +30,22 @@ module Database.PostgreSQL.Typed.Protocol ( , pgCommit , pgRollback , pgTransaction + -- * HDBC support + , pgDisconnectOnce + , pgRun + , PGPreparedStatement + , pgPrepare + , pgClose + , PGColDescription(..) + , PGRowDescription + , pgBind + , pgFetch ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) #endif -import Control.Arrow ((&&&), second) +import Control.Arrow ((&&&), first, second) import Control.Exception (Exception, throwIO, onException) import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef USE_MD5 @@ -57,6 +69,7 @@ import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif +import Data.Tuple (swap) import Data.Typeable (Typeable) #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) @@ -71,8 +84,7 @@ import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic data PGState - = StateUnknown -- no Sync - | StateCommand -- was Sync, sent command + = StateUnsync -- no Sync | StatePending -- Sync sent -- ReadyForQuery received: | StateIdle @@ -97,6 +109,12 @@ instance Eq PGDatabase where PGDatabase h1 s1 n1 u1 p1 l1 _ _ == PGDatabase h2 s2 n2 u2 p2 l2 _ _ = h1 == h2 && s1 == s2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 +newtype PGPreparedStatement = PGPreparedStatement Integer + deriving (Eq, Show) + +preparedStatementName :: PGPreparedStatement -> BS.ByteString +preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n + -- |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 @@ -106,20 +124,23 @@ data PGConnection = PGConnection , connKey :: !Word32 -- unused , connParameters :: Map.Map BS.ByteString BS.ByteString , connTypeEnv :: PGTypeEnv - , connPreparedStatements :: IORef (Integer, Map.Map (BS.ByteString, [OID]) Integer) + , connPreparedStatementCount :: IORef Integer + , connPreparedStatementMap :: IORef (Map.Map (BS.ByteString, [OID]) PGPreparedStatement) , connState :: IORef PGState , connInput :: IORef (G.Decoder PGBackendMessage) , connTransaction :: IORef Word } -data ColDescription = ColDescription +data PGColDescription = PGColDescription { colName :: BS.ByteString , colTable :: !OID , colNumber :: !Int16 , colType :: !OID + , colSize :: !Int16 , colModifier :: !Int32 , colBinary :: !Bool } deriving (Show) +type PGRowDescription = [PGColDescription] type MessageFields = Map.Map Char BS.ByteString @@ -128,12 +149,14 @@ type MessageFields = Map.Map Char BS.ByteString data PGFrontendMessage = StartupMessage [(BS.ByteString, BS.ByteString)] -- only sent first | CancelRequest !Word32 !Word32 -- sent first on separate connection - | Bind { statementName :: BS.ByteString, bindParameters :: PGValues, binaryColumns :: [Bool] } - | Close { statementName :: BS.ByteString } + | Bind { portalName :: BS.ByteString, statementName :: BS.ByteString, bindParameters :: PGValues, binaryColumns :: [Bool] } + | CloseStatement { statementName :: BS.ByteString } + | ClosePortal { portalName :: BS.ByteString } -- |Describe a SQL query/statement. The SQL string can contain -- parameters ($1, $2, etc.). - | Describe { statementName :: BS.ByteString } - | Execute !Word32 + | DescribeStatement { statementName :: BS.ByteString } + | DescribePortal { portalName :: BS.ByteString } + | Execute { portalName :: BS.ByteString, executeRows :: !Word32 } | Flush -- |Parse SQL Destination (prepared statement) | Parse { statementName :: BS.ByteString, queryString :: BSL.ByteString, parseTypes :: [OID] } @@ -177,7 +200,7 @@ data PGBackendMessage -- |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] + | RowDescription PGRowDescription deriving (Show) -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of @@ -192,8 +215,11 @@ 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 = BSC.unpack $ Map.findWithDefault BS.empty c m +displayMessage m = "PG" ++ f 'S' ++ (if null fC then ": " else " [" ++ fC ++ "]: ") ++ f 'M' ++ (if null fD then fD else '\n' : fD) + where + fC = f 'C' + fD = f 'D' + f c = BSC.unpack $ Map.findWithDefault BS.empty c m makeMessage :: BS.ByteString -> BS.ByteString -> MessageFields makeMessage m d = Map.fromAscList [('D', d), ('M', m)] @@ -217,9 +243,18 @@ connDebug = pgDBDebug . connDatabase connLogMessage :: PGConnection -> MessageFields -> IO () connLogMessage = pgDBLogMessage . connDatabase +-- |The database information for this connection. +pgConnectionDatabase :: PGConnection -> PGDatabase +pgConnectionDatabase = connDatabase + +-- |The type environment for this connection. pgTypeEnv :: PGConnection -> PGTypeEnv pgTypeEnv = connTypeEnv +-- |Retrieve the \"server_version\" parameter from the connection, if any. +pgServerVersion :: PGConnection -> Maybe BS.ByteString +pgServerVersion PGConnection{ connParameters = p } = Map.lookup (BSC.pack "server_version") p + #ifdef USE_MD5 md5 :: BS.ByteString -> BS.ByteString md5 = BA.convertToBase BA.Base16 . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) @@ -241,8 +276,9 @@ messageBody (StartupMessage kv) = (Nothing, B.word32BE 0x30000 <> Fold.foldMap (\(k, v) -> byteStringNul k <> byteStringNul v) kv <> nul) messageBody (CancelRequest pid key) = (Nothing, B.word32BE 80877102 <> B.word32BE pid <> B.word32BE key) -messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = (Just 'B', - nul <> byteStringNul n +messageBody Bind{ portalName = d, statementName = n, bindParameters = p, binaryColumns = bc } = (Just 'B', + byteStringNul d + <> byteStringNul n <> (if any fmt p then B.word16BE (fromIntegral $ length p) <> Fold.foldMap (B.word16BE . fromIntegral . fromEnum . fmt) p else B.word16BE 0) @@ -256,12 +292,16 @@ messageBody Bind{ statementName = n, bindParameters = p, binaryColumns = bc } = 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', +messageBody CloseStatement{ statementName = n } = (Just 'C', B.char7 'S' <> byteStringNul n) -messageBody Describe{ statementName = n } = (Just 'D', +messageBody ClosePortal{ portalName = n } = (Just 'C', + B.char7 'P' <> byteStringNul n) +messageBody DescribeStatement{ statementName = n } = (Just 'D', B.char7 'S' <> byteStringNul n) -messageBody (Execute r) = (Just 'E', - nul <> B.word32BE r) +messageBody DescribePortal{ portalName = n } = (Just 'D', + B.char7 'P' <> byteStringNul n) +messageBody Execute{ portalName = n, executeRows = r } = (Just 'E', + byteStringNul n <> B.word32BE r) messageBody Flush = (Just 'H', mempty) messageBody Parse{ statementName = n, queryString = s, parseTypes = t } = (Just 'P', byteStringNul n <> lazyByteStringNul s @@ -285,8 +325,7 @@ pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do state _ StateClosed = StateClosed state Sync _ = StatePending state Terminate _ = StateClosed - state _ StateUnknown = StateUnknown - state _ _ = StateCommand + state _ _ = StateUnsync pgFlush :: PGConnection -> IO () pgFlush = hFlush . connHandle @@ -318,14 +357,15 @@ getMessageBody 'T' = do oid <- G.getWord32be -- table OID col <- G.getWord16be -- column number typ' <- G.getWord32be -- type - _ <- G.getWord16be -- type size + siz <- G.getWord16be -- type size tmod <- G.getWord32be -- type modifier fmt <- G.getWord16be -- format code - return $ ColDescription + return $ PGColDescription { colName = name , colTable = oid , colNumber = fromIntegral col , colType = typ' + , colSize = fromIntegral siz , colModifier = fromIntegral tmod , colBinary = toEnum (fromIntegral fmt) } @@ -382,10 +422,8 @@ pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = else go $ r (Just b) got :: G.Decoder PGBackendMessage -> PGBackendMessage -> PGState -> IO (Maybe PGBackendMessage) got d (NoticeResponse m) _ = connLogMessage c m >> go d - got d (ReadyForQuery _) StateCommand = go d got d m@(ReadyForQuery s) _ = Just m <$ state s d - got d m@(ErrorResponse _) _ = Just m <$ state StateUnknown d - got d m StateCommand = Just m <$ state StateUnknown d + got d m@(ErrorResponse _) _ = Just m <$ state StateUnsync d got d m _ = Just m <$ next d -- |Receive the next message from PostgreSQL (low-level). Note that this will @@ -403,8 +441,9 @@ pgReceive c = do -- |Connect to a PostgreSQL server. pgConnect :: PGDatabase -> IO PGConnection pgConnect db = do - state <- newIORef StateUnknown - prep <- newIORef (0, Map.empty) + state <- newIORef StateUnsync + prepc <- newIORef 0 + prepm <- newIORef Map.empty input <- newIORef getMessage tr <- newIORef 0 h <- connectTo (pgDBHost db) (pgDBPort db) @@ -415,7 +454,8 @@ pgConnect db = do , connPid = 0 , connKey = 0 , connParameters = Map.empty - , connPreparedStatements = prep + , connPreparedStatementCount = prepc + , connPreparedStatementMap = prepm , connState = state , connTypeEnv = unknownPGTypeEnv , connInput = input @@ -461,6 +501,14 @@ pgDisconnect c@PGConnection{ connHandle = h } = do pgSend c Terminate hClose h +-- |Disconnect cleanly from the PostgreSQL server, but only if it's still connected. +pgDisconnectOnce :: PGConnection -- ^ a handle from 'pgConnect' + -> IO () +pgDisconnectOnce c@PGConnection{ connState = cs } = do + s <- readIORef cs + unless (s == StateClosed) $ + pgDisconnect c + -- |Possibly re-open a connection to a different database, either reusing the connection if the given database is already connected or closing it and opening a new one. -- Regardless, the input connection must not be used afterwards. pgReconnect :: PGConnection -> PGDatabase -> IO PGConnection @@ -478,7 +526,7 @@ pgSync c@PGConnection{ connState = sr } = do case s of StateClosed -> fail "pgSync: operation on closed connection" StatePending -> wait True - StateUnknown -> wait False + StateUnsync -> wait False _ -> return () where wait s = do @@ -496,6 +544,11 @@ pgSync c@PGConnection{ connState = sr } = do connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) $ BSC.pack "Each statement should only contain a single query" wait s +rowDescription :: PGBackendMessage -> PGRowDescription +rowDescription (RowDescription d) = d +rowDescription NoData = [] +rowDescription m = error $ "describe: unexpected response: " ++ show m + -- |Describe a SQL statement/query. A statement description consists of 0 or -- more parameter descriptions (a PostgreSQL type) and zero or more result -- field descriptions (for queries) (consist of the name of the field, the @@ -506,20 +559,15 @@ pgDescribe :: PGConnection -> BSL.ByteString -- ^ SQL string -> IO ([OID], [(BS.ByteString, OID, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators. pgDescribe h sql types nulls = do pgSync h - pgSend h $ Parse{ queryString = sql, statementName = BS.empty, parseTypes = types } - pgSend h $ Describe BS.empty - pgSend h Flush + pgSend h Parse{ queryString = sql, statementName = BS.empty, parseTypes = types } + pgSend h DescribeStatement{ statementName = BS.empty } 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 + (,) ps <$> (mapM desc . rowDescription =<< pgReceive h) where - desc (ColDescription{ colName = name, colTable = tab, colNumber = col, colType = typ }) = do + desc (PGColDescription{ 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. @@ -536,12 +584,12 @@ pgDescribe h sql types nulls = do _ -> fail $ "Failed to determine nullability of column #" ++ show col | otherwise = return True -rowsAffected :: BS.ByteString -> Int +rowsAffected :: (Integral i, Read i) => BS.ByteString -> i rowsAffected = ra . BSC.words where ra [] = -1 ra l = fromMaybe (-1) $ readMaybe $ BSC.unpack $ last l --- Do we need to use the ColDescription here always, or are the request formats okay? +-- Do we need to use the PGColDescription here always, or are the request formats okay? fixBinary :: [Bool] -> PGValues -> PGValues fixBinary (False:b) (PGBinaryValue x:r) = PGTextValue x : fixBinary b r fixBinary (True :b) (PGTextValue x:r) = PGBinaryValue x : fixBinary b r @@ -588,22 +636,23 @@ pgSimpleQueries_ h sql = do res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m pgPreparedBind :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> IO (IO ()) -pgPreparedBind c@PGConnection{ connPreparedStatements = psr } sql types bind bc = do +pgPreparedBind c 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 = BSC.pack $ show n + m <- readIORef (connPreparedStatementMap c) + (p, n) <- maybe + (atomicModifyIORef' (connPreparedStatementCount c) (succ &&& (,) False . PGPreparedStatement)) + (return . (,) True) $ Map.lookup key m unless p $ - pgSend c $ Parse{ queryString = BSL.fromStrict sql, statementName = sn, parseTypes = types } - pgSend c $ Bind{ statementName = sn, bindParameters = bind, binaryColumns = bc } + pgSend c Parse{ queryString = BSL.fromStrict sql, statementName = preparedStatementName n, parseTypes = types } + pgSend c Bind{ portalName = BS.empty, statementName = preparedStatementName n, bindParameters = bind, binaryColumns = bc } let go = pgReceive c >>= start start ParseComplete = do - modifyIORef psr $ \(i, m) -> - (i, Map.insert key n m) + modifyIORef (connPreparedStatementMap c) $ + Map.insert key n go start BindComplete = return () - start m = fail $ "pgPrepared: unexpected response: " ++ show m + start r = fail $ "pgPrepared: unexpected response: " ++ show r return go where key = (sql, types) @@ -616,8 +665,7 @@ pgPreparedQuery :: PGConnection -> BS.ByteString -- ^ SQL statement with placeho -> IO (Int, [PGValues]) pgPreparedQuery c sql types bind bc = do start <- pgPreparedBind c sql types bind bc - pgSend c $ Execute 0 - pgSend c Flush + pgSend c Execute{ portalName = BS.empty, executeRows = 0 } pgSend c Sync pgFlush c start @@ -641,8 +689,8 @@ pgPreparedLazyQuery c sql types bind bc count = do go id where execute = do - pgSend c $ Execute count - pgSend c $ Flush + pgSend c Execute{ portalName = BS.empty, executeRows = count } + pgSend c Flush pgFlush c go r = pgReceive c >>= row r row r (DataRow fs) = go (r . (fixBinary bc fs :)) @@ -653,15 +701,10 @@ pgPreparedLazyQuery c sql types bind bc count = do -- |Close a previously prepared query (if necessary). pgCloseStatement :: PGConnection -> BS.ByteString -> [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 = BSC.pack $ show n } - pgFlush c - CloseComplete <- pgReceive c - return () +pgCloseStatement c sql types = do + mn <- atomicModifyIORef (connPreparedStatementMap c) $ + swap . Map.updateLookupWithKey (\_ _ -> Nothing) (sql, types) + Fold.mapM_ (pgClose c) mn -- |Begin a new transaction. If there is already a transaction in progress (created with 'pgBegin' or 'pgTransaction') instead creates a savepoint. pgBegin :: PGConnection -> IO () @@ -694,3 +737,82 @@ pgTransaction c f = do pgCommit c return r) (pgRollback c) + +-- |Prepare, bind, execute, and close a single (unnamed) query, and return the number of rows affected, or Nothing if there are (ignored) result rows. +pgRun :: PGConnection -> BSL.ByteString -> [OID] -> PGValues -> IO (Maybe Integer) +pgRun c sql types bind = do + pgSync c + pgSend c Parse{ queryString = sql, statementName = BS.empty, parseTypes = types } + pgSend c Bind{ portalName = BS.empty, statementName = BS.empty, bindParameters = bind, binaryColumns = [] } + pgSend c Execute{ portalName = BS.empty, executeRows = 1 } -- 0 does not mean none + pgSend c Sync + pgFlush c + go where + go = pgReceive c >>= res + res ParseComplete = go + res BindComplete = go + res (DataRow _) = go + res PortalSuspended = return Nothing + res (CommandComplete d) = return (Just $ rowsAffected d) + res EmptyQueryResponse = return (Just 0) + res m = fail $ "pgRun: unexpected response: " ++ show m + +-- |Prepare a single query and return its handle. +pgPrepare :: PGConnection -> BSL.ByteString -> [OID] -> IO PGPreparedStatement +pgPrepare c sql types = do + n <- atomicModifyIORef' (connPreparedStatementCount c) (succ &&& PGPreparedStatement) + pgSync c + pgSend c Parse{ queryString = sql, statementName = preparedStatementName n, parseTypes = types } + pgSend c Sync + pgFlush c + ParseComplete <- pgReceive c + return n + +-- |Close a previously prepared query. +pgClose :: PGConnection -> PGPreparedStatement -> IO () +pgClose c n = do + pgSync c + pgSend c ClosePortal{ portalName = preparedStatementName n } + pgSend c CloseStatement{ statementName = preparedStatementName n } + pgSend c Sync + pgFlush c + CloseComplete <- pgReceive c + CloseComplete <- pgReceive c + return () + +-- |Bind a prepared statement, and return the row description. +-- After 'pgBind', you must either call 'pgFetch' until it completes (returns @(_, 'Just' _)@) or 'pgFinish' before calling 'pgBind' again on the same prepared statement. +pgBind :: PGConnection -> PGPreparedStatement -> PGValues -> IO PGRowDescription +pgBind c n bind = do + pgSync c + pgSend c ClosePortal{ portalName = sn } + pgSend c Bind{ portalName = sn, statementName = sn, bindParameters = bind, binaryColumns = [] } + pgSend c DescribePortal{ portalName = sn } + pgSend c Sync + pgFlush c + CloseComplete <- pgReceive c + BindComplete <- pgReceive c + rowDescription <$> pgReceive c + where sn = preparedStatementName n + +-- |Fetch a single row from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete. +pgFetch :: PGConnection -> PGPreparedStatement -> Word32 -- ^Maximum number of rows to return, or 0 for all + -> IO ([PGValues], Maybe Integer) +pgFetch c n count = do + pgSync c + pgSend c Execute{ portalName = preparedStatementName n, executeRows = count } + pgSend c Sync + pgFlush c + go where + go = pgReceive c >>= res + res (DataRow v) = first (v :) <$> go + res PortalSuspended = return ([], Nothing) + res (CommandComplete d) = do + pgSync c + pgSend c ClosePortal{ portalName = preparedStatementName n } + pgSend c Sync + pgFlush c + CloseComplete <- pgReceive c + return ([], Just $ rowsAffected d) + res EmptyQueryResponse = return ([], Just 0) + res m = fail $ "pgFetch: unexpected response: " ++ show m diff --git a/Database/PostgreSQL/Typed/SQLToken.hs b/Database/PostgreSQL/Typed/SQLToken.hs index db1f40e..bf6f99c 100644 --- a/Database/PostgreSQL/Typed/SQLToken.hs +++ b/Database/PostgreSQL/Typed/SQLToken.hs @@ -13,6 +13,7 @@ module Database.PostgreSQL.Typed.SQLToken import Control.Arrow (first) import Data.Char (isDigit, isAsciiUpper, isAsciiLower) import Data.List (stripPrefix) +import Data.String (IsString(..)) -- |A parsed SQL token. data SQLToken @@ -20,6 +21,7 @@ data SQLToken | SQLParam Int -- ^A \"$N\" parameter placeholder (this is the only non-string-preserving token: \"$012\" becomes \"$12\") | SQLExpr String -- ^A \"${expr}\" expression placeholder | SQLQMark Bool -- ^A possibly-escaped question-mark: False for \"?\" or True for \"\\?\" + deriving (Eq) -- |Produces the original SQL string instance Show SQLToken where @@ -30,6 +32,9 @@ instance Show SQLToken where showsPrec _ (SQLQMark True) = showString "\\?" showList = flip $ foldr shows +instance IsString SQLToken where + fromString = SQLToken + type PH = String -> [SQLToken] infixr 4 ++:, +: diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 76370b9..5ca8212 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -16,6 +16,9 @@ module Database.PostgreSQL.Typed.TH , tpgTypeEncoder , tpgTypeDecoder , tpgTypeBinary + -- * HDBC support + , PGTypes + , pgLoadTypes ) where #if !MIN_VERSION_base(4,8,0) @@ -74,13 +77,21 @@ tpgState = unsafePerformIO $ do data TPGState = TPGState { tpgConnection :: PGConnection - , tpgTypes :: IntMap.IntMap TPGType -- keyed on fromIntegral OID + , tpgTypes :: PGTypes } +-- |Map keyed on fromIntegral OID. +type PGTypes = IntMap.IntMap TPGType + +-- |Load a map of types from the database. +pgLoadTypes :: PGConnection -> IO PGTypes +pgLoadTypes c = + IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . + snd <$> pgSimpleQuery c (BSLC.pack "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") + tpgLoadTypes :: TPGState -> IO TPGState tpgLoadTypes tpg = do - t <- IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . - snd <$> pgSimpleQuery (tpgConnection tpg) (BSLC.pack "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") + t <- pgLoadTypes (tpgConnection tpg) return tpg{ tpgTypes = t } tpgInit :: PGConnection -> IO TPGState @@ -123,7 +134,7 @@ reloadTPGTypes = TH.runIO $ [] <$ modifyMVar_ tpgState (\(d, c) -> (,) d <$> Tv. -- Error if not found. tpgType :: TPGState -> OID -> TPGType tpgType TPGState{ tpgTypes = types } t = - IntMap.findWithDefault (error $ "Unknown PostgreSQL type: " ++ show t) (fromIntegral t) types + IntMap.findWithDefault (error $ "Unknown PostgreSQL type: " ++ show t ++ "\nYour postgresql-typed application may need to be rebuilt.") (fromIntegral t) types -- |Lookup a type OID by type name. -- This is less common and thus less efficient than going the other way. diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index db99e2e..503ef86 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -40,6 +40,7 @@ module Database.PostgreSQL.Typed.Types #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$), (<*), (*>)) #endif +import Control.Arrow ((&&&)) #ifdef USE_AESON import qualified Data.Aeson as JSON #endif @@ -163,11 +164,6 @@ instance PGColumn t a => PGColumn t (Maybe a) where pgDecodeValue _ _ PGNullValue = Nothing pgDecodeValue e t v = Just $ pgDecodeValue e t v -instance PGType t => PGColumn t PGValue where - pgDecode _ = PGTextValue - pgDecodeBinary _ _ = PGBinaryValue - pgDecodeValue _ _ = id - -- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> PGValue pgEncodeParameter = pgEncodeValue @@ -237,6 +233,17 @@ binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ #define BIN_DEC(F) #endif +instance PGType "any" +instance PGType t => PGColumn t PGValue where + pgDecode _ = PGTextValue + pgDecodeBinary _ _ = PGBinaryValue + pgDecodeValue _ _ = id +instance PGParameter "any" PGValue where + pgEncode _ (PGTextValue v) = v + pgEncode _ PGNullValue = error "pgEncode any: NULL" + pgEncode _ (PGBinaryValue _) = error "pgEncode any: binary" + pgEncodeValue _ _ = id + instance PGType "void" instance PGColumn "void" () where pgDecode _ _ = () @@ -302,12 +309,19 @@ instance PGParameter "real" Float where instance PGColumn "real" Float where pgDecode _ = read . BSC.unpack BIN_DEC(binDec BinD.float4) +instance PGColumn "real" Double where + pgDecode _ = read . BSC.unpack + BIN_DEC((realToFrac .) . binDec BinD.float4) instance PGType "double precision" where BIN_COL instance PGParameter "double precision" Double where pgEncode _ = BSC.pack . show pgLiteral = pgEncode BIN_ENC(BinE.float8) +instance PGParameter "double precision" Float where + pgEncode _ = BSC.pack . show + pgLiteral = pgEncode + BIN_ENC(BinE.float8 . realToFrac) instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack BIN_DEC(binDec BinD.float8) @@ -468,6 +482,16 @@ binDecDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } = binDec fi binDecDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } = error "pgDecodeBinary: unknown integer_datetimes value" #endif +-- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. +-- readTime can successfully parse both formats, but PostgreSQL needs the colon. +fixTZ :: String -> String +fixTZ "" = "" +fixTZ ['+',h1,h2] | isDigit h1 && isDigit h2 = ['+',h1,h2,':','0','0'] +fixTZ ['-',h1,h2] | isDigit h1 && isDigit h2 = ['-',h1,h2,':','0','0'] +fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['+',h1,h2,':',m1,m2] +fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2] +fixTZ (c:s) = c:fixTZ s + instance PGType "time without time zone" where pgBinaryColumn = binColDatetime instance PGParameter "time without time zone" Time.TimeOfDay where @@ -482,6 +506,20 @@ instance PGColumn "time without time zone" Time.TimeOfDay where pgDecodeBinary = binDecDatetime BinD.time_int BinD.time_float #endif +instance PGType "time with time zone" where + pgBinaryColumn = binColDatetime +instance PGParameter "time with time zone" (Time.TimeOfDay, Time.TimeZone) where + pgEncode _ (t, z) = BSC.pack $ Time.formatTime defaultTimeLocale "%T%Q" t ++ fixTZ (Time.formatTime defaultTimeLocale "%z" z) + pgLiteral t = pgQuoteUnsafe . pgEncode t +#ifdef USE_BINARY + pgEncodeValue = binEncDatetime BinE.timetz_int BinE.timetz_float +#endif +instance PGColumn "time with time zone" (Time.TimeOfDay, Time.TimeZone) where + pgDecode _ = (Time.localTimeOfDay . Time.zonedTimeToLocalTime &&& Time.zonedTimeZone) . readTime "%T%Q%z" . fixTZ . BSC.unpack +#ifdef USE_BINARY + pgDecodeBinary = binDecDatetime BinD.timetz_int BinD.timetz_float +#endif + instance PGType "timestamp without time zone" where pgBinaryColumn = binColDatetime instance PGParameter "timestamp without time zone" Time.LocalTime where @@ -496,16 +534,6 @@ instance PGColumn "timestamp without time zone" Time.LocalTime where pgDecodeBinary = binDecDatetime BinD.timestamp_int BinD.timestamp_float #endif --- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default. --- readTime can successfully parse both formats, but PostgreSQL needs the colon. -fixTZ :: String -> String -fixTZ "" = "" -fixTZ ['+',h1,h2] | isDigit h1 && isDigit h2 = ['+',h1,h2,':','0','0'] -fixTZ ['-',h1,h2] | isDigit h1 && isDigit h2 = ['-',h1,h2,':','0','0'] -fixTZ ['+',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['+',h1,h2,':',m1,m2] -fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = ['-',h1,h2,':',m1,m2] -fixTZ (c:s) = c:fixTZ s - instance PGType "timestamp with time zone" where pgBinaryColumn = binColDatetime instance PGParameter "timestamp with time zone" Time.UTCTime where diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 10218e0..4d949c8 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,12 +1,12 @@ Name: postgresql-typed -Version: 0.4.4 +Version: 0.5 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING -Copyright: 2010-2013 Chris Forno, 2014-2015 Dylan Simon +Copyright: 2010-2013 Chris Forno, 2014-2016 Dylan Simon Author: Dylan Simon Maintainer: Dylan Simon -Stability: beta +Stability: provisional Bug-Reports: https://github.com/dylex/postgresql-typed/issues Homepage: https://github.com/dylex/postgresql-typed Category: Database @@ -47,9 +47,12 @@ Flag aeson Description: Support decoding json via aeson. Default: True +Flag HDBC + Description: Provide an HDBC driver + Library Build-Depends: - base >= 4.7 && < 5, + base >= 4.8 && < 5, array, binary, containers, @@ -96,13 +99,24 @@ Library if flag(aeson) Build-Depends: aeson >= 0.7 CPP-options: -DUSE_AESON + if flag(HDBC) + Build-Depends: HDBC >= 2.2 + Exposed-Modules: + Database.PostgreSQL.Typed.HDBC test-suite test build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck type: exitcode-stdio-1.0 + hs-source-dirs: test main-is: Main.hs Other-Modules: Connect - buildable: True - hs-source-dirs: test Extensions: TemplateHaskell, QuasiQuotes GHC-Options: -Wall + +test-suite hdbc + build-depends: base, network, time, containers, convertible, postgresql-typed, HDBC, HUnit + type: exitcode-stdio-1.0 + hs-source-dirs: test/hdbc, test + main-is: runtests.hs + if !flag(HDBC) + buildable: False diff --git a/test/Main.hs b/test/Main.hs index 28fec4c..fedc95d 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where @@ -60,6 +61,14 @@ instance Q.Arbitrary PGInet where then PGInet6 <$> Q.arbitrary <*> ((`mod` 129) <$> Q.arbitrary) else PGInet <$> Q.arbitrary <*> ((`mod` 33) <$> Q.arbitrary) +instance Q.Arbitrary SQLToken where + arbitrary = Q.oneof + [ SQLToken <$> Q.arbitrary + , SQLParam <$> Q.arbitrary + , SQLExpr <$> Q.arbitrary + , SQLQMark <$> Q.arbitrary + ] + newtype Str = Str { strString :: [Char] } deriving (Eq, Show) strByte :: Str -> BS.ByteString strByte = BSC.pack . strString @@ -112,6 +121,20 @@ main = do Q..&&. tokenProp Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" Q..&&. pgEnumValues Q.=== [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] + Q..&&. Q.conjoin (map (\(s, t) -> sqlTokens s Q.=== t) + [ ("", + []) + , ( "SELECT a from b WHERE c = ?" + , ["SELECT a from b WHERE c = ", SQLQMark False]) + , ( "INSERT INTO foo VALUES (?,?)" + , ["INSERT INTO foo VALUES (", SQLQMark False, ",", SQLQMark False, ")"]) + , ( "INSERT INTO foo VALUES ('?','''?')" + , ["INSERT INTO foo VALUES ('?','''?')"]) + , ( "-- really?\n-- yes'?\nINSERT INTO ? VALUES ('', ?, \"?asd\", e'?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ?)" + , ["-- really?\n-- yes'?\nINSERT INTO ", SQLQMark False, " VALUES ('', ", SQLQMark False, ", \"?asd\", e'?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ", SQLQMark False, ")"]) + , ( "some ${things? {don't}} change$1 $1\\?" + , ["some ", SQLExpr "things? {don't}", " change$1 ", SQLParam 1, SQLQMark True]) + ]) assert $ isSuccess r ["box"] <- simple c 603 diff --git a/test/hdbc/SpecificDB.hs b/test/hdbc/SpecificDB.hs new file mode 100644 index 0000000..1b86949 --- /dev/null +++ b/test/hdbc/SpecificDB.hs @@ -0,0 +1,27 @@ +module SpecificDB where +import Database.HDBC +import Database.PostgreSQL.Typed.HDBC + +import Connect + +connectDB :: IO Connection +connectDB = + handleSqlError (do dbh <- connect db + _ <- run dbh "SET client_min_messages=WARNING" [] + return dbh) + +dateTimeTypeOfSqlValue :: SqlValue -> String +dateTimeTypeOfSqlValue (SqlLocalDate _) = "date" +dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone" +dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone" +dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone" +dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone" +dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone" +dateTimeTypeOfSqlValue (SqlDiffTime _) = "interval" +dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric" +dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer" +dateTimeTypeOfSqlValue (SqlTimeDiff _) = "interval" +dateTimeTypeOfSqlValue _ = "text" + +supportsFracTime :: Bool +supportsFracTime = True diff --git a/test/hdbc/TestMisc.hs b/test/hdbc/TestMisc.hs new file mode 100644 index 0000000..15372f0 --- /dev/null +++ b/test/hdbc/TestMisc.hs @@ -0,0 +1,181 @@ +module TestMisc(tests, setup) where +import Test.HUnit +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception +import Data.Char +import Control.Monad +import qualified Data.Map as Map + +rowdata = + [[SqlInt32 0, toSql "Testing", SqlNull], + [SqlInt32 1, toSql "Foo", SqlInt32 5], + [SqlInt32 2, toSql "Bar", SqlInt32 9]] + +colnames = ["testid", "teststring", "testint"] +alrows :: [[(String, SqlValue)]] +alrows = map (zip colnames) rowdata + +setup f = dbTestCase $ \dbh -> + do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] + sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rowdata + finish sth + commit dbh + finally (f dbh) + (do run dbh "DROP TABLE hdbctest2" [] + commit dbh + ) + +cloneTest dbh a = + do dbh2 <- clone dbh + finally (handleSqlError (a dbh2)) + (handleSqlError (disconnect dbh2)) + +testgetColumnNames = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2" + execute sth [] + cols <- getColumnNames sth + finish sth + ["testid", "teststring", "testint"] @=? map (map toLower) cols + +testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` + ["sqlite3"])) $ + do sth <- prepare dbh "SELECT * from hdbctest2" + execute sth [] + cols <- describeResult sth + ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols + let coldata = map snd cols + assertBool "r0 type" (colType (coldata !! 0) `elem` + [SqlBigIntT, SqlIntegerT]) + assertBool "r1 type" (colType (coldata !! 1) `elem` + [SqlVarCharT, SqlLongVarCharT]) + assertBool "r2 type" (colType (coldata !! 2) `elem` + [SqlBigIntT, SqlIntegerT]) + finish sth + +testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` + ["sqlite3"])) $ + do cols <- describeTable dbh "hdbctest2" + ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols + let coldata = map snd cols + assertBool "r0 type" (colType (coldata !! 0) `elem` + [SqlBigIntT, SqlIntegerT]) + assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0)) + assertBool "r1 type" (colType (coldata !! 1) `elem` + [SqlVarCharT, SqlLongVarCharT]) + assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1)) + assertBool "r2 type" (colType (coldata !! 2) `elem` + [SqlBigIntT, SqlIntegerT]) + assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) + +testquickQuery = setup $ \dbh -> + do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + rowdata @=? results + +testfetchRowAL = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchRowAL sth >>= (Just (head alrows) @=?) + fetchRowAL sth >>= (Just (alrows !! 1) @=?) + fetchRowAL sth >>= (Just (alrows !! 2) @=?) + fetchRowAL sth >>= (Nothing @=?) + finish sth + +testfetchRowMap = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) + fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) + fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) + fetchRowMap sth >>= (Nothing @=?) + finish sth + +testfetchAllRowsAL = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchAllRowsAL sth >>= (alrows @=?) + +testfetchAllRowsMap = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) + +testexception = setup $ \dbh -> + catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" + execute sth [] + assertFailure "No exception was raised" + ) + (\e -> commit dbh) + +testrowcount = setup $ \dbh -> + do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] + assertEqual "UPDATE with no change" 0 r + r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] + assertEqual "UPDATE with 1 change" 1 r + r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] + assertEqual "UPDATE with 2 changes" 2 r + commit dbh + res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + assertEqual "final results" + [[SqlInt32 0, toSql "Testing", SqlInt32 26], + [SqlInt32 1, toSql "Foo", SqlInt32 27], + [SqlInt32 2, toSql "Bar", SqlInt32 27]] res + +{- Since we might be running against a live DB, we can't look at a specific +list here (though a SpecificDB test case may be able to). We can ensure +that our test table is, or is not, present, as appropriate. -} + +testgetTables1 = setup $ \dbh -> + do r <- getTables dbh + True @=? "hdbctest2" `elem` r + +testgetTables2 = dbTestCase $ \dbh -> + do r <- getTables dbh + False @=? "hdbctest2" `elem` r + +testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> + do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + rowdata @=? results + +testnulls = setup $ \dbh -> + do let dn = hdbcDriverName dbh + when (not (dn `elem` ["postgresql", "odbc", "postgresql-typed"])) ( + do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rows + finish sth + res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + seq (length res) rows @=? res + ) + where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], + [SqlInt32 101, SqlString "bar\NUL", SqlNull], + [SqlInt32 102, SqlString "\NUL", SqlNull], + [SqlInt32 103, SqlString "\xFF", SqlNull], + [SqlInt32 104, SqlString "regular", SqlNull]] + +testunicode = setup $ \dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rows + finish sth + res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + seq (length res) rows @=? res + where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], + [SqlInt32 101, SqlString "bar\x00A3", SqlNull], + [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] + +tests = TestList [TestLabel "getColumnNames" testgetColumnNames, + TestLabel "describeResult" testdescribeResult, + TestLabel "describeTable" testdescribeTable, + TestLabel "quickQuery" testquickQuery, + TestLabel "fetchRowAL" testfetchRowAL, + TestLabel "fetchRowMap" testfetchRowMap, + TestLabel "fetchAllRowsAL" testfetchAllRowsAL, + TestLabel "fetchAllRowsMap" testfetchAllRowsMap, + TestLabel "sql exception" testexception, + TestLabel "clone" testclone, + TestLabel "update rowcount" testrowcount, + TestLabel "get tables1" testgetTables1, + TestLabel "get tables2" testgetTables2, + TestLabel "nulls" testnulls, + TestLabel "unicode" testunicode] diff --git a/test/hdbc/TestSbasics.hs b/test/hdbc/TestSbasics.hs new file mode 100644 index 0000000..87cf761 --- /dev/null +++ b/test/hdbc/TestSbasics.hs @@ -0,0 +1,170 @@ +module TestSbasics(tests) where +import Test.HUnit +import Data.List +import Database.HDBC +import TestUtils +import Control.Exception + +openClosedb = sqlTestCase $ + do dbh <- connectDB + disconnect dbh + +multiFinish = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + sExecute sth [] + finish sth + finish sth + finish sth + ) + +runRawTest = dbTestCase (\dbh -> + do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" + tables <- getTables dbh + assertBool "valid1 table not created!" ("valid1" `elem` tables) + assertBool "valid2 table not created!" ("valid2" `elem` tables) + ) + +runRawErrorTest = dbTestCase (\dbh -> + let expected = "ERROR: syntax error at or near \"INVALID\"" + in do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` + (return . seErrorMsg) + assertBool "Error message inappropriate" (expected `isPrefixOf` err) + rollback dbh + tables <- getTables dbh + assertBool "valid1 table created!" (not $ "valid1" `elem` tables) + ) + + +basicQueries = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + sExecute sth [] + sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) + sFetchRow sth >>= (assertEqual "last row" Nothing) + ) + +createTable = dbTestCase (\dbh -> + do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + commit dbh + ) + +dropTable = dbTestCase (\dbh -> + do sRun dbh "DROP TABLE hdbctest1" [] + commit dbh + ) + +runReplace = dbTestCase (\dbh -> + do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" + sExecute sth [] + sFetchRow sth >>= (assertEqual "r1" (Just r1)) + sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", + Just "2", Nothing])) + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] + r2 = [Just "runReplace", Just "2", Nothing] + +executeReplace = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" + sExecute sth [Just "1", Just "1234", Just "Foo"] + sExecute sth [Just "2", Nothing, Just "Bar"] + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + sExecute sth [Just "executeReplace"] + sFetchRow sth >>= (assertEqual "r1" + (Just $ map Just ["executeReplace", "1", "1234", + "Foo"])) + sFetchRow sth >>= (assertEqual "r2" + (Just [Just "executeReplace", Just "2", Nothing, + Just "Bar"])) + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + +testExecuteMany = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" + sExecuteMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + sExecute sth [] + mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + where rows = [map Just ["1", "1234", "foo"], + map Just ["2", "1341", "bar"], + [Just "3", Nothing, Nothing]] + +testsFetchAllRows = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" + sExecuteMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + sExecute sth [] + results <- sFetchAllRows sth + assertEqual "" rows results + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +basicTransactions = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" + sExecute sth [Just "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) + + -- Now try a rollback + sExecuteMany sth rows + rollback dbh + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) + + -- Now try another commit + sExecuteMany sth rows + commit dbh + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +testWithTransaction = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" + sExecute sth [Just "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) + + -- Let's try a rollback. + catch (withTransaction dbh (\_ -> do sExecuteMany sth rows + fail "Foo")) + (\SomeException{} -> return ()) + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) + + -- And now a commit. + withTransaction dbh (\_ -> sExecuteMany sth rows) + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +tests = TestList + [ + TestLabel "openClosedb" openClosedb, + TestLabel "multiFinish" multiFinish, + TestLabel "runRawTest" runRawTest, + TestLabel "runRawErrorTest" runRawErrorTest, + TestLabel "basicQueries" basicQueries, + TestLabel "createTable" createTable, + TestLabel "runReplace" runReplace, + TestLabel "executeReplace" executeReplace, + TestLabel "executeMany" testExecuteMany, + TestLabel "sFetchAllRows" testsFetchAllRows, + TestLabel "basicTransactions" basicTransactions, + TestLabel "withTransaction" testWithTransaction, + TestLabel "dropTable" dropTable + ] diff --git a/test/hdbc/TestTime.hs b/test/hdbc/TestTime.hs new file mode 100644 index 0000000..55f990b --- /dev/null +++ b/test/hdbc/TestTime.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} + +module TestTime(tests) where +import Test.HUnit +import Database.HDBC +import TestUtils +import Control.Exception +import Data.Time (UTCTime, Day, NominalDiffTime) +import Data.Time.LocalTime +import Data.Time.Clock.POSIX +import Data.Maybe +import Data.Convertible +import SpecificDB +import Data.Time (parseTimeM, defaultTimeLocale, TimeLocale) +import Database.HDBC.Locale (iso8601DateFormat) + +instance Eq ZonedTime where + a == b = zonedTimeToUTC a == zonedTimeToUTC b + +testZonedTime :: ZonedTime +testZonedTime = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T %z")) + "1989-08-01 15:33:01 -0500" + +testZonedTimeFrac :: ZonedTime +testZonedTimeFrac = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) + "1989-08-01 15:33:01.536 -0500" + + +testDTType :: (Convertible SqlValue a, Show b, Eq b) => + a + -> (a -> SqlValue) + -> (a -> b) + -> Test +testDTType inputdata convToSqlValue toComparable = dbTestCase $ \dbh -> + do _ <- run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] + commit dbh + finally (testDT dbh) (do commit dbh + _ <- run dbh "DROP TABLE hdbctesttime" [] + commit dbh + ) + where testDT dbh = + do _ <- run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" + [iToSql 5, value] + commit dbh + r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] + case r of + ~[[testidsv, testvaluesv]] -> + do assertEqual "testid" (5::Int) (fromSql testidsv) + assertEqual "testvalue" + (toComparable inputdata) + (toComparable$ fromSql testvaluesv) + value = convToSqlValue inputdata + +mkTest :: (Eq b, Show b, Convertible SqlValue a) => String -> a -> (a -> SqlValue) -> (a -> b) -> Test +mkTest label inputdata convfunc toComparable = + TestLabel label (testDTType inputdata convfunc toComparable) + +tests :: Test +tests = TestList $ + ((TestLabel "Non-frac" $ testIt testZonedTime) : + if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) + +testIt :: ZonedTime -> Test +testIt baseZonedTime = + TestList [ mkTest "Day" baseDay toSql id + , mkTest "TimeOfDay" baseTimeOfDay toSql id + , mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql id + , mkTest "LocalTime" baseLocalTime toSql id + , mkTest "ZonedTime" baseZonedTime toSql id + , mkTest "UTCTime" baseUTCTime toSql id + , mkTest "DiffTime" baseDiffTime toSql id + , mkTest "POSIXTime" basePOSIXTime posixToSql id + ] + where + baseDay :: Day + baseDay = localDay baseLocalTime + + baseTimeOfDay :: TimeOfDay + baseTimeOfDay = localTimeOfDay baseLocalTime + + baseZonedTimeOfDay :: (TimeOfDay, TimeZone) + baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) + + baseLocalTime :: LocalTime + baseLocalTime = zonedTimeToLocalTime baseZonedTime + + baseUTCTime :: UTCTime + baseUTCTime = convert baseZonedTime + + baseDiffTime :: NominalDiffTime + baseDiffTime = basePOSIXTime + + basePOSIXTime :: POSIXTime + basePOSIXTime = convert baseZonedTime + +parseTime' :: TimeLocale -> String -> String -> Maybe ZonedTime +parseTime' = parseTimeM True diff --git a/test/hdbc/TestUtils.hs b/test/hdbc/TestUtils.hs new file mode 100644 index 0000000..f70627d --- /dev/null +++ b/test/hdbc/TestUtils.hs @@ -0,0 +1,29 @@ +module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where +import Database.HDBC +import Database.PostgreSQL.Typed.HDBC +import Test.HUnit +import Control.Exception +import SpecificDB(connectDB) + +sqlTestCase :: IO () -> Test +sqlTestCase a = + TestCase (handleSqlError a) + +dbTestCase :: (Connection -> IO ()) -> Test +dbTestCase a = + TestCase (do dbh <- connectDB + finally (handleSqlError (a dbh)) + (handleSqlError (disconnect dbh)) + ) + +printDBInfo :: IO () +printDBInfo = handleSqlError $ + do dbh <- connectDB + putStrLn "+-------------------------------------------------------------------------" + putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++ + ", bound to client: " ++ hdbcClientVer dbh + putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++ + ", bound to version: " ++ proxiedClientVer dbh + putStrLn $ "| Connected to server version: " ++ dbServerVer dbh + putStrLn "+-------------------------------------------------------------------------\n" + disconnect dbh diff --git a/test/hdbc/Testbasics.hs b/test/hdbc/Testbasics.hs new file mode 100644 index 0000000..1e0fa9d --- /dev/null +++ b/test/hdbc/Testbasics.hs @@ -0,0 +1,168 @@ +module Testbasics(tests) where +import Test.HUnit +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception + +openClosedb = sqlTestCase $ + do dbh <- connectDB + disconnect dbh + +multiFinish = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + r <- execute sth [] + assertEqual "basic count" 0 r + finish sth + finish sth + finish sth + ) + +basicQueries = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + execute sth [] >>= (0 @=?) + r <- fetchAllRows sth + assertEqual "converted from" [["2"]] (map (map fromSql) r) + assertEqual "int32 compare" [[SqlInt32 2]] r + assertEqual "iToSql compare" [[iToSql 2]] r + assertEqual "num compare" [[toSql (2::Int)]] r + assertEqual "nToSql compare" [[nToSql (2::Int)]] r + assertEqual "string compare" [[SqlString "2"]] r + ) + +createTable = dbTestCase (\dbh -> + do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + commit dbh + ) + +dropTable = dbTestCase (\dbh -> + do run dbh "DROP TABLE hdbctest1" [] + commit dbh + ) + +runReplace = dbTestCase (\dbh -> + do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + assertEqual "insert retval" 1 r + run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" + rv2 <- execute sth [] + assertEqual "select retval" 0 rv2 + r <- fetchAllRows sth + assertEqual "" [r1, r2] r + ) + where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] + +executeReplace = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" + execute sth [iToSql 1, iToSql 1234, toSql "Foo"] + execute sth [SqlInt32 2, SqlNull, toSql "Bar"] + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + execute sth [SqlString "executeReplace"] + r <- fetchAllRows sth + assertEqual "result" + [[toSql "executeReplace", iToSql 1, toSql "1234", + toSql "Foo"], + [toSql "executeReplace", iToSql 2, SqlNull, + toSql "Bar"]] + r + ) + +testExecuteMany = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + execute sth [] + r <- fetchAllRows sth + assertEqual "" rows r + ) + where rows = [map toSql ["1", "1234", "foo"], + map toSql ["2", "1341", "bar"], + [toSql "3", SqlNull, SqlNull]] + +testFetchAllRows = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + execute sth [] + results <- fetchAllRows sth + assertEqual "" rows results + ) + where rows = map (\x -> [iToSql x]) [1..9] + +testFetchAllRows' = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid" + execute sth [] + results <- fetchAllRows' sth + assertEqual "" rows results + ) + where rows = map (\x -> [iToSql x]) [1..9] + +basicTransactions = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" + execute sth [iToSql 0] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) + + -- Now try a rollback + executeMany sth rows + rollback dbh + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) + + -- Now try another commit + executeMany sth rows + commit dbh + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) + ) + where rows = map (\x -> [iToSql $ x]) [1..9] + +testWithTransaction = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" + execute sth [toSql "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) + + -- Let's try a rollback. + catch (withTransaction dbh (\_ -> do executeMany sth rows + fail "Foo")) + (\SomeException{} -> return ()) + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) + + -- And now a commit. + withTransaction dbh (\_ -> executeMany sth rows) + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) + ) + where rows = map (\x -> [iToSql x]) [1..9] + +tests = TestList + [ + TestLabel "openClosedb" openClosedb, + TestLabel "multiFinish" multiFinish, + TestLabel "basicQueries" basicQueries, + TestLabel "createTable" createTable, + TestLabel "runReplace" runReplace, + TestLabel "executeReplace" executeReplace, + TestLabel "executeMany" testExecuteMany, + TestLabel "fetchAllRows" testFetchAllRows, + TestLabel "fetchAllRows'" testFetchAllRows', + TestLabel "basicTransactions" basicTransactions, + TestLabel "withTransaction" testWithTransaction, + TestLabel "dropTable" dropTable + ] diff --git a/test/hdbc/Tests.hs b/test/hdbc/Tests.hs new file mode 100644 index 0000000..a924cab --- /dev/null +++ b/test/hdbc/Tests.hs @@ -0,0 +1,19 @@ +{- arch-tag: Tests main file +-} + +module Tests(tests) where +import Test.HUnit +import qualified Testbasics +import qualified TestSbasics +import qualified TestMisc +import qualified TestTime + +test1 = TestCase ("x" @=? "x") + +tests = TestList + [ TestLabel "test1" test1 + , TestLabel "String basics" TestSbasics.tests + , TestLabel "SqlValue basics" Testbasics.tests + , TestLabel "Misc tests" TestMisc.tests + , TestLabel "Time tests" TestTime.tests + ] diff --git a/test/hdbc/runtests.hs b/test/hdbc/runtests.hs new file mode 100644 index 0000000..c60979b --- /dev/null +++ b/test/hdbc/runtests.hs @@ -0,0 +1,16 @@ +{- arch-tag: Test runner +-} + +module Main where + +import Test.HUnit +import System.Exit +import Tests +import TestUtils + +main = do + printDBInfo + r <- runTestTT tests + if errors r == 0 && failures r == 0 + then exitSuccess + else exitFailure From 401b8b87debddd3cd2708d9aaf829255981f0b20 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Aug 2016 00:33:52 -0400 Subject: [PATCH 189/306] Add LICENSE for hdbc tests --- postgresql-typed.cabal | 7 ++++--- test/hdbc/LICENSE | 29 +++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 3 deletions(-) create mode 100644 test/hdbc/LICENSE diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 4d949c8..107a714 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -105,18 +105,19 @@ Library Database.PostgreSQL.Typed.HDBC test-suite test - build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs Other-Modules: Connect Extensions: TemplateHaskell, QuasiQuotes + build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck GHC-Options: -Wall test-suite hdbc - build-depends: base, network, time, containers, convertible, postgresql-typed, HDBC, HUnit type: exitcode-stdio-1.0 hs-source-dirs: test/hdbc, test main-is: runtests.hs - if !flag(HDBC) + if flag(HDBC) + build-depends: base, network, time, containers, convertible, postgresql-typed, HDBC, HUnit + else buildable: False diff --git a/test/hdbc/LICENSE b/test/hdbc/LICENSE new file mode 100644 index 0000000..c49d345 --- /dev/null +++ b/test/hdbc/LICENSE @@ -0,0 +1,29 @@ +Based on HDBC-postgresql testsrc + +Copyright (c) 2005-2011 John Goerzen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +* Neither the name of John Goerzen nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. From 11d65d0d9e2410c337d826229d4d92042c8438ef Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Aug 2016 10:51:58 -0400 Subject: [PATCH 190/306] Update HDBC-related documentation --- Database/PostgreSQL/Typed/HDBC.hs | 50 +++++++++++++++++-------------- postgresql-typed.cabal | 7 +++-- 2 files changed, 32 insertions(+), 25 deletions(-) diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index 43a7624..9535ab8 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -10,9 +10,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Database.PostgreSQL.Typed.HDBC - ( Connection, pgConnection + ( Connection, connectionPG, connectionFetchSize , connect , reloadTypes + , setFetchSize ) where import Control.Arrow ((&&&)) @@ -44,15 +45,17 @@ import Database.PostgreSQL.Typed.SQLToken import Paths_postgresql_typed (version) -- |A wrapped 'PGConnection'. --- This differs from a bare 'PGConnection' in two ways: +-- This differs from a bare 'PGConnection' in a few ways: -- --- 1) It always has exactly one active transaction (with 'pgBegin') --- 2) It automatically disconnects on GC +-- 1. It always has exactly one active transaction (with 'pgBegin') +-- 2. It automatically disconnects on GC +-- 3. It provides a mutex around the underlying 'PGConnection' for thread-safety -- data Connection = Connection - { pgConnection :: MVar PGConnection -- ^Access the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. - , pgServerVer :: String - , pgTypes :: IntMap.IntMap SqlType + { connectionPG :: MVar PGConnection -- ^Access the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. + , connectionServerVer :: String + , connectionTypes :: IntMap.IntMap SqlType + , connectionFetchSize :: Word32 -- ^Number of rows to fetch (and cache) with 'HDBC.execute' and each time 'HDBC.fetchRow' requires more rows. A higher value will result in fewer round-trips to the database but potentially more wasted data. Defaults to 1. 0 means fetch all rows. } sqlError :: IO a -> IO a @@ -67,7 +70,7 @@ sqlError = handle $ \(PGError m) -> } withPG :: Connection -> (PGConnection -> IO a) -> IO a -withPG c = sqlError . withMVar (pgConnection c) +withPG c = sqlError . withMVar (connectionPG c) connect_ :: PGDatabase -> IO PGConnection connect_ d = sqlError $ do @@ -82,9 +85,10 @@ connect d = do pg <- connect_ d pgv <- newMVar pg reloadTypes Connection - { pgConnection = pgv - , pgServerVer = maybe "" BSC.unpack $ pgServerVersion pg - , pgTypes = mempty + { connectionPG = pgv + , connectionServerVer = maybe "" BSC.unpack $ pgServerVersion pg + , connectionTypes = mempty + , connectionFetchSize = 1 } -- |Reload the table of all types from the database. @@ -92,7 +96,12 @@ connect d = do reloadTypes :: Connection -> IO Connection reloadTypes c = withPG c $ \pg -> do t <- pgLoadTypes pg - return c{ pgTypes = IntMap.map (sqlType $ pgTypeEnv pg) t } + return c{ connectionTypes = IntMap.map (sqlType $ pgTypeEnv pg) t } + +-- |Change the 'connectionFetchSize' for new 'HDBC.Statement's created with 'HDBC.prepare'. +-- Ideally this could be set with each call to 'HDBC.execute' and 'HDBC.fetchRow', but the HDBC interface provides no way to do this. +setFetchSize :: Word32 -> Connection -> Connection +setFetchSize i c = c{ connectionFetchSize = i } sqls :: String -> BSLC.ByteString sqls = BSLC.pack @@ -119,11 +128,6 @@ data Cursor = Cursor noCursor :: HDBC.Statement -> Cursor noCursor = Cursor [] [] False --- |Number of rows to retrieve (and cache) with each call to fetchRow. --- Ideally this should be configurable, but it's not clear how. -fetchSize :: Word32 -fetchSize = 1 - getType :: Connection -> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc getType c pg nul PGColDescription{..} = ColDesc { colDescName = BSC.unpack colName @@ -135,7 +139,7 @@ getType c pg nul PGColDescription{..} = ColDesc , HDBC.colNullable = nul } , colDescDecode = sqlTypeDecode t - } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show colType) (fromIntegral colType) (pgTypes c) + } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show colType) (fromIntegral colType) (connectionTypes c) instance HDBC.IConnection Connection where disconnect c = withPG c @@ -159,7 +163,7 @@ instance HDBC.IConnection Connection where let execute v = withPG c $ \pg -> do d <- pgBind pg n (map encode v) - (r, e) <- pgFetch pg n fetchSize + (r, e) <- pgFetch pg n (connectionFetchSize c) modifyIORef' cr $ \p -> p { cursorDesc = map (getType c pg Nothing) d , cursorRow = r @@ -177,7 +181,7 @@ instance HDBC.IConnection Connection where p <- readIORef cr fmap (zipWith colDescDecode (cursorDesc p)) <$> case cursorRow p of [] | True || cursorActive p -> do - (rl, e) <- pgFetch pg n fetchSize + (rl, e) <- pgFetch pg n (connectionFetchSize c) let rl' = uncons rl writeIORef cr p { cursorRow = maybe [] snd rl' @@ -199,14 +203,14 @@ instance HDBC.IConnection Connection where addFinalizer stmt $ withPG c $ \pg -> pgClose pg n return stmt clone c = do - c' <- connect_ . pgConnectionDatabase =<< readMVar (pgConnection c) + c' <- connect_ . pgConnectionDatabase =<< readMVar (connectionPG c) cv <- newMVar c' - return c{ pgConnection = cv } + return c{ connectionPG = cv } hdbcDriverName _ = "postgresql-typed" hdbcClientVer _ = show version proxiedClientName = HDBC.hdbcDriverName proxiedClientVer = HDBC.hdbcClientVer - dbServerVer = pgServerVer + dbServerVer = connectionServerVer dbTransactionSupport _ = True getTables c = withPG c $ \pg -> map (pgDecodeRep . head) . snd <$> pgSimpleQuery pg (BSLC.fromChunks diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 107a714..b9f8ddb 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -10,11 +10,14 @@ Stability: provisional 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 +Synopsis: A PostgreSQL library with compile-time SQL type inference and optional HDBC backend Description: Automatically type-check SQL statements at compile time. Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statements at compile time and provide appropriate type marshalling for both parameters and results. Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell. Supports many built-in PostgreSQL types already, including arrays and ranges, and can be easily extended in user code to support any other types. + . + Also includes an optional HDBC backend that, since it uses the raw PostgreSQL backend, may be more efficient than the normal libpq backend in some cases (though provides no more type safety than HDBC-postgresql when used without templates). + . Originally based on Chris Forno's templatepg library. Tested-With: GHC == 7.10.3 Build-Type: Simple @@ -48,7 +51,7 @@ Flag aeson Default: True Flag HDBC - Description: Provide an HDBC driver + Description: Provide an HDBC driver backend using the raw PostgreSQL protocol. Library Build-Depends: From 7e95170785aedbf1b2b932a0efb11e0c25d7b65e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Aug 2016 10:57:39 -0400 Subject: [PATCH 191/306] Don't short-circuit cursorActive check --- Database/PostgreSQL/Typed/HDBC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index 9535ab8..6cc9c6c 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -180,7 +180,7 @@ instance HDBC.IConnection Connection where , HDBC.fetchRow = withPG c $ \pg -> do p <- readIORef cr fmap (zipWith colDescDecode (cursorDesc p)) <$> case cursorRow p of - [] | True || cursorActive p -> do + [] | cursorActive p -> do (rl, e) <- pgFetch pg n (connectionFetchSize c) let rl' = uncons rl writeIORef cr p From a7decb7619e39ca318503e961c0ef7edb14467a7 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Aug 2016 11:22:49 -0400 Subject: [PATCH 192/306] Minor doc edits --- Database/PostgreSQL/Typed.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index 7e3b71e..a363231 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -115,7 +115,7 @@ import Database.PostgreSQL.Typed.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. +-- Both TH functions take a single SQL string, which may contain in-line placeholders of the form @${expr}@ (where @expr@ is any valid Haskell expression) and/or PostgreSQL placeholders of the form @$1@, @$2@, etc. -- -- > let q = [pgSQL|SELECT id, name, address FROM people WHERE name LIKE ${query++"%"} OR email LIKE $1|] :: PGSimpleQuery [(Int32, String, Maybe String)] -- @@ -125,7 +125,7 @@ import Database.PostgreSQL.Typed.Query -- -- > [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. +-- To produce 'PGPreparedQuery' objects instead of 'PGSimpleQuery', put a single @$@ at the beginning of the query. -- You can also create queries at run-time using 'rawPGSimpleQuery' or 'rawPGPreparedQuery'. -- $run From f7328e819915a51cb90472d57c51e62780f0a02d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 9 Aug 2016 09:32:19 -0400 Subject: [PATCH 193/306] Add HDBC.fromPGConnection and more aggressive transactions --- Database/PostgreSQL/Typed/HDBC.hs | 41 ++++++++++++++++----------- Database/PostgreSQL/Typed/Protocol.hs | 14 +++++++++ 2 files changed, 38 insertions(+), 17 deletions(-) diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index 6cc9c6c..656cb3c 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -10,14 +10,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Database.PostgreSQL.Typed.HDBC - ( Connection, connectionPG, connectionFetchSize + ( Connection, connectionPG , connect + , fromPGConnection , reloadTypes + , connectionFetchSize , setFetchSize ) where import Control.Arrow ((&&&)) -import Control.Concurrent.MVar (MVar, newMVar, readMVar, withMVar) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Exception (handle, throwIO) import Control.Monad (void, guard) import qualified Data.ByteString.Char8 as BSC @@ -72,18 +74,17 @@ sqlError = handle $ \(PGError m) -> withPG :: Connection -> (PGConnection -> IO a) -> IO a withPG c = sqlError . withMVar (connectionPG c) -connect_ :: PGDatabase -> IO PGConnection -connect_ d = sqlError $ do - pg <- pgConnect d +takePGConnection :: PGConnection -> IO (MVar PGConnection) +takePGConnection pg = do addFinalizer pg (pgDisconnectOnce pg) pgBegin pg - return pg + newMVar pg --- |Connect to a database for HDBC use (equivalent to 'pgConnect' and 'pgBegin'). -connect :: PGDatabase -> IO Connection -connect d = do - pg <- connect_ d - pgv <- newMVar pg +-- |Convert an existing 'PGConnection' to an HDBC-compatible 'Connection'. +-- The caveats under 'connectionPG' apply if you plan to continue using the original 'PGConnection'. +fromPGConnection :: PGConnection -> IO Connection +fromPGConnection pg = do + pgv <- takePGConnection pg reloadTypes Connection { connectionPG = pgv , connectionServerVer = maybe "" BSC.unpack $ pgServerVersion pg @@ -91,6 +92,12 @@ connect d = do , connectionFetchSize = 1 } +-- |Connect to a database for HDBC use (equivalent to 'pgConnect' and 'pgBegin'). +connect :: PGDatabase -> IO Connection +connect d = sqlError $ do + pg <- pgConnect d + fromPGConnection pg + -- |Reload the table of all types from the database. -- This may be needed if you make structural changes to the database. reloadTypes :: Connection -> IO Connection @@ -145,10 +152,10 @@ instance HDBC.IConnection Connection where disconnect c = withPG c pgDisconnectOnce commit c = withPG c $ \pg -> do - pgCommit pg + pgCommitAll pg pgBegin pg rollback c = withPG c $ \pg -> do - pgRollback pg + pgRollbackAll pg pgBegin pg runRaw c q = withPG c $ \pg -> pgSimpleQueries_ pg $ sqls q @@ -202,10 +209,10 @@ instance HDBC.IConnection Connection where writeIORef cr $ noCursor stmt addFinalizer stmt $ withPG c $ \pg -> pgClose pg n return stmt - clone c = do - c' <- connect_ . pgConnectionDatabase =<< readMVar (connectionPG c) - cv <- newMVar c' - return c{ connectionPG = cv } + clone c = withPG c $ \pg -> do + pg' <- pgConnect $ pgConnectionDatabase pg + pgv <- takePGConnection pg' + return c{ connectionPG = pgv } hdbcDriverName _ = "postgresql-typed" hdbcClientVer _ = show version proxiedClientName = HDBC.hdbcDriverName diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 7a39076..4653207 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -29,6 +29,8 @@ module Database.PostgreSQL.Typed.Protocol ( , pgBegin , pgCommit , pgRollback + , pgCommitAll + , pgRollbackAll , pgTransaction -- * HDBC support , pgDisconnectOnce @@ -728,6 +730,18 @@ pgCommit c@PGConnection{ connTransaction = tr } = do t <- atomicModifyIORef' tr predTransaction void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "COMMIT" else "RELEASE SAVEPOINT pgt" ++ show t +-- |Rollback all active 'pgBegin's. +pgRollbackAll :: PGConnection -> IO () +pgRollbackAll c@PGConnection{ connTransaction = tr } = do + writeIORef tr 0 + void $ pgSimpleQuery c $ BSLC.pack "ROLLBACK" + +-- |Commit all active 'pgBegin's. +pgCommitAll :: PGConnection -> IO () +pgCommitAll c@PGConnection{ connTransaction = tr } = do + writeIORef tr 0 + void $ pgSimpleQuery c $ BSLC.pack "COMMIT" + -- |Wrap a computation in a 'pgBegin', 'pgCommit' block, or 'pgRollback' on exception. pgTransaction :: PGConnection -> IO a -> IO a pgTransaction c f = do From f7098c16702b366224f09c4376e9c4bdcfee890d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 9 Aug 2016 09:35:04 -0400 Subject: [PATCH 194/306] Updates for ghc 8.0.1 --- Database/PostgreSQL/Typed/Array.hs | 3 +++ Database/PostgreSQL/Typed/Dynamic.hs | 2 +- Database/PostgreSQL/Typed/Enum.hs | 27 +++++++++++++++++++-------- Database/PostgreSQL/Typed/Range.hs | 2 +- postgresql-typed.cabal | 2 +- 5 files changed, 25 insertions(+), 11 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 5608cc1..79e9f61 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#endif -- | -- Module: Database.PostgreSQL.Typed.Array -- Copyright: 2015 Dylan Simon diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 9533b28..a57d3f7 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, GADTs, TemplateHaskell #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, GADTs, TemplateHaskell, AllowAmbiguousTypes #-} -- | -- Module: Database.PostgreSQL.Typed.Dynamic -- Copyright: 2015 Dylan Simon diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index a8ae44e..671560d 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} -- | -- Module: Database.PostgreSQL.Typed.Enum -- Copyright: 2015 Dylan Simon @@ -57,18 +57,25 @@ makePGEnum name typs valnf = do valn = map (\[PGTextValue v] -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals dv <- TH.newName "x" return - [ TH.DataD [] typn [] (map (\(n, _, _) -> TH.NormalC n []) valn) + [ TH.DataD [] typn [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + (map (\(n, _, _) -> TH.NormalC n []) valn) $ +#if MIN_VERSION_template_haskell(2,11,0) + map TH.ConT +#endif [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] - , TH.InstanceD [] (TH.ConT ''Show `TH.AppT` typt) + , instanceD [] (TH.ConT ''Show `TH.AppT` typt) [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []] (TH.NormalB $ TH.LitE v) []) valn ] - , TH.InstanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] - , TH.InstanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) + , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] + , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgEncode $ map (\(n, l, _) -> TH.Clause [TH.WildP, TH.ConP n []] (TH.NormalB $ TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) []) valn ] - , TH.InstanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) + , instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l, _) -> TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE n) []) valn ++ @@ -77,10 +84,14 @@ makePGEnum name typs valnf = do []]) []] ] - , TH.InstanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) [] - , TH.InstanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) [] + , instanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) [] + , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) [] ] where typn = TH.mkName typs typt = TH.ConT typn typl = TH.LitT (TH.StrTyLit name) + instanceD = TH.InstanceD +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 2fad763..c981b1c 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -144,7 +144,7 @@ isFull (Range (Lower Unbounded) (Upper Unbounded)) = True isFull _ = False -- |Create a point range @[x,x]@ -point :: Eq a => a -> Range a +point :: a -> Range a point a = Range (Lower (Bounded True a)) (Upper (Bounded True a)) -- |Extract a point: @getPoint (point x) == Just x@ diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index b9f8ddb..f999bac 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -19,7 +19,7 @@ Description: Automatically type-check SQL statements at compile time. Also includes an optional HDBC backend that, since it uses the raw PostgreSQL backend, may be more efficient than the normal libpq backend in some cases (though provides no more type safety than HDBC-postgresql when used without templates). . Originally based on Chris Forno's templatepg library. -Tested-With: GHC == 7.10.3 +Tested-With: GHC == 7.10.3, GHC == 8.0.1 Build-Type: Simple source-repository head From 5d83bce5c27254688fad148fe12f60d34f728750 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 28 Sep 2016 16:34:39 -0400 Subject: [PATCH 195/306] Add auto-generated ErrCodes --- .gitignore | 3 + Database/PostgreSQL/Typed/ErrCodes.hs | 1506 +++++++++++++++++++++++++ errcodes.hs | 115 ++ postgresql-typed.cabal | 1 + 4 files changed, 1625 insertions(+) create mode 100644 Database/PostgreSQL/Typed/ErrCodes.hs create mode 100644 errcodes.hs diff --git a/.gitignore b/.gitignore index 9b1c8b1..a7e4f5f 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,4 @@ /dist +/errcodes +/errcodes.hi +/errcodes.o diff --git a/Database/PostgreSQL/Typed/ErrCodes.hs b/Database/PostgreSQL/Typed/ErrCodes.hs new file mode 100644 index 0000000..675a6de --- /dev/null +++ b/Database/PostgreSQL/Typed/ErrCodes.hs @@ -0,0 +1,1506 @@ +-- Automatically generated from /src/postgresql-9.5.3/src/src/backend/utils/errcodes.txt using errcodes.hs 2016-09-28 20:17:05.706135604 UTC. +{-# LANGUAGE OverloadedStrings #-} +-- |PostgreSQL error codes. +module Database.PostgreSQL.Typed.ErrCodes (names + -- * Class 00 - Successful Completion + , successful_completion + -- * Class 01 - Warning + , warning + , warning_dynamic_result_sets_returned + , warning_implicit_zero_bit_padding + , warning_null_value_eliminated_in_set_function + , warning_privilege_not_granted + , warning_privilege_not_revoked + , warning_string_data_right_truncation + , warning_deprecated_feature + -- * Class 02 - No Data (this is also a warning class per the SQL standard) + , no_data + , no_additional_dynamic_result_sets_returned + -- * Class 03 - SQL Statement Not Yet Complete + , sql_statement_not_yet_complete + -- * Class 08 - Connection Exception + , connection_exception + , connection_does_not_exist + , connection_failure + , sqlclient_unable_to_establish_sqlconnection + , sqlserver_rejected_establishment_of_sqlconnection + , transaction_resolution_unknown + , protocol_violation + -- * Class 09 - Triggered Action Exception + , triggered_action_exception + -- * Class 0A - Feature Not Supported + , feature_not_supported + -- * Class 0B - Invalid Transaction Initiation + , invalid_transaction_initiation + -- * Class 0F - Locator Exception + , locator_exception + , invalid_locator_specification + -- * Class 0L - Invalid Grantor + , invalid_grantor + , invalid_grant_operation + -- * Class 0P - Invalid Role Specification + , invalid_role_specification + -- * Class 0Z - Diagnostics Exception + , diagnostics_exception + , stacked_diagnostics_accessed_without_active_handler + -- * Class 20 - Case Not Found + , case_not_found + -- * Class 21 - Cardinality Violation + , cardinality_violation + -- * Class 22 - Data Exception + , data_exception + , _ARRAY_ELEMENT_ERROR + , array_subscript_error + , character_not_in_repertoire + , datetime_field_overflow + , _DATETIME_VALUE_OUT_OF_RANGE + , division_by_zero + , error_in_assignment + , escape_character_conflict + , indicator_overflow + , interval_field_overflow + , invalid_argument_for_logarithm + , invalid_argument_for_ntile_function + , invalid_argument_for_nth_value_function + , invalid_argument_for_power_function + , invalid_argument_for_width_bucket_function + , invalid_character_value_for_cast + , invalid_datetime_format + , invalid_escape_character + , invalid_escape_octet + , invalid_escape_sequence + , nonstandard_use_of_escape_character + , invalid_indicator_parameter_value + , invalid_parameter_value + , invalid_regular_expression + , invalid_row_count_in_limit_clause + , invalid_row_count_in_result_offset_clause + , invalid_tablesample_argument + , invalid_tablesample_repeat + , invalid_time_zone_displacement_value + , invalid_use_of_escape_character + , most_specific_type_mismatch + , null_value_not_allowed + , null_value_no_indicator_parameter + , numeric_value_out_of_range + , string_data_length_mismatch + , string_data_right_truncation + , substring_error + , trim_error + , unterminated_c_string + , zero_length_character_string + , floating_point_exception + , invalid_text_representation + , invalid_binary_representation + , bad_copy_file_format + , untranslatable_character + , not_an_xml_document + , invalid_xml_document + , invalid_xml_content + , invalid_xml_comment + , invalid_xml_processing_instruction + -- * Class 23 - Integrity Constraint Violation + , integrity_constraint_violation + , restrict_violation + , not_null_violation + , foreign_key_violation + , unique_violation + , check_violation + , exclusion_violation + -- * Class 24 - Invalid Cursor State + , invalid_cursor_state + -- * Class 25 - Invalid Transaction State + , invalid_transaction_state + , active_sql_transaction + , branch_transaction_already_active + , held_cursor_requires_same_isolation_level + , inappropriate_access_mode_for_branch_transaction + , inappropriate_isolation_level_for_branch_transaction + , no_active_sql_transaction_for_branch_transaction + , read_only_sql_transaction + , schema_and_data_statement_mixing_not_supported + , no_active_sql_transaction + , in_failed_sql_transaction + -- * Class 26 - Invalid SQL Statement Name + , invalid_sql_statement_name + -- * Class 27 - Triggered Data Change Violation + , triggered_data_change_violation + -- * Class 28 - Invalid Authorization Specification + , invalid_authorization_specification + , invalid_password + -- * Class 2B - Dependent Privilege Descriptors Still Exist + , dependent_privilege_descriptors_still_exist + , dependent_objects_still_exist + -- * Class 2D - Invalid Transaction Termination + , invalid_transaction_termination + -- * Class 2F - SQL Routine Exception + , sql_routine_exception + , s_r_e_function_executed_no_return_statement + , s_r_e_modifying_sql_data_not_permitted + , s_r_e_prohibited_sql_statement_attempted + , s_r_e_reading_sql_data_not_permitted + -- * Class 34 - Invalid Cursor Name + , invalid_cursor_name + -- * Class 38 - External Routine Exception + , external_routine_exception + , e_r_e_containing_sql_not_permitted + , e_r_e_modifying_sql_data_not_permitted + , e_r_e_prohibited_sql_statement_attempted + , e_r_e_reading_sql_data_not_permitted + -- * Class 39 - External Routine Invocation Exception + , external_routine_invocation_exception + , e_r_i_e_invalid_sqlstate_returned + , e_r_i_e_null_value_not_allowed + , e_r_i_e_trigger_protocol_violated + , e_r_i_e_srf_protocol_violated + , e_r_i_e_event_trigger_protocol_violated + -- * Class 3B - Savepoint Exception + , savepoint_exception + , invalid_savepoint_specification + -- * Class 3D - Invalid Catalog Name + , invalid_catalog_name + -- * Class 3F - Invalid Schema Name + , invalid_schema_name + -- * Class 40 - Transaction Rollback + , transaction_rollback + , transaction_integrity_constraint_violation + , serialization_failure + , statement_completion_unknown + , deadlock_detected + -- * Class 42 - Syntax Error or Access Rule Violation + , syntax_error_or_access_rule_violation + , syntax_error + , insufficient_privilege + , cannot_coerce + , grouping_error + , windowing_error + , invalid_recursion + , invalid_foreign_key + , invalid_name + , name_too_long + , reserved_name + , datatype_mismatch + , indeterminate_datatype + , collation_mismatch + , indeterminate_collation + , wrong_object_type + , undefined_column + , _UNDEFINED_CURSOR + , _UNDEFINED_DATABASE + , undefined_function + , _UNDEFINED_PSTATEMENT + , _UNDEFINED_SCHEMA + , undefined_table + , undefined_parameter + , undefined_object + , duplicate_column + , duplicate_cursor + , duplicate_database + , duplicate_function + , duplicate_prepared_statement + , duplicate_schema + , duplicate_table + , duplicate_alias + , duplicate_object + , ambiguous_column + , ambiguous_function + , ambiguous_parameter + , ambiguous_alias + , invalid_column_reference + , invalid_column_definition + , invalid_cursor_definition + , invalid_database_definition + , invalid_function_definition + , invalid_prepared_statement_definition + , invalid_schema_definition + , invalid_table_definition + , invalid_object_definition + -- * Class 44 - WITH CHECK OPTION Violation + , with_check_option_violation + -- * Class 53 - Insufficient Resources + , insufficient_resources + , disk_full + , out_of_memory + , too_many_connections + , configuration_limit_exceeded + -- * Class 54 - Program Limit Exceeded + , program_limit_exceeded + , statement_too_complex + , too_many_columns + , too_many_arguments + -- * Class 55 - Object Not In Prerequisite State + , object_not_in_prerequisite_state + , object_in_use + , cant_change_runtime_param + , lock_not_available + -- * Class 57 - Operator Intervention + , operator_intervention + , query_canceled + , admin_shutdown + , crash_shutdown + , cannot_connect_now + , database_dropped + -- * Class 58 - System Error (errors external to PostgreSQL itself) + , system_error + , io_error + , undefined_file + , duplicate_file + -- * Class F0 - Configuration File Error + , config_file_error + , lock_file_exists + -- * Class HV - Foreign Data Wrapper Error (SQL/MED) + , fdw_error + , fdw_column_name_not_found + , fdw_dynamic_parameter_value_needed + , fdw_function_sequence_error + , fdw_inconsistent_descriptor_information + , fdw_invalid_attribute_value + , fdw_invalid_column_name + , fdw_invalid_column_number + , fdw_invalid_data_type + , fdw_invalid_data_type_descriptors + , fdw_invalid_descriptor_field_identifier + , fdw_invalid_handle + , fdw_invalid_option_index + , fdw_invalid_option_name + , fdw_invalid_string_length_or_buffer_length + , fdw_invalid_string_format + , fdw_invalid_use_of_null_pointer + , fdw_too_many_handles + , fdw_out_of_memory + , fdw_no_schemas + , fdw_option_name_not_found + , fdw_reply_handle + , fdw_schema_not_found + , fdw_table_not_found + , fdw_unable_to_create_execution + , fdw_unable_to_create_reply + , fdw_unable_to_establish_connection + -- * Class P0 - PL/pgSQL Error + , plpgsql_error + , raise_exception + , no_data_found + , too_many_rows + , assert_failure + -- * Class XX - Internal Error + , internal_error + , data_corrupted + , index_corrupted +) where + +import Data.ByteString (ByteString) +import Data.Map.Strict (Map, fromDistinctAscList) + +-- |@SUCCESSFUL_COMPLETION@: 00000 (Success) +successful_completion :: ByteString +successful_completion = "00000" + +-- |@WARNING@: 01000 (Warning) +warning :: ByteString +warning = "01000" + +-- |@WARNING_DYNAMIC_RESULT_SETS_RETURNED@: 0100C (Warning) +warning_dynamic_result_sets_returned :: ByteString +warning_dynamic_result_sets_returned = "0100C" + +-- |@WARNING_IMPLICIT_ZERO_BIT_PADDING@: 01008 (Warning) +warning_implicit_zero_bit_padding :: ByteString +warning_implicit_zero_bit_padding = "01008" + +-- |@WARNING_NULL_VALUE_ELIMINATED_IN_SET_FUNCTION@: 01003 (Warning) +warning_null_value_eliminated_in_set_function :: ByteString +warning_null_value_eliminated_in_set_function = "01003" + +-- |@WARNING_PRIVILEGE_NOT_GRANTED@: 01007 (Warning) +warning_privilege_not_granted :: ByteString +warning_privilege_not_granted = "01007" + +-- |@WARNING_PRIVILEGE_NOT_REVOKED@: 01006 (Warning) +warning_privilege_not_revoked :: ByteString +warning_privilege_not_revoked = "01006" + +-- |@WARNING_STRING_DATA_RIGHT_TRUNCATION@: 01004 (Warning) +warning_string_data_right_truncation :: ByteString +warning_string_data_right_truncation = "01004" + +-- |@WARNING_DEPRECATED_FEATURE@: 01P01 (Warning) +warning_deprecated_feature :: ByteString +warning_deprecated_feature = "01P01" + +-- |@NO_DATA@: 02000 (Warning) +no_data :: ByteString +no_data = "02000" + +-- |@NO_ADDITIONAL_DYNAMIC_RESULT_SETS_RETURNED@: 02001 (Warning) +no_additional_dynamic_result_sets_returned :: ByteString +no_additional_dynamic_result_sets_returned = "02001" + +-- |@SQL_STATEMENT_NOT_YET_COMPLETE@: 03000 (Error) +sql_statement_not_yet_complete :: ByteString +sql_statement_not_yet_complete = "03000" + +-- |@CONNECTION_EXCEPTION@: 08000 (Error) +connection_exception :: ByteString +connection_exception = "08000" + +-- |@CONNECTION_DOES_NOT_EXIST@: 08003 (Error) +connection_does_not_exist :: ByteString +connection_does_not_exist = "08003" + +-- |@CONNECTION_FAILURE@: 08006 (Error) +connection_failure :: ByteString +connection_failure = "08006" + +-- |@SQLCLIENT_UNABLE_TO_ESTABLISH_SQLCONNECTION@: 08001 (Error) +sqlclient_unable_to_establish_sqlconnection :: ByteString +sqlclient_unable_to_establish_sqlconnection = "08001" + +-- |@SQLSERVER_REJECTED_ESTABLISHMENT_OF_SQLCONNECTION@: 08004 (Error) +sqlserver_rejected_establishment_of_sqlconnection :: ByteString +sqlserver_rejected_establishment_of_sqlconnection = "08004" + +-- |@TRANSACTION_RESOLUTION_UNKNOWN@: 08007 (Error) +transaction_resolution_unknown :: ByteString +transaction_resolution_unknown = "08007" + +-- |@PROTOCOL_VIOLATION@: 08P01 (Error) +protocol_violation :: ByteString +protocol_violation = "08P01" + +-- |@TRIGGERED_ACTION_EXCEPTION@: 09000 (Error) +triggered_action_exception :: ByteString +triggered_action_exception = "09000" + +-- |@FEATURE_NOT_SUPPORTED@: 0A000 (Error) +feature_not_supported :: ByteString +feature_not_supported = "0A000" + +-- |@INVALID_TRANSACTION_INITIATION@: 0B000 (Error) +invalid_transaction_initiation :: ByteString +invalid_transaction_initiation = "0B000" + +-- |@LOCATOR_EXCEPTION@: 0F000 (Error) +locator_exception :: ByteString +locator_exception = "0F000" + +-- |@L_E_INVALID_SPECIFICATION@: 0F001 (Error) +invalid_locator_specification :: ByteString +invalid_locator_specification = "0F001" + +-- |@INVALID_GRANTOR@: 0L000 (Error) +invalid_grantor :: ByteString +invalid_grantor = "0L000" + +-- |@INVALID_GRANT_OPERATION@: 0LP01 (Error) +invalid_grant_operation :: ByteString +invalid_grant_operation = "0LP01" + +-- |@INVALID_ROLE_SPECIFICATION@: 0P000 (Error) +invalid_role_specification :: ByteString +invalid_role_specification = "0P000" + +-- |@DIAGNOSTICS_EXCEPTION@: 0Z000 (Error) +diagnostics_exception :: ByteString +diagnostics_exception = "0Z000" + +-- |@STACKED_DIAGNOSTICS_ACCESSED_WITHOUT_ACTIVE_HANDLER@: 0Z002 (Error) +stacked_diagnostics_accessed_without_active_handler :: ByteString +stacked_diagnostics_accessed_without_active_handler = "0Z002" + +-- |@CASE_NOT_FOUND@: 20000 (Error) +case_not_found :: ByteString +case_not_found = "20000" + +-- |@CARDINALITY_VIOLATION@: 21000 (Error) +cardinality_violation :: ByteString +cardinality_violation = "21000" + +-- |@DATA_EXCEPTION@: 22000 (Error) +data_exception :: ByteString +data_exception = "22000" + +-- |@ARRAY_ELEMENT_ERROR@: 2202E (Error) +_ARRAY_ELEMENT_ERROR :: ByteString +_ARRAY_ELEMENT_ERROR = "2202E" + +-- |@ARRAY_SUBSCRIPT_ERROR@: 2202E (Error) +array_subscript_error :: ByteString +array_subscript_error = "2202E" + +-- |@CHARACTER_NOT_IN_REPERTOIRE@: 22021 (Error) +character_not_in_repertoire :: ByteString +character_not_in_repertoire = "22021" + +-- |@DATETIME_FIELD_OVERFLOW@: 22008 (Error) +datetime_field_overflow :: ByteString +datetime_field_overflow = "22008" + +-- |@DATETIME_VALUE_OUT_OF_RANGE@: 22008 (Error) +_DATETIME_VALUE_OUT_OF_RANGE :: ByteString +_DATETIME_VALUE_OUT_OF_RANGE = "22008" + +-- |@DIVISION_BY_ZERO@: 22012 (Error) +division_by_zero :: ByteString +division_by_zero = "22012" + +-- |@ERROR_IN_ASSIGNMENT@: 22005 (Error) +error_in_assignment :: ByteString +error_in_assignment = "22005" + +-- |@ESCAPE_CHARACTER_CONFLICT@: 2200B (Error) +escape_character_conflict :: ByteString +escape_character_conflict = "2200B" + +-- |@INDICATOR_OVERFLOW@: 22022 (Error) +indicator_overflow :: ByteString +indicator_overflow = "22022" + +-- |@INTERVAL_FIELD_OVERFLOW@: 22015 (Error) +interval_field_overflow :: ByteString +interval_field_overflow = "22015" + +-- |@INVALID_ARGUMENT_FOR_LOG@: 2201E (Error) +invalid_argument_for_logarithm :: ByteString +invalid_argument_for_logarithm = "2201E" + +-- |@INVALID_ARGUMENT_FOR_NTILE@: 22014 (Error) +invalid_argument_for_ntile_function :: ByteString +invalid_argument_for_ntile_function = "22014" + +-- |@INVALID_ARGUMENT_FOR_NTH_VALUE@: 22016 (Error) +invalid_argument_for_nth_value_function :: ByteString +invalid_argument_for_nth_value_function = "22016" + +-- |@INVALID_ARGUMENT_FOR_POWER_FUNCTION@: 2201F (Error) +invalid_argument_for_power_function :: ByteString +invalid_argument_for_power_function = "2201F" + +-- |@INVALID_ARGUMENT_FOR_WIDTH_BUCKET_FUNCTION@: 2201G (Error) +invalid_argument_for_width_bucket_function :: ByteString +invalid_argument_for_width_bucket_function = "2201G" + +-- |@INVALID_CHARACTER_VALUE_FOR_CAST@: 22018 (Error) +invalid_character_value_for_cast :: ByteString +invalid_character_value_for_cast = "22018" + +-- |@INVALID_DATETIME_FORMAT@: 22007 (Error) +invalid_datetime_format :: ByteString +invalid_datetime_format = "22007" + +-- |@INVALID_ESCAPE_CHARACTER@: 22019 (Error) +invalid_escape_character :: ByteString +invalid_escape_character = "22019" + +-- |@INVALID_ESCAPE_OCTET@: 2200D (Error) +invalid_escape_octet :: ByteString +invalid_escape_octet = "2200D" + +-- |@INVALID_ESCAPE_SEQUENCE@: 22025 (Error) +invalid_escape_sequence :: ByteString +invalid_escape_sequence = "22025" + +-- |@NONSTANDARD_USE_OF_ESCAPE_CHARACTER@: 22P06 (Error) +nonstandard_use_of_escape_character :: ByteString +nonstandard_use_of_escape_character = "22P06" + +-- |@INVALID_INDICATOR_PARAMETER_VALUE@: 22010 (Error) +invalid_indicator_parameter_value :: ByteString +invalid_indicator_parameter_value = "22010" + +-- |@INVALID_PARAMETER_VALUE@: 22023 (Error) +invalid_parameter_value :: ByteString +invalid_parameter_value = "22023" + +-- |@INVALID_REGULAR_EXPRESSION@: 2201B (Error) +invalid_regular_expression :: ByteString +invalid_regular_expression = "2201B" + +-- |@INVALID_ROW_COUNT_IN_LIMIT_CLAUSE@: 2201W (Error) +invalid_row_count_in_limit_clause :: ByteString +invalid_row_count_in_limit_clause = "2201W" + +-- |@INVALID_ROW_COUNT_IN_RESULT_OFFSET_CLAUSE@: 2201X (Error) +invalid_row_count_in_result_offset_clause :: ByteString +invalid_row_count_in_result_offset_clause = "2201X" + +-- |@INVALID_TABLESAMPLE_ARGUMENT@: 2202H (Error) +invalid_tablesample_argument :: ByteString +invalid_tablesample_argument = "2202H" + +-- |@INVALID_TABLESAMPLE_REPEAT@: 2202G (Error) +invalid_tablesample_repeat :: ByteString +invalid_tablesample_repeat = "2202G" + +-- |@INVALID_TIME_ZONE_DISPLACEMENT_VALUE@: 22009 (Error) +invalid_time_zone_displacement_value :: ByteString +invalid_time_zone_displacement_value = "22009" + +-- |@INVALID_USE_OF_ESCAPE_CHARACTER@: 2200C (Error) +invalid_use_of_escape_character :: ByteString +invalid_use_of_escape_character = "2200C" + +-- |@MOST_SPECIFIC_TYPE_MISMATCH@: 2200G (Error) +most_specific_type_mismatch :: ByteString +most_specific_type_mismatch = "2200G" + +-- |@NULL_VALUE_NOT_ALLOWED@: 22004 (Error) +null_value_not_allowed :: ByteString +null_value_not_allowed = "22004" + +-- |@NULL_VALUE_NO_INDICATOR_PARAMETER@: 22002 (Error) +null_value_no_indicator_parameter :: ByteString +null_value_no_indicator_parameter = "22002" + +-- |@NUMERIC_VALUE_OUT_OF_RANGE@: 22003 (Error) +numeric_value_out_of_range :: ByteString +numeric_value_out_of_range = "22003" + +-- |@STRING_DATA_LENGTH_MISMATCH@: 22026 (Error) +string_data_length_mismatch :: ByteString +string_data_length_mismatch = "22026" + +-- |@STRING_DATA_RIGHT_TRUNCATION@: 22001 (Error) +string_data_right_truncation :: ByteString +string_data_right_truncation = "22001" + +-- |@SUBSTRING_ERROR@: 22011 (Error) +substring_error :: ByteString +substring_error = "22011" + +-- |@TRIM_ERROR@: 22027 (Error) +trim_error :: ByteString +trim_error = "22027" + +-- |@UNTERMINATED_C_STRING@: 22024 (Error) +unterminated_c_string :: ByteString +unterminated_c_string = "22024" + +-- |@ZERO_LENGTH_CHARACTER_STRING@: 2200F (Error) +zero_length_character_string :: ByteString +zero_length_character_string = "2200F" + +-- |@FLOATING_POINT_EXCEPTION@: 22P01 (Error) +floating_point_exception :: ByteString +floating_point_exception = "22P01" + +-- |@INVALID_TEXT_REPRESENTATION@: 22P02 (Error) +invalid_text_representation :: ByteString +invalid_text_representation = "22P02" + +-- |@INVALID_BINARY_REPRESENTATION@: 22P03 (Error) +invalid_binary_representation :: ByteString +invalid_binary_representation = "22P03" + +-- |@BAD_COPY_FILE_FORMAT@: 22P04 (Error) +bad_copy_file_format :: ByteString +bad_copy_file_format = "22P04" + +-- |@UNTRANSLATABLE_CHARACTER@: 22P05 (Error) +untranslatable_character :: ByteString +untranslatable_character = "22P05" + +-- |@NOT_AN_XML_DOCUMENT@: 2200L (Error) +not_an_xml_document :: ByteString +not_an_xml_document = "2200L" + +-- |@INVALID_XML_DOCUMENT@: 2200M (Error) +invalid_xml_document :: ByteString +invalid_xml_document = "2200M" + +-- |@INVALID_XML_CONTENT@: 2200N (Error) +invalid_xml_content :: ByteString +invalid_xml_content = "2200N" + +-- |@INVALID_XML_COMMENT@: 2200S (Error) +invalid_xml_comment :: ByteString +invalid_xml_comment = "2200S" + +-- |@INVALID_XML_PROCESSING_INSTRUCTION@: 2200T (Error) +invalid_xml_processing_instruction :: ByteString +invalid_xml_processing_instruction = "2200T" + +-- |@INTEGRITY_CONSTRAINT_VIOLATION@: 23000 (Error) +integrity_constraint_violation :: ByteString +integrity_constraint_violation = "23000" + +-- |@RESTRICT_VIOLATION@: 23001 (Error) +restrict_violation :: ByteString +restrict_violation = "23001" + +-- |@NOT_NULL_VIOLATION@: 23502 (Error) +not_null_violation :: ByteString +not_null_violation = "23502" + +-- |@FOREIGN_KEY_VIOLATION@: 23503 (Error) +foreign_key_violation :: ByteString +foreign_key_violation = "23503" + +-- |@UNIQUE_VIOLATION@: 23505 (Error) +unique_violation :: ByteString +unique_violation = "23505" + +-- |@CHECK_VIOLATION@: 23514 (Error) +check_violation :: ByteString +check_violation = "23514" + +-- |@EXCLUSION_VIOLATION@: 23P01 (Error) +exclusion_violation :: ByteString +exclusion_violation = "23P01" + +-- |@INVALID_CURSOR_STATE@: 24000 (Error) +invalid_cursor_state :: ByteString +invalid_cursor_state = "24000" + +-- |@INVALID_TRANSACTION_STATE@: 25000 (Error) +invalid_transaction_state :: ByteString +invalid_transaction_state = "25000" + +-- |@ACTIVE_SQL_TRANSACTION@: 25001 (Error) +active_sql_transaction :: ByteString +active_sql_transaction = "25001" + +-- |@BRANCH_TRANSACTION_ALREADY_ACTIVE@: 25002 (Error) +branch_transaction_already_active :: ByteString +branch_transaction_already_active = "25002" + +-- |@HELD_CURSOR_REQUIRES_SAME_ISOLATION_LEVEL@: 25008 (Error) +held_cursor_requires_same_isolation_level :: ByteString +held_cursor_requires_same_isolation_level = "25008" + +-- |@INAPPROPRIATE_ACCESS_MODE_FOR_BRANCH_TRANSACTION@: 25003 (Error) +inappropriate_access_mode_for_branch_transaction :: ByteString +inappropriate_access_mode_for_branch_transaction = "25003" + +-- |@INAPPROPRIATE_ISOLATION_LEVEL_FOR_BRANCH_TRANSACTION@: 25004 (Error) +inappropriate_isolation_level_for_branch_transaction :: ByteString +inappropriate_isolation_level_for_branch_transaction = "25004" + +-- |@NO_ACTIVE_SQL_TRANSACTION_FOR_BRANCH_TRANSACTION@: 25005 (Error) +no_active_sql_transaction_for_branch_transaction :: ByteString +no_active_sql_transaction_for_branch_transaction = "25005" + +-- |@READ_ONLY_SQL_TRANSACTION@: 25006 (Error) +read_only_sql_transaction :: ByteString +read_only_sql_transaction = "25006" + +-- |@SCHEMA_AND_DATA_STATEMENT_MIXING_NOT_SUPPORTED@: 25007 (Error) +schema_and_data_statement_mixing_not_supported :: ByteString +schema_and_data_statement_mixing_not_supported = "25007" + +-- |@NO_ACTIVE_SQL_TRANSACTION@: 25P01 (Error) +no_active_sql_transaction :: ByteString +no_active_sql_transaction = "25P01" + +-- |@IN_FAILED_SQL_TRANSACTION@: 25P02 (Error) +in_failed_sql_transaction :: ByteString +in_failed_sql_transaction = "25P02" + +-- |@INVALID_SQL_STATEMENT_NAME@: 26000 (Error) +invalid_sql_statement_name :: ByteString +invalid_sql_statement_name = "26000" + +-- |@TRIGGERED_DATA_CHANGE_VIOLATION@: 27000 (Error) +triggered_data_change_violation :: ByteString +triggered_data_change_violation = "27000" + +-- |@INVALID_AUTHORIZATION_SPECIFICATION@: 28000 (Error) +invalid_authorization_specification :: ByteString +invalid_authorization_specification = "28000" + +-- |@INVALID_PASSWORD@: 28P01 (Error) +invalid_password :: ByteString +invalid_password = "28P01" + +-- |@DEPENDENT_PRIVILEGE_DESCRIPTORS_STILL_EXIST@: 2B000 (Error) +dependent_privilege_descriptors_still_exist :: ByteString +dependent_privilege_descriptors_still_exist = "2B000" + +-- |@DEPENDENT_OBJECTS_STILL_EXIST@: 2BP01 (Error) +dependent_objects_still_exist :: ByteString +dependent_objects_still_exist = "2BP01" + +-- |@INVALID_TRANSACTION_TERMINATION@: 2D000 (Error) +invalid_transaction_termination :: ByteString +invalid_transaction_termination = "2D000" + +-- |@SQL_ROUTINE_EXCEPTION@: 2F000 (Error) +sql_routine_exception :: ByteString +sql_routine_exception = "2F000" + +-- |@S_R_E_FUNCTION_EXECUTED_NO_RETURN_STATEMENT@: 2F005 (Error) +s_r_e_function_executed_no_return_statement :: ByteString +s_r_e_function_executed_no_return_statement = "2F005" + +-- |@S_R_E_MODIFYING_SQL_DATA_NOT_PERMITTED@: 2F002 (Error) +s_r_e_modifying_sql_data_not_permitted :: ByteString +s_r_e_modifying_sql_data_not_permitted = "2F002" + +-- |@S_R_E_PROHIBITED_SQL_STATEMENT_ATTEMPTED@: 2F003 (Error) +s_r_e_prohibited_sql_statement_attempted :: ByteString +s_r_e_prohibited_sql_statement_attempted = "2F003" + +-- |@S_R_E_READING_SQL_DATA_NOT_PERMITTED@: 2F004 (Error) +s_r_e_reading_sql_data_not_permitted :: ByteString +s_r_e_reading_sql_data_not_permitted = "2F004" + +-- |@INVALID_CURSOR_NAME@: 34000 (Error) +invalid_cursor_name :: ByteString +invalid_cursor_name = "34000" + +-- |@EXTERNAL_ROUTINE_EXCEPTION@: 38000 (Error) +external_routine_exception :: ByteString +external_routine_exception = "38000" + +-- |@E_R_E_CONTAINING_SQL_NOT_PERMITTED@: 38001 (Error) +e_r_e_containing_sql_not_permitted :: ByteString +e_r_e_containing_sql_not_permitted = "38001" + +-- |@E_R_E_MODIFYING_SQL_DATA_NOT_PERMITTED@: 38002 (Error) +e_r_e_modifying_sql_data_not_permitted :: ByteString +e_r_e_modifying_sql_data_not_permitted = "38002" + +-- |@E_R_E_PROHIBITED_SQL_STATEMENT_ATTEMPTED@: 38003 (Error) +e_r_e_prohibited_sql_statement_attempted :: ByteString +e_r_e_prohibited_sql_statement_attempted = "38003" + +-- |@E_R_E_READING_SQL_DATA_NOT_PERMITTED@: 38004 (Error) +e_r_e_reading_sql_data_not_permitted :: ByteString +e_r_e_reading_sql_data_not_permitted = "38004" + +-- |@EXTERNAL_ROUTINE_INVOCATION_EXCEPTION@: 39000 (Error) +external_routine_invocation_exception :: ByteString +external_routine_invocation_exception = "39000" + +-- |@E_R_I_E_INVALID_SQLSTATE_RETURNED@: 39001 (Error) +e_r_i_e_invalid_sqlstate_returned :: ByteString +e_r_i_e_invalid_sqlstate_returned = "39001" + +-- |@E_R_I_E_NULL_VALUE_NOT_ALLOWED@: 39004 (Error) +e_r_i_e_null_value_not_allowed :: ByteString +e_r_i_e_null_value_not_allowed = "39004" + +-- |@E_R_I_E_TRIGGER_PROTOCOL_VIOLATED@: 39P01 (Error) +e_r_i_e_trigger_protocol_violated :: ByteString +e_r_i_e_trigger_protocol_violated = "39P01" + +-- |@E_R_I_E_SRF_PROTOCOL_VIOLATED@: 39P02 (Error) +e_r_i_e_srf_protocol_violated :: ByteString +e_r_i_e_srf_protocol_violated = "39P02" + +-- |@E_R_I_E_EVENT_TRIGGER_PROTOCOL_VIOLATED@: 39P03 (Error) +e_r_i_e_event_trigger_protocol_violated :: ByteString +e_r_i_e_event_trigger_protocol_violated = "39P03" + +-- |@SAVEPOINT_EXCEPTION@: 3B000 (Error) +savepoint_exception :: ByteString +savepoint_exception = "3B000" + +-- |@S_E_INVALID_SPECIFICATION@: 3B001 (Error) +invalid_savepoint_specification :: ByteString +invalid_savepoint_specification = "3B001" + +-- |@INVALID_CATALOG_NAME@: 3D000 (Error) +invalid_catalog_name :: ByteString +invalid_catalog_name = "3D000" + +-- |@INVALID_SCHEMA_NAME@: 3F000 (Error) +invalid_schema_name :: ByteString +invalid_schema_name = "3F000" + +-- |@TRANSACTION_ROLLBACK@: 40000 (Error) +transaction_rollback :: ByteString +transaction_rollback = "40000" + +-- |@T_R_INTEGRITY_CONSTRAINT_VIOLATION@: 40002 (Error) +transaction_integrity_constraint_violation :: ByteString +transaction_integrity_constraint_violation = "40002" + +-- |@T_R_SERIALIZATION_FAILURE@: 40001 (Error) +serialization_failure :: ByteString +serialization_failure = "40001" + +-- |@T_R_STATEMENT_COMPLETION_UNKNOWN@: 40003 (Error) +statement_completion_unknown :: ByteString +statement_completion_unknown = "40003" + +-- |@T_R_DEADLOCK_DETECTED@: 40P01 (Error) +deadlock_detected :: ByteString +deadlock_detected = "40P01" + +-- |@SYNTAX_ERROR_OR_ACCESS_RULE_VIOLATION@: 42000 (Error) +syntax_error_or_access_rule_violation :: ByteString +syntax_error_or_access_rule_violation = "42000" + +-- |@SYNTAX_ERROR@: 42601 (Error) +syntax_error :: ByteString +syntax_error = "42601" + +-- |@INSUFFICIENT_PRIVILEGE@: 42501 (Error) +insufficient_privilege :: ByteString +insufficient_privilege = "42501" + +-- |@CANNOT_COERCE@: 42846 (Error) +cannot_coerce :: ByteString +cannot_coerce = "42846" + +-- |@GROUPING_ERROR@: 42803 (Error) +grouping_error :: ByteString +grouping_error = "42803" + +-- |@WINDOWING_ERROR@: 42P20 (Error) +windowing_error :: ByteString +windowing_error = "42P20" + +-- |@INVALID_RECURSION@: 42P19 (Error) +invalid_recursion :: ByteString +invalid_recursion = "42P19" + +-- |@INVALID_FOREIGN_KEY@: 42830 (Error) +invalid_foreign_key :: ByteString +invalid_foreign_key = "42830" + +-- |@INVALID_NAME@: 42602 (Error) +invalid_name :: ByteString +invalid_name = "42602" + +-- |@NAME_TOO_LONG@: 42622 (Error) +name_too_long :: ByteString +name_too_long = "42622" + +-- |@RESERVED_NAME@: 42939 (Error) +reserved_name :: ByteString +reserved_name = "42939" + +-- |@DATATYPE_MISMATCH@: 42804 (Error) +datatype_mismatch :: ByteString +datatype_mismatch = "42804" + +-- |@INDETERMINATE_DATATYPE@: 42P18 (Error) +indeterminate_datatype :: ByteString +indeterminate_datatype = "42P18" + +-- |@COLLATION_MISMATCH@: 42P21 (Error) +collation_mismatch :: ByteString +collation_mismatch = "42P21" + +-- |@INDETERMINATE_COLLATION@: 42P22 (Error) +indeterminate_collation :: ByteString +indeterminate_collation = "42P22" + +-- |@WRONG_OBJECT_TYPE@: 42809 (Error) +wrong_object_type :: ByteString +wrong_object_type = "42809" + +-- |@UNDEFINED_COLUMN@: 42703 (Error) +undefined_column :: ByteString +undefined_column = "42703" + +-- |@UNDEFINED_CURSOR@: 34000 (Error) +_UNDEFINED_CURSOR :: ByteString +_UNDEFINED_CURSOR = "34000" + +-- |@UNDEFINED_DATABASE@: 3D000 (Error) +_UNDEFINED_DATABASE :: ByteString +_UNDEFINED_DATABASE = "3D000" + +-- |@UNDEFINED_FUNCTION@: 42883 (Error) +undefined_function :: ByteString +undefined_function = "42883" + +-- |@UNDEFINED_PSTATEMENT@: 26000 (Error) +_UNDEFINED_PSTATEMENT :: ByteString +_UNDEFINED_PSTATEMENT = "26000" + +-- |@UNDEFINED_SCHEMA@: 3F000 (Error) +_UNDEFINED_SCHEMA :: ByteString +_UNDEFINED_SCHEMA = "3F000" + +-- |@UNDEFINED_TABLE@: 42P01 (Error) +undefined_table :: ByteString +undefined_table = "42P01" + +-- |@UNDEFINED_PARAMETER@: 42P02 (Error) +undefined_parameter :: ByteString +undefined_parameter = "42P02" + +-- |@UNDEFINED_OBJECT@: 42704 (Error) +undefined_object :: ByteString +undefined_object = "42704" + +-- |@DUPLICATE_COLUMN@: 42701 (Error) +duplicate_column :: ByteString +duplicate_column = "42701" + +-- |@DUPLICATE_CURSOR@: 42P03 (Error) +duplicate_cursor :: ByteString +duplicate_cursor = "42P03" + +-- |@DUPLICATE_DATABASE@: 42P04 (Error) +duplicate_database :: ByteString +duplicate_database = "42P04" + +-- |@DUPLICATE_FUNCTION@: 42723 (Error) +duplicate_function :: ByteString +duplicate_function = "42723" + +-- |@DUPLICATE_PSTATEMENT@: 42P05 (Error) +duplicate_prepared_statement :: ByteString +duplicate_prepared_statement = "42P05" + +-- |@DUPLICATE_SCHEMA@: 42P06 (Error) +duplicate_schema :: ByteString +duplicate_schema = "42P06" + +-- |@DUPLICATE_TABLE@: 42P07 (Error) +duplicate_table :: ByteString +duplicate_table = "42P07" + +-- |@DUPLICATE_ALIAS@: 42712 (Error) +duplicate_alias :: ByteString +duplicate_alias = "42712" + +-- |@DUPLICATE_OBJECT@: 42710 (Error) +duplicate_object :: ByteString +duplicate_object = "42710" + +-- |@AMBIGUOUS_COLUMN@: 42702 (Error) +ambiguous_column :: ByteString +ambiguous_column = "42702" + +-- |@AMBIGUOUS_FUNCTION@: 42725 (Error) +ambiguous_function :: ByteString +ambiguous_function = "42725" + +-- |@AMBIGUOUS_PARAMETER@: 42P08 (Error) +ambiguous_parameter :: ByteString +ambiguous_parameter = "42P08" + +-- |@AMBIGUOUS_ALIAS@: 42P09 (Error) +ambiguous_alias :: ByteString +ambiguous_alias = "42P09" + +-- |@INVALID_COLUMN_REFERENCE@: 42P10 (Error) +invalid_column_reference :: ByteString +invalid_column_reference = "42P10" + +-- |@INVALID_COLUMN_DEFINITION@: 42611 (Error) +invalid_column_definition :: ByteString +invalid_column_definition = "42611" + +-- |@INVALID_CURSOR_DEFINITION@: 42P11 (Error) +invalid_cursor_definition :: ByteString +invalid_cursor_definition = "42P11" + +-- |@INVALID_DATABASE_DEFINITION@: 42P12 (Error) +invalid_database_definition :: ByteString +invalid_database_definition = "42P12" + +-- |@INVALID_FUNCTION_DEFINITION@: 42P13 (Error) +invalid_function_definition :: ByteString +invalid_function_definition = "42P13" + +-- |@INVALID_PSTATEMENT_DEFINITION@: 42P14 (Error) +invalid_prepared_statement_definition :: ByteString +invalid_prepared_statement_definition = "42P14" + +-- |@INVALID_SCHEMA_DEFINITION@: 42P15 (Error) +invalid_schema_definition :: ByteString +invalid_schema_definition = "42P15" + +-- |@INVALID_TABLE_DEFINITION@: 42P16 (Error) +invalid_table_definition :: ByteString +invalid_table_definition = "42P16" + +-- |@INVALID_OBJECT_DEFINITION@: 42P17 (Error) +invalid_object_definition :: ByteString +invalid_object_definition = "42P17" + +-- |@WITH_CHECK_OPTION_VIOLATION@: 44000 (Error) +with_check_option_violation :: ByteString +with_check_option_violation = "44000" + +-- |@INSUFFICIENT_RESOURCES@: 53000 (Error) +insufficient_resources :: ByteString +insufficient_resources = "53000" + +-- |@DISK_FULL@: 53100 (Error) +disk_full :: ByteString +disk_full = "53100" + +-- |@OUT_OF_MEMORY@: 53200 (Error) +out_of_memory :: ByteString +out_of_memory = "53200" + +-- |@TOO_MANY_CONNECTIONS@: 53300 (Error) +too_many_connections :: ByteString +too_many_connections = "53300" + +-- |@CONFIGURATION_LIMIT_EXCEEDED@: 53400 (Error) +configuration_limit_exceeded :: ByteString +configuration_limit_exceeded = "53400" + +-- |@PROGRAM_LIMIT_EXCEEDED@: 54000 (Error) +program_limit_exceeded :: ByteString +program_limit_exceeded = "54000" + +-- |@STATEMENT_TOO_COMPLEX@: 54001 (Error) +statement_too_complex :: ByteString +statement_too_complex = "54001" + +-- |@TOO_MANY_COLUMNS@: 54011 (Error) +too_many_columns :: ByteString +too_many_columns = "54011" + +-- |@TOO_MANY_ARGUMENTS@: 54023 (Error) +too_many_arguments :: ByteString +too_many_arguments = "54023" + +-- |@OBJECT_NOT_IN_PREREQUISITE_STATE@: 55000 (Error) +object_not_in_prerequisite_state :: ByteString +object_not_in_prerequisite_state = "55000" + +-- |@OBJECT_IN_USE@: 55006 (Error) +object_in_use :: ByteString +object_in_use = "55006" + +-- |@CANT_CHANGE_RUNTIME_PARAM@: 55P02 (Error) +cant_change_runtime_param :: ByteString +cant_change_runtime_param = "55P02" + +-- |@LOCK_NOT_AVAILABLE@: 55P03 (Error) +lock_not_available :: ByteString +lock_not_available = "55P03" + +-- |@OPERATOR_INTERVENTION@: 57000 (Error) +operator_intervention :: ByteString +operator_intervention = "57000" + +-- |@QUERY_CANCELED@: 57014 (Error) +query_canceled :: ByteString +query_canceled = "57014" + +-- |@ADMIN_SHUTDOWN@: 57P01 (Error) +admin_shutdown :: ByteString +admin_shutdown = "57P01" + +-- |@CRASH_SHUTDOWN@: 57P02 (Error) +crash_shutdown :: ByteString +crash_shutdown = "57P02" + +-- |@CANNOT_CONNECT_NOW@: 57P03 (Error) +cannot_connect_now :: ByteString +cannot_connect_now = "57P03" + +-- |@DATABASE_DROPPED@: 57P04 (Error) +database_dropped :: ByteString +database_dropped = "57P04" + +-- |@SYSTEM_ERROR@: 58000 (Error) +system_error :: ByteString +system_error = "58000" + +-- |@IO_ERROR@: 58030 (Error) +io_error :: ByteString +io_error = "58030" + +-- |@UNDEFINED_FILE@: 58P01 (Error) +undefined_file :: ByteString +undefined_file = "58P01" + +-- |@DUPLICATE_FILE@: 58P02 (Error) +duplicate_file :: ByteString +duplicate_file = "58P02" + +-- |@CONFIG_FILE_ERROR@: F0000 (Error) +config_file_error :: ByteString +config_file_error = "F0000" + +-- |@LOCK_FILE_EXISTS@: F0001 (Error) +lock_file_exists :: ByteString +lock_file_exists = "F0001" + +-- |@FDW_ERROR@: HV000 (Error) +fdw_error :: ByteString +fdw_error = "HV000" + +-- |@FDW_COLUMN_NAME_NOT_FOUND@: HV005 (Error) +fdw_column_name_not_found :: ByteString +fdw_column_name_not_found = "HV005" + +-- |@FDW_DYNAMIC_PARAMETER_VALUE_NEEDED@: HV002 (Error) +fdw_dynamic_parameter_value_needed :: ByteString +fdw_dynamic_parameter_value_needed = "HV002" + +-- |@FDW_FUNCTION_SEQUENCE_ERROR@: HV010 (Error) +fdw_function_sequence_error :: ByteString +fdw_function_sequence_error = "HV010" + +-- |@FDW_INCONSISTENT_DESCRIPTOR_INFORMATION@: HV021 (Error) +fdw_inconsistent_descriptor_information :: ByteString +fdw_inconsistent_descriptor_information = "HV021" + +-- |@FDW_INVALID_ATTRIBUTE_VALUE@: HV024 (Error) +fdw_invalid_attribute_value :: ByteString +fdw_invalid_attribute_value = "HV024" + +-- |@FDW_INVALID_COLUMN_NAME@: HV007 (Error) +fdw_invalid_column_name :: ByteString +fdw_invalid_column_name = "HV007" + +-- |@FDW_INVALID_COLUMN_NUMBER@: HV008 (Error) +fdw_invalid_column_number :: ByteString +fdw_invalid_column_number = "HV008" + +-- |@FDW_INVALID_DATA_TYPE@: HV004 (Error) +fdw_invalid_data_type :: ByteString +fdw_invalid_data_type = "HV004" + +-- |@FDW_INVALID_DATA_TYPE_DESCRIPTORS@: HV006 (Error) +fdw_invalid_data_type_descriptors :: ByteString +fdw_invalid_data_type_descriptors = "HV006" + +-- |@FDW_INVALID_DESCRIPTOR_FIELD_IDENTIFIER@: HV091 (Error) +fdw_invalid_descriptor_field_identifier :: ByteString +fdw_invalid_descriptor_field_identifier = "HV091" + +-- |@FDW_INVALID_HANDLE@: HV00B (Error) +fdw_invalid_handle :: ByteString +fdw_invalid_handle = "HV00B" + +-- |@FDW_INVALID_OPTION_INDEX@: HV00C (Error) +fdw_invalid_option_index :: ByteString +fdw_invalid_option_index = "HV00C" + +-- |@FDW_INVALID_OPTION_NAME@: HV00D (Error) +fdw_invalid_option_name :: ByteString +fdw_invalid_option_name = "HV00D" + +-- |@FDW_INVALID_STRING_LENGTH_OR_BUFFER_LENGTH@: HV090 (Error) +fdw_invalid_string_length_or_buffer_length :: ByteString +fdw_invalid_string_length_or_buffer_length = "HV090" + +-- |@FDW_INVALID_STRING_FORMAT@: HV00A (Error) +fdw_invalid_string_format :: ByteString +fdw_invalid_string_format = "HV00A" + +-- |@FDW_INVALID_USE_OF_NULL_POINTER@: HV009 (Error) +fdw_invalid_use_of_null_pointer :: ByteString +fdw_invalid_use_of_null_pointer = "HV009" + +-- |@FDW_TOO_MANY_HANDLES@: HV014 (Error) +fdw_too_many_handles :: ByteString +fdw_too_many_handles = "HV014" + +-- |@FDW_OUT_OF_MEMORY@: HV001 (Error) +fdw_out_of_memory :: ByteString +fdw_out_of_memory = "HV001" + +-- |@FDW_NO_SCHEMAS@: HV00P (Error) +fdw_no_schemas :: ByteString +fdw_no_schemas = "HV00P" + +-- |@FDW_OPTION_NAME_NOT_FOUND@: HV00J (Error) +fdw_option_name_not_found :: ByteString +fdw_option_name_not_found = "HV00J" + +-- |@FDW_REPLY_HANDLE@: HV00K (Error) +fdw_reply_handle :: ByteString +fdw_reply_handle = "HV00K" + +-- |@FDW_SCHEMA_NOT_FOUND@: HV00Q (Error) +fdw_schema_not_found :: ByteString +fdw_schema_not_found = "HV00Q" + +-- |@FDW_TABLE_NOT_FOUND@: HV00R (Error) +fdw_table_not_found :: ByteString +fdw_table_not_found = "HV00R" + +-- |@FDW_UNABLE_TO_CREATE_EXECUTION@: HV00L (Error) +fdw_unable_to_create_execution :: ByteString +fdw_unable_to_create_execution = "HV00L" + +-- |@FDW_UNABLE_TO_CREATE_REPLY@: HV00M (Error) +fdw_unable_to_create_reply :: ByteString +fdw_unable_to_create_reply = "HV00M" + +-- |@FDW_UNABLE_TO_ESTABLISH_CONNECTION@: HV00N (Error) +fdw_unable_to_establish_connection :: ByteString +fdw_unable_to_establish_connection = "HV00N" + +-- |@PLPGSQL_ERROR@: P0000 (Error) +plpgsql_error :: ByteString +plpgsql_error = "P0000" + +-- |@RAISE_EXCEPTION@: P0001 (Error) +raise_exception :: ByteString +raise_exception = "P0001" + +-- |@NO_DATA_FOUND@: P0002 (Error) +no_data_found :: ByteString +no_data_found = "P0002" + +-- |@TOO_MANY_ROWS@: P0003 (Error) +too_many_rows :: ByteString +too_many_rows = "P0003" + +-- |@ASSERT_FAILURE@: P0004 (Error) +assert_failure :: ByteString +assert_failure = "P0004" + +-- |@INTERNAL_ERROR@: XX000 (Error) +internal_error :: ByteString +internal_error = "XX000" + +-- |@DATA_CORRUPTED@: XX001 (Error) +data_corrupted :: ByteString +data_corrupted = "XX001" + +-- |@INDEX_CORRUPTED@: XX002 (Error) +index_corrupted :: ByteString +index_corrupted = "XX002" + +-- |All known error code names by code. +names :: Map ByteString String +names = fromDistinctAscList + [(successful_completion,"successful_completion") + ,(warning,"warning") + ,(warning_null_value_eliminated_in_set_function,"null_value_eliminated_in_set_function") + ,(warning_string_data_right_truncation,"string_data_right_truncation") + ,(warning_privilege_not_revoked,"privilege_not_revoked") + ,(warning_privilege_not_granted,"privilege_not_granted") + ,(warning_implicit_zero_bit_padding,"implicit_zero_bit_padding") + ,(warning_dynamic_result_sets_returned,"dynamic_result_sets_returned") + ,(warning_deprecated_feature,"deprecated_feature") + ,(no_data,"no_data") + ,(no_additional_dynamic_result_sets_returned,"no_additional_dynamic_result_sets_returned") + ,(sql_statement_not_yet_complete,"sql_statement_not_yet_complete") + ,(connection_exception,"connection_exception") + ,(sqlclient_unable_to_establish_sqlconnection,"sqlclient_unable_to_establish_sqlconnection") + ,(connection_does_not_exist,"connection_does_not_exist") + ,(sqlserver_rejected_establishment_of_sqlconnection,"sqlserver_rejected_establishment_of_sqlconnection") + ,(connection_failure,"connection_failure") + ,(transaction_resolution_unknown,"transaction_resolution_unknown") + ,(protocol_violation,"protocol_violation") + ,(triggered_action_exception,"triggered_action_exception") + ,(feature_not_supported,"feature_not_supported") + ,(invalid_transaction_initiation,"invalid_transaction_initiation") + ,(locator_exception,"locator_exception") + ,(invalid_locator_specification,"invalid_locator_specification") + ,(invalid_grantor,"invalid_grantor") + ,(invalid_grant_operation,"invalid_grant_operation") + ,(invalid_role_specification,"invalid_role_specification") + ,(diagnostics_exception,"diagnostics_exception") + ,(stacked_diagnostics_accessed_without_active_handler,"stacked_diagnostics_accessed_without_active_handler") + ,(case_not_found,"case_not_found") + ,(cardinality_violation,"cardinality_violation") + ,(data_exception,"data_exception") + ,(string_data_right_truncation,"string_data_right_truncation") + ,(null_value_no_indicator_parameter,"null_value_no_indicator_parameter") + ,(numeric_value_out_of_range,"numeric_value_out_of_range") + ,(null_value_not_allowed,"null_value_not_allowed") + ,(error_in_assignment,"error_in_assignment") + ,(invalid_datetime_format,"invalid_datetime_format") + ,(datetime_field_overflow,"datetime_field_overflow") + ,(_DATETIME_VALUE_OUT_OF_RANGE,"DATETIME_VALUE_OUT_OF_RANGE") + ,(invalid_time_zone_displacement_value,"invalid_time_zone_displacement_value") + ,(escape_character_conflict,"escape_character_conflict") + ,(invalid_use_of_escape_character,"invalid_use_of_escape_character") + ,(invalid_escape_octet,"invalid_escape_octet") + ,(zero_length_character_string,"zero_length_character_string") + ,(most_specific_type_mismatch,"most_specific_type_mismatch") + ,(not_an_xml_document,"not_an_xml_document") + ,(invalid_xml_document,"invalid_xml_document") + ,(invalid_xml_content,"invalid_xml_content") + ,(invalid_xml_comment,"invalid_xml_comment") + ,(invalid_xml_processing_instruction,"invalid_xml_processing_instruction") + ,(invalid_indicator_parameter_value,"invalid_indicator_parameter_value") + ,(substring_error,"substring_error") + ,(division_by_zero,"division_by_zero") + ,(invalid_argument_for_ntile_function,"invalid_argument_for_ntile_function") + ,(interval_field_overflow,"interval_field_overflow") + ,(invalid_argument_for_nth_value_function,"invalid_argument_for_nth_value_function") + ,(invalid_character_value_for_cast,"invalid_character_value_for_cast") + ,(invalid_escape_character,"invalid_escape_character") + ,(invalid_regular_expression,"invalid_regular_expression") + ,(invalid_argument_for_logarithm,"invalid_argument_for_logarithm") + ,(invalid_argument_for_power_function,"invalid_argument_for_power_function") + ,(invalid_argument_for_width_bucket_function,"invalid_argument_for_width_bucket_function") + ,(invalid_row_count_in_limit_clause,"invalid_row_count_in_limit_clause") + ,(invalid_row_count_in_result_offset_clause,"invalid_row_count_in_result_offset_clause") + ,(character_not_in_repertoire,"character_not_in_repertoire") + ,(indicator_overflow,"indicator_overflow") + ,(invalid_parameter_value,"invalid_parameter_value") + ,(unterminated_c_string,"unterminated_c_string") + ,(invalid_escape_sequence,"invalid_escape_sequence") + ,(string_data_length_mismatch,"string_data_length_mismatch") + ,(trim_error,"trim_error") + ,(_ARRAY_ELEMENT_ERROR,"ARRAY_ELEMENT_ERROR") + ,(array_subscript_error,"array_subscript_error") + ,(invalid_tablesample_repeat,"invalid_tablesample_repeat") + ,(invalid_tablesample_argument,"invalid_tablesample_argument") + ,(floating_point_exception,"floating_point_exception") + ,(invalid_text_representation,"invalid_text_representation") + ,(invalid_binary_representation,"invalid_binary_representation") + ,(bad_copy_file_format,"bad_copy_file_format") + ,(untranslatable_character,"untranslatable_character") + ,(nonstandard_use_of_escape_character,"nonstandard_use_of_escape_character") + ,(integrity_constraint_violation,"integrity_constraint_violation") + ,(restrict_violation,"restrict_violation") + ,(not_null_violation,"not_null_violation") + ,(foreign_key_violation,"foreign_key_violation") + ,(unique_violation,"unique_violation") + ,(check_violation,"check_violation") + ,(exclusion_violation,"exclusion_violation") + ,(invalid_cursor_state,"invalid_cursor_state") + ,(invalid_transaction_state,"invalid_transaction_state") + ,(active_sql_transaction,"active_sql_transaction") + ,(branch_transaction_already_active,"branch_transaction_already_active") + ,(inappropriate_access_mode_for_branch_transaction,"inappropriate_access_mode_for_branch_transaction") + ,(inappropriate_isolation_level_for_branch_transaction,"inappropriate_isolation_level_for_branch_transaction") + ,(no_active_sql_transaction_for_branch_transaction,"no_active_sql_transaction_for_branch_transaction") + ,(read_only_sql_transaction,"read_only_sql_transaction") + ,(schema_and_data_statement_mixing_not_supported,"schema_and_data_statement_mixing_not_supported") + ,(held_cursor_requires_same_isolation_level,"held_cursor_requires_same_isolation_level") + ,(no_active_sql_transaction,"no_active_sql_transaction") + ,(in_failed_sql_transaction,"in_failed_sql_transaction") + ,(invalid_sql_statement_name,"invalid_sql_statement_name") + ,(_UNDEFINED_PSTATEMENT,"UNDEFINED_PSTATEMENT") + ,(triggered_data_change_violation,"triggered_data_change_violation") + ,(invalid_authorization_specification,"invalid_authorization_specification") + ,(invalid_password,"invalid_password") + ,(dependent_privilege_descriptors_still_exist,"dependent_privilege_descriptors_still_exist") + ,(dependent_objects_still_exist,"dependent_objects_still_exist") + ,(invalid_transaction_termination,"invalid_transaction_termination") + ,(sql_routine_exception,"sql_routine_exception") + ,(s_r_e_modifying_sql_data_not_permitted,"modifying_sql_data_not_permitted") + ,(s_r_e_prohibited_sql_statement_attempted,"prohibited_sql_statement_attempted") + ,(s_r_e_reading_sql_data_not_permitted,"reading_sql_data_not_permitted") + ,(s_r_e_function_executed_no_return_statement,"function_executed_no_return_statement") + ,(invalid_cursor_name,"invalid_cursor_name") + ,(_UNDEFINED_CURSOR,"UNDEFINED_CURSOR") + ,(external_routine_exception,"external_routine_exception") + ,(e_r_e_containing_sql_not_permitted,"containing_sql_not_permitted") + ,(e_r_e_modifying_sql_data_not_permitted,"modifying_sql_data_not_permitted") + ,(e_r_e_prohibited_sql_statement_attempted,"prohibited_sql_statement_attempted") + ,(e_r_e_reading_sql_data_not_permitted,"reading_sql_data_not_permitted") + ,(external_routine_invocation_exception,"external_routine_invocation_exception") + ,(e_r_i_e_invalid_sqlstate_returned,"invalid_sqlstate_returned") + ,(e_r_i_e_null_value_not_allowed,"null_value_not_allowed") + ,(e_r_i_e_trigger_protocol_violated,"trigger_protocol_violated") + ,(e_r_i_e_srf_protocol_violated,"srf_protocol_violated") + ,(e_r_i_e_event_trigger_protocol_violated,"event_trigger_protocol_violated") + ,(savepoint_exception,"savepoint_exception") + ,(invalid_savepoint_specification,"invalid_savepoint_specification") + ,(invalid_catalog_name,"invalid_catalog_name") + ,(_UNDEFINED_DATABASE,"UNDEFINED_DATABASE") + ,(invalid_schema_name,"invalid_schema_name") + ,(_UNDEFINED_SCHEMA,"UNDEFINED_SCHEMA") + ,(transaction_rollback,"transaction_rollback") + ,(serialization_failure,"serialization_failure") + ,(transaction_integrity_constraint_violation,"transaction_integrity_constraint_violation") + ,(statement_completion_unknown,"statement_completion_unknown") + ,(deadlock_detected,"deadlock_detected") + ,(syntax_error_or_access_rule_violation,"syntax_error_or_access_rule_violation") + ,(insufficient_privilege,"insufficient_privilege") + ,(syntax_error,"syntax_error") + ,(invalid_name,"invalid_name") + ,(invalid_column_definition,"invalid_column_definition") + ,(name_too_long,"name_too_long") + ,(duplicate_column,"duplicate_column") + ,(ambiguous_column,"ambiguous_column") + ,(undefined_column,"undefined_column") + ,(undefined_object,"undefined_object") + ,(duplicate_object,"duplicate_object") + ,(duplicate_alias,"duplicate_alias") + ,(duplicate_function,"duplicate_function") + ,(ambiguous_function,"ambiguous_function") + ,(grouping_error,"grouping_error") + ,(datatype_mismatch,"datatype_mismatch") + ,(wrong_object_type,"wrong_object_type") + ,(invalid_foreign_key,"invalid_foreign_key") + ,(cannot_coerce,"cannot_coerce") + ,(undefined_function,"undefined_function") + ,(reserved_name,"reserved_name") + ,(undefined_table,"undefined_table") + ,(undefined_parameter,"undefined_parameter") + ,(duplicate_cursor,"duplicate_cursor") + ,(duplicate_database,"duplicate_database") + ,(duplicate_prepared_statement,"duplicate_prepared_statement") + ,(duplicate_schema,"duplicate_schema") + ,(duplicate_table,"duplicate_table") + ,(ambiguous_parameter,"ambiguous_parameter") + ,(ambiguous_alias,"ambiguous_alias") + ,(invalid_column_reference,"invalid_column_reference") + ,(invalid_cursor_definition,"invalid_cursor_definition") + ,(invalid_database_definition,"invalid_database_definition") + ,(invalid_function_definition,"invalid_function_definition") + ,(invalid_prepared_statement_definition,"invalid_prepared_statement_definition") + ,(invalid_schema_definition,"invalid_schema_definition") + ,(invalid_table_definition,"invalid_table_definition") + ,(invalid_object_definition,"invalid_object_definition") + ,(indeterminate_datatype,"indeterminate_datatype") + ,(invalid_recursion,"invalid_recursion") + ,(windowing_error,"windowing_error") + ,(collation_mismatch,"collation_mismatch") + ,(indeterminate_collation,"indeterminate_collation") + ,(with_check_option_violation,"with_check_option_violation") + ,(insufficient_resources,"insufficient_resources") + ,(disk_full,"disk_full") + ,(out_of_memory,"out_of_memory") + ,(too_many_connections,"too_many_connections") + ,(configuration_limit_exceeded,"configuration_limit_exceeded") + ,(program_limit_exceeded,"program_limit_exceeded") + ,(statement_too_complex,"statement_too_complex") + ,(too_many_columns,"too_many_columns") + ,(too_many_arguments,"too_many_arguments") + ,(object_not_in_prerequisite_state,"object_not_in_prerequisite_state") + ,(object_in_use,"object_in_use") + ,(cant_change_runtime_param,"cant_change_runtime_param") + ,(lock_not_available,"lock_not_available") + ,(operator_intervention,"operator_intervention") + ,(query_canceled,"query_canceled") + ,(admin_shutdown,"admin_shutdown") + ,(crash_shutdown,"crash_shutdown") + ,(cannot_connect_now,"cannot_connect_now") + ,(database_dropped,"database_dropped") + ,(system_error,"system_error") + ,(io_error,"io_error") + ,(undefined_file,"undefined_file") + ,(duplicate_file,"duplicate_file") + ,(config_file_error,"config_file_error") + ,(lock_file_exists,"lock_file_exists") + ,(fdw_error,"fdw_error") + ,(fdw_out_of_memory,"fdw_out_of_memory") + ,(fdw_dynamic_parameter_value_needed,"fdw_dynamic_parameter_value_needed") + ,(fdw_invalid_data_type,"fdw_invalid_data_type") + ,(fdw_column_name_not_found,"fdw_column_name_not_found") + ,(fdw_invalid_data_type_descriptors,"fdw_invalid_data_type_descriptors") + ,(fdw_invalid_column_name,"fdw_invalid_column_name") + ,(fdw_invalid_column_number,"fdw_invalid_column_number") + ,(fdw_invalid_use_of_null_pointer,"fdw_invalid_use_of_null_pointer") + ,(fdw_invalid_string_format,"fdw_invalid_string_format") + ,(fdw_invalid_handle,"fdw_invalid_handle") + ,(fdw_invalid_option_index,"fdw_invalid_option_index") + ,(fdw_invalid_option_name,"fdw_invalid_option_name") + ,(fdw_option_name_not_found,"fdw_option_name_not_found") + ,(fdw_reply_handle,"fdw_reply_handle") + ,(fdw_unable_to_create_execution,"fdw_unable_to_create_execution") + ,(fdw_unable_to_create_reply,"fdw_unable_to_create_reply") + ,(fdw_unable_to_establish_connection,"fdw_unable_to_establish_connection") + ,(fdw_no_schemas,"fdw_no_schemas") + ,(fdw_schema_not_found,"fdw_schema_not_found") + ,(fdw_table_not_found,"fdw_table_not_found") + ,(fdw_function_sequence_error,"fdw_function_sequence_error") + ,(fdw_too_many_handles,"fdw_too_many_handles") + ,(fdw_inconsistent_descriptor_information,"fdw_inconsistent_descriptor_information") + ,(fdw_invalid_attribute_value,"fdw_invalid_attribute_value") + ,(fdw_invalid_string_length_or_buffer_length,"fdw_invalid_string_length_or_buffer_length") + ,(fdw_invalid_descriptor_field_identifier,"fdw_invalid_descriptor_field_identifier") + ,(plpgsql_error,"plpgsql_error") + ,(raise_exception,"raise_exception") + ,(no_data_found,"no_data_found") + ,(too_many_rows,"too_many_rows") + ,(assert_failure,"assert_failure") + ,(internal_error,"internal_error") + ,(data_corrupted,"data_corrupted") + ,(index_corrupted,"index_corrupted")] diff --git a/errcodes.hs b/errcodes.hs new file mode 100644 index 0000000..5d4b7c2 --- /dev/null +++ b/errcodes.hs @@ -0,0 +1,115 @@ +-- Parses postgresql/src/backend/utils/errcodes.txt into ErrCodes.hs +-- Based on generate-errcodes.pl +import Data.Char (isSpace, isLower, toLower) +import Data.List (intercalate, isPrefixOf, find, sortOn) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time.Clock (getCurrentTime) +import System.Directory (doesDirectoryExist) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.FilePath (()) +import System.IO (stderr, readFile, hPutStrLn) + +path :: FilePath +path = "src" "backend" "utils" "errcodes.txt" + +data ErrType + = Error + | Warning + | Success + deriving (Show) + +data ErrCode = ErrCode + { errCode :: String + , errMacro :: String + , errName :: Maybe String + , errType :: ErrType + } + +data Line + = Line ErrCode + | Section String + +macroName :: String -> String +macroName ('E':'R':'R':'C':'O':'D':'E':'_':n) = n +macroName n = n + +descName :: ErrCode -> String +descName ErrCode{ errName = Just n } = n +descName ErrCode{ errMacro = n } = n + +macroPrefixes :: [String] +macroPrefixes = ["WARNING_", "S_R_E_", "E_R_E_", "E_R_I_E_"] + +varName :: ErrCode -> String +varName ErrCode{ errName = Just n@(h:_), errMacro = m } + | Just p <- find (`isPrefixOf` m) macroPrefixes = map toLower p ++ n + | isLower h = n +varName e = '_':descName e + +parseType :: String -> Maybe ErrType +parseType "E" = Just Error +parseType "W" = Just Warning +parseType "S" = Just Success +parseType _ = Nothing + +parseWords :: [String] -> Maybe ErrCode +parseWords [c@[_,_,_,_,_], t, m, n] = ErrCode c (macroName m) (Just n) <$> parseType t +parseWords [c@[_,_,_,_,_], t, m] = ErrCode c (macroName m) Nothing <$> parseType t +parseWords _ = Nothing + +parseLine :: String -> Maybe Line +parseLine ('#':_) = Nothing +parseLine ('S':'e':'c':'t':'i':'o':'n':':':s) = Just $ Section $ dropWhile isSpace s +parseLine s + | all isSpace s = Nothing + | otherwise = Just $ Line $ fromMaybe (error $ "invalid line: " ++ s) $ parseWords $ words s + +exportLine :: Line -> IO () +exportLine (Section s) = putStrLn $ " -- * " ++ s +exportLine (Line e) = putStrLn $ " , " ++ varName e + +lineErr :: Line -> Maybe ErrCode +lineErr (Line e) = Just e +lineErr _ = Nothing + +line :: ErrCode -> IO () +line e = do + putStrLn $ "" + putStrLn $ "-- |@" ++ errMacro e ++ "@: " ++ errCode e ++ " (" ++ show (errType e) ++ ")" + putStrLn $ varName e ++ " :: ByteString" + putStrLn $ varName e ++ " = " ++ show (errCode e) + +name :: ErrCode -> Maybe String +name e = Just $ "(" ++ varName e ++ "," ++ show (descName e) ++ ")" + +main :: IO () +main = do + prog <- getProgName + args <- getArgs + arg <- case args of + [f] -> return f + _ -> do + hPutStrLn stderr $ "Usage: " ++ prog ++ " POSTGRESQLSRCDIR[/" ++ path ++ "] > ErrCodes.hs" + exitFailure + argd <- doesDirectoryExist arg + let file | argd = arg path + | otherwise = arg + l <- mapMaybe parseLine . lines <$> readFile file + let e = mapMaybe lineErr l + now <- getCurrentTime + putStrLn $ "-- Automatically generated from " ++ file ++ " using " ++ prog ++ " " ++ show now ++ "." + putStrLn $ "{-# LANGUAGE OverloadedStrings #-}" + putStrLn $ "-- |PostgreSQL error codes." + putStrLn $ "module Database.PostgreSQL.Typed.ErrCodes (names" + mapM_ exportLine l + putStrLn $ ") where" + putStrLn $ "" + putStrLn $ "import Data.ByteString (ByteString)" + putStrLn $ "import Data.Map.Strict (Map, fromDistinctAscList)" + mapM_ line e + putStrLn $ "" + putStrLn $ "-- |All known error code names by code." + putStrLn $ "names :: Map ByteString String" + putStrLn $ "names = fromDistinctAscList\n [" ++ intercalate "\n ," (mapMaybe name $ sortOn errCode e) ++ "]" + return () diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index f999bac..f973ea8 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -80,6 +80,7 @@ Library Database.PostgreSQL.Typed.Dynamic Database.PostgreSQL.Typed.TemplatePG Database.PostgreSQL.Typed.SQLToken + Database.PostgreSQL.Typed.ErrCodes Other-Modules: Paths_postgresql_typed GHC-Options: -Wall From 93f50b47847a98cae06345da64ce74a2aa2bdebb Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 30 Sep 2016 13:56:20 -0400 Subject: [PATCH 196/306] Prepare for 0.4.5 release Not feeling like 0.5 yet, and no incompatibilities, just additions --- postgresql-typed.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index f973ea8..d06c5b8 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.5 +Version: 0.4.5 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING @@ -16,7 +16,7 @@ Description: Automatically type-check SQL statements at compile time. Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell. Supports many built-in PostgreSQL types already, including arrays and ranges, and can be easily extended in user code to support any other types. . - Also includes an optional HDBC backend that, since it uses the raw PostgreSQL backend, may be more efficient than the normal libpq backend in some cases (though provides no more type safety than HDBC-postgresql when used without templates). + Also includes an optional HDBC backend that, since it uses the raw PostgreSQL protocol, may be more efficient than the normal libpq backend in some cases (though provides no more type safety than HDBC-postgresql when used without templates). . Originally based on Chris Forno's templatepg library. Tested-With: GHC == 7.10.3, GHC == 8.0.1 From e4c9e38e28f1e9aed1a3fdce8b4b4a933550a379 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 11 Oct 2016 21:16:22 -0400 Subject: [PATCH 197/306] Switch Dynamic PGRep from fundeps to type families API-breaking change --- Database/PostgreSQL/Typed.hs | 2 +- Database/PostgreSQL/Typed/Dynamic.hs | 95 +++++++++++++++++----------- Database/PostgreSQL/Typed/Enum.hs | 4 +- Database/PostgreSQL/Typed/HDBC.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 2 +- test/Main.hs | 2 +- 6 files changed, 64 insertions(+), 43 deletions(-) diff --git a/Database/PostgreSQL/Typed.hs b/Database/PostgreSQL/Typed.hs index a363231..2844dcf 100644 --- a/Database/PostgreSQL/Typed.hs +++ b/Database/PostgreSQL/Typed.hs @@ -176,7 +176,7 @@ import Database.PostgreSQL.Typed.Query -- You can make as many 'PGParameter' and 'PGColumn' instances as you want if you want to support different representations of your type. -- If you want to use any of the functions in "Database.PostgreSQL.Typed.Dynamic", however, such as 'Database.PostgreSQL.Typed.Dynamic.pgSafeLiteral', you must define a default representation: -- --- > instance PGRep "mytype" MyType +-- > instance PGRep MyType where type PGRepType MyType = "mytype" -- -- If you want to support arrays of your new type, you should also provide a 'Database.PostgreSQL.Typed.Array.PGArrayType' instance (or 'Database.PostgreSQL.Typed.Range.PGRangeType' for new ranges). -- Currently only 1-dimensional arrays are supported. diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index a57d3f7..b09d346 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, DataKinds, DefaultSignatures, PatternGuards, GADTs, TemplateHaskell, AllowAmbiguousTypes #-} +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies #-} -- | -- Module: Database.PostgreSQL.Typed.Dynamic -- Copyright: 2015 Dylan Simon @@ -33,6 +33,7 @@ import qualified Data.Time as Time #ifdef USE_UUID import qualified Data.UUID as UUID #endif +import GHC.TypeLits (Symbol) import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH @@ -40,39 +41,37 @@ import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.SQLToken -- |Represents canonical/default PostgreSQL representation for various Haskell types, allowing convenient type-driven marshalling. -class PGType t => PGRep t a | a -> t where - pgTypeOf :: a -> PGTypeName t +class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where + -- |The PostgreSOL type that this type should be converted to. + type PGRepType a :: Symbol + pgTypeOf :: a -> PGTypeName (PGRepType a) pgTypeOf _ = PGTypeProxy + -- |Encode a value, using 'pgEncodeValue' by default. pgEncodeRep :: a -> PGValue - default pgEncodeRep :: PGParameter t a => a -> PGValue pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x - -- |Produce a literal value for interpolation in a SQL statement. Using 'pgSafeLiteral' is usually safer as it includes type cast. + -- |Produce a literal value for interpolation in a SQL statement, using 'pgLiteral' by default. Using 'pgSafeLiteral' is usually safer as it includes type cast. pgLiteralRep :: a -> BS.ByteString - default pgLiteralRep :: PGParameter t a => a -> BS.ByteString pgLiteralRep x = pgLiteral (pgTypeOf x) x + -- |Decode a value, using 'pgDecode' for text values or producing an error for binary or null values by default. pgDecodeRep :: PGValue -> a -#ifdef USE_BINARY_XXX - default pgDecodeRep :: PGBinaryColumn t a => PGValue -> a - pgDecodeRep (PGBinaryValue v) = pgDecodeBinary unknownPGTypeEnv (PGTypeProxy :: PGTypeName t) v -#else - default pgDecodeRep :: PGColumn t a => PGValue -> a -#endif - pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName t) v - pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue" + pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName (PGRepType a)) v + pgDecodeRep (PGBinaryValue v) = pgDecodeBinary unknownPGTypeEnv (PGTypeProxy :: PGTypeName (PGRepType a)) v + pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName (PGRepType a)) ++ ": unsupported PGValue" -- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement. -pgLiteralString :: PGRep t a => a -> String +pgLiteralString :: PGRep a => a -> String pgLiteralString = BSC.unpack . pgLiteralRep -- |Produce a safely type-cast literal value for interpolation in a SQL statement, e.g., "'123'::integer". -pgSafeLiteral :: PGRep t a => a -> BS.ByteString +pgSafeLiteral :: PGRep a => a -> BS.ByteString pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) -- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. -pgSafeLiteralString :: PGRep t a => a -> String +pgSafeLiteralString :: PGRep a => a -> String pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeName (pgTypeOf x) -instance PGRep t a => PGRep t (Maybe a) where +instance PGRep a => PGRep (Maybe a) where + type PGRepType (Maybe a) = PGRepType a pgEncodeRep Nothing = PGNullValue pgEncodeRep (Just x) = pgEncodeRep x pgLiteralRep Nothing = BSC.pack "NULL" @@ -80,31 +79,51 @@ instance PGRep t a => PGRep t (Maybe a) where pgDecodeRep PGNullValue = Nothing pgDecodeRep v = Just (pgDecodeRep v) -instance PGRep "boolean" Bool -instance PGRep "oid" OID -instance PGRep "smallint" Int16 -instance PGRep "integer" Int32 -instance PGRep "bigint" Int64 -instance PGRep "real" Float -instance PGRep "double precision" Double -instance PGRep "\"char\"" Char -instance PGRep "text" String -instance PGRep "text" BS.ByteString +instance PGRep Bool where + type PGRepType Bool = "boolean" +instance PGRep OID where + type PGRepType OID = "oid" +instance PGRep Int16 where + type PGRepType Int16 = "smallint" +instance PGRep Int32 where + type PGRepType Int32 = "integer" +instance PGRep Int64 where + type PGRepType Int64 = "bigint" +instance PGRep Float where + type PGRepType Float = "real" +instance PGRep Double where + type PGRepType Double = "double precision" +instance PGRep Char where + type PGRepType Char = "\"char\"" +instance PGRep String where + type PGRepType String = "text" +instance PGRep BS.ByteString where + type PGRepType BS.ByteString = "text" #ifdef USE_TEXT -instance PGRep "text" T.Text +instance PGRep T.Text where + type PGRepType T.Text = "text" #endif -instance PGRep "date" Time.Day -instance PGRep "time without time zone" Time.TimeOfDay -instance PGRep "time with time zone" (Time.TimeOfDay, Time.TimeZone) -instance PGRep "timestamp without time zone" Time.LocalTime -instance PGRep "timestamp with time zone" Time.UTCTime -instance PGRep "interval" Time.DiffTime -instance PGRep "numeric" Rational +instance PGRep Time.Day where + type PGRepType Time.Day = "date" +instance PGRep Time.TimeOfDay where + type PGRepType Time.TimeOfDay = "time without time zone" +instance PGRep (Time.TimeOfDay, Time.TimeZone) where + type PGRepType (Time.TimeOfDay, Time.TimeZone) = "time with time zone" +instance PGRep Time.LocalTime where + type PGRepType Time.LocalTime = "timestamp without time zone" +instance PGRep Time.UTCTime where + type PGRepType Time.UTCTime = "timestamp with time zone" +instance PGRep Time.DiffTime where + type PGRepType Time.DiffTime = "interval" +instance PGRep Rational where + type PGRepType Rational = "numeric" #ifdef USE_SCIENTIFIC -instance PGRep "numeric" Scientific +instance PGRep Scientific where + type PGRepType Scientific = "numeric" #endif #ifdef USE_UUID -instance PGRep "uuid" UUID.UUID +instance PGRep UUID.UUID where + type PGRepType UUID.UUID = "uuid" #endif -- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@, producing a lazy 'BSL.ByteString'. diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 671560d..41e623c 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -84,7 +84,9 @@ makePGEnum name typs valnf = do []]) []] ] - , instanceD [] (TH.ConT ''PGRep `TH.AppT` typl `TH.AppT` typt) [] + , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) + [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl + ] , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) [] ] where diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index 656cb3c..72b4331 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -253,7 +253,7 @@ instance HDBC.IConnection Connection where , "ORDER BY attnum" ]) -encodeRep :: (PGParameter t a, PGRep t a) => a -> PGValue +encodeRep :: PGRep a => a -> PGValue encodeRep x = PGTextValue $ pgEncode (pgTypeOf x) x encode :: HDBC.SqlValue -> PGValue diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 503ef86..c44ec07 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif diff --git a/test/Main.hs b/test/Main.hs index fedc95d..638d3e3 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Main (main) where From 057510b19363c159e3f73ee3899a22bc83184fde Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 11 Oct 2016 21:40:53 -0400 Subject: [PATCH 198/306] Take PGRep methods out of class Since no specialization is or should be necessary anymore --- Database/PostgreSQL/Typed/Dynamic.hs | 40 +++++++++++++++------------- Database/PostgreSQL/Typed/Types.hs | 2 ++ 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index b09d346..166657b 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -8,6 +8,10 @@ module Database.PostgreSQL.Typed.Dynamic ( PGRep(..) + , pgTypeOf + , pgEncodeRep + , pgDecodeRep + , pgLiteralRep , pgLiteralString , pgSafeLiteral , pgSafeLiteralString @@ -44,19 +48,21 @@ import Database.PostgreSQL.Typed.SQLToken class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where -- |The PostgreSOL type that this type should be converted to. type PGRepType a :: Symbol - pgTypeOf :: a -> PGTypeName (PGRepType a) - pgTypeOf _ = PGTypeProxy - -- |Encode a value, using 'pgEncodeValue' by default. - pgEncodeRep :: a -> PGValue - pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x - -- |Produce a literal value for interpolation in a SQL statement, using 'pgLiteral' by default. Using 'pgSafeLiteral' is usually safer as it includes type cast. - pgLiteralRep :: a -> BS.ByteString - pgLiteralRep x = pgLiteral (pgTypeOf x) x - -- |Decode a value, using 'pgDecode' for text values or producing an error for binary or null values by default. - pgDecodeRep :: PGValue -> a - pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName (PGRepType a)) v - pgDecodeRep (PGBinaryValue v) = pgDecodeBinary unknownPGTypeEnv (PGTypeProxy :: PGTypeName (PGRepType a)) v - pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName (PGRepType a)) ++ ": unsupported PGValue" + +pgTypeOf :: a -> PGTypeName (PGRepType a) +pgTypeOf _ = PGTypeProxy + +-- |Encode a value using 'pgEncodeValue'. +pgEncodeRep :: PGRep a => a -> PGValue +pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x + +-- |Produce a literal value for interpolation in a SQL statement using 'pgLiteral'. Using 'pgSafeLiteral' is usually safer as it includes type cast. +pgLiteralRep :: PGRep a => a -> BS.ByteString +pgLiteralRep x = pgLiteral (pgTypeOf x) x + +-- |Decode a value using 'pgDecodeValue'. +pgDecodeRep :: forall a . PGRep a => PGValue -> a +pgDecodeRep = pgDecodeValue unknownPGTypeEnv (PGTypeProxy :: PGTypeName (PGRepType a)) -- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement. pgLiteralString :: PGRep a => a -> String @@ -72,13 +78,9 @@ pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeName (pgTypeOf x) instance PGRep a => PGRep (Maybe a) where type PGRepType (Maybe a) = PGRepType a - pgEncodeRep Nothing = PGNullValue - pgEncodeRep (Just x) = pgEncodeRep x - pgLiteralRep Nothing = BSC.pack "NULL" - pgLiteralRep (Just x) = pgLiteralRep x - pgDecodeRep PGNullValue = Nothing - pgDecodeRep v = Just (pgDecodeRep v) +instance PGRep () where + type PGRepType () = "void" instance PGRep Bool where type PGRepType Bool = "boolean" instance PGRep OID where diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index c44ec07..485bac6 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -245,6 +245,8 @@ instance PGParameter "any" PGValue where pgEncodeValue _ _ = id instance PGType "void" +instance PGParameter "void" () where + pgEncode _ _ = BSC.empty instance PGColumn "void" () where pgDecode _ _ = () pgDecodeBinary _ _ _ = () From 222190a8bd7eaa9541267a15123f6321725d91a6 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 11 Oct 2016 21:41:36 -0400 Subject: [PATCH 199/306] Switch from -DUSE_x to pre-defined VERSION_x --- Database/PostgreSQL/Typed/Dynamic.hs | 19 ++++++++---- Database/PostgreSQL/Typed/Protocol.hs | 6 ++-- Database/PostgreSQL/Typed/Query.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 44 +++++++++++++-------------- postgresql-typed.cabal | 6 ---- 5 files changed, 39 insertions(+), 38 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 166657b..5a9fb89 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -21,20 +21,23 @@ module Database.PostgreSQL.Typed.Dynamic #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif +#ifdef VERSION_aeson +import qualified Data.Aeson as JSON +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import Data.Monoid ((<>)) import Data.Int -#ifdef USE_SCIENTIFIC +#ifdef VERSION_scientific import Data.Scientific (Scientific) #endif import Data.String (fromString) -#ifdef USE_TEXT +#ifdef VERSION_text import qualified Data.Text as T #endif import qualified Data.Time as Time -#ifdef USE_UUID +#ifdef VERSION_uuid import qualified Data.UUID as UUID #endif import GHC.TypeLits (Symbol) @@ -101,7 +104,7 @@ instance PGRep String where type PGRepType String = "text" instance PGRep BS.ByteString where type PGRepType BS.ByteString = "text" -#ifdef USE_TEXT +#ifdef VERSION_text instance PGRep T.Text where type PGRepType T.Text = "text" #endif @@ -119,14 +122,18 @@ instance PGRep Time.DiffTime where type PGRepType Time.DiffTime = "interval" instance PGRep Rational where type PGRepType Rational = "numeric" -#ifdef USE_SCIENTIFIC +#ifdef VERSION_scientific instance PGRep Scientific where type PGRepType Scientific = "numeric" #endif -#ifdef USE_UUID +#ifdef VERSION_uuid instance PGRep UUID.UUID where type PGRepType UUID.UUID = "uuid" #endif +#ifdef VERSION_aeson +instance PGRep JSON.Value where + type PGRepType JSON.Value = "jsonb" +#endif -- |Create an expression that literally substitutes each instance of @${expr}@ for the result of @pgSafeLiteral expr@, producing a lazy 'BSL.ByteString'. -- This lets you do safe, type-driven literal substitution into SQL fragments without needing a full query, bypassing placeholder inference and any prepared queries, for example when using 'Database.PostgreSQL.Typed.Protocol.pgSimpleQuery' or 'Database.PostgreSQL.Typed.Protocol.pgSimpleQueries_'. diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 4653207..cb62e76 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -50,7 +50,7 @@ import Control.Applicative ((<$>), (<$)) import Control.Arrow ((&&&), first, second) import Control.Exception (Exception, throwIO, onException) import Control.Monad (void, liftM2, replicateM, when, unless) -#ifdef USE_MD5 +#ifdef VERSION_cryptonite import qualified Crypto.Hash as Hash import qualified Data.ByteArray.Encoding as BA #endif @@ -257,7 +257,7 @@ pgTypeEnv = connTypeEnv pgServerVersion :: PGConnection -> Maybe BS.ByteString pgServerVersion PGConnection{ connParameters = p } = Map.lookup (BSC.pack "server_version") p -#ifdef USE_MD5 +#ifdef VERSION_cryptonite md5 :: BS.ByteString -> BS.ByteString md5 = BA.convertToBase BA.Base16 . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) #endif @@ -488,7 +488,7 @@ pgConnect db = do pgSend c $ PasswordMessage $ pgDBPass db pgFlush c conn c -#ifdef USE_MD5 +#ifdef VERSION_cryptonite msg c (AuthenticationMD5Password salt) = do pgSend c $ PasswordMessage $ BSC.pack "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) pgFlush c diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 833c533..95c6703 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -199,7 +199,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID . snd) $ zip p pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary bins #else [] diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 485bac6..9bb9956 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -41,7 +41,7 @@ module Database.PostgreSQL.Typed.Types import Control.Applicative ((<$>), (<$), (<*), (*>)) #endif import Control.Arrow ((&&&)) -#ifdef USE_AESON +#ifdef VERSION_aeson import qualified Data.Aeson as JSON #endif import qualified Data.Attoparsec.ByteString as P (anyWord8) @@ -64,10 +64,10 @@ import Data.Monoid ((<>)) import Data.Monoid (mempty, mconcat) #endif import Data.Ratio ((%), numerator, denominator) -#ifdef USE_SCIENTIFIC +#ifdef VERSION_scientific import Data.Scientific (Scientific) #endif -#ifdef USE_TEXT +#ifdef VERSION_text import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL @@ -79,13 +79,13 @@ import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif -#ifdef USE_UUID +#ifdef VERSION_uuid import qualified Data.UUID as UUID #endif import Data.Word (Word8, Word32) import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) import Numeric (readFloat) -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary import qualified PostgreSQL.Binary.Decoder as BinD import qualified PostgreSQL.Binary.Encoder as BinE #endif @@ -220,7 +220,7 @@ parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where | isnul s = Nothing | otherwise = Just s -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary binDec :: PGType t => BinD.Decoder a -> PGTypeName t -> PGBinaryValue -> a binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . BinD.run d @@ -376,7 +376,7 @@ instance pgDecode _ = BSL.fromStrict BIN_DEC((TLE.encodeUtf8 .) . binDec BinD.text_lazy) -#ifdef USE_TEXT +#ifdef VERSION_text instance PGStringType t => PGParameter t T.Text where pgEncode _ = TE.encodeUtf8 BIN_ENC(BinE.text_strict) @@ -467,12 +467,12 @@ instance PGColumn "date" Time.Day where BIN_DEC(binDec BinD.date) binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True #endif binColDatetime _ _ = False -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary binEncDatetime :: PGParameter t a => BinE.Encoder a -> BinE.Encoder a -> PGTypeEnv -> PGTypeName t -> a -> PGValue binEncDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } _ = PGBinaryValue . buildPGValue . ff binEncDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } _ = PGBinaryValue . buildPGValue . fi @@ -499,12 +499,12 @@ instance PGType "time without time zone" where instance PGParameter "time without time zone" Time.TimeOfDay where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" pgLiteral t = pgQuoteUnsafe . pgEncode t -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgEncodeValue = binEncDatetime BinE.time_int BinE.time_float #endif instance PGColumn "time without time zone" Time.TimeOfDay where pgDecode _ = readTime "%T%Q" . BSC.unpack -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgDecodeBinary = binDecDatetime BinD.time_int BinD.time_float #endif @@ -513,12 +513,12 @@ instance PGType "time with time zone" where instance PGParameter "time with time zone" (Time.TimeOfDay, Time.TimeZone) where pgEncode _ (t, z) = BSC.pack $ Time.formatTime defaultTimeLocale "%T%Q" t ++ fixTZ (Time.formatTime defaultTimeLocale "%z" z) pgLiteral t = pgQuoteUnsafe . pgEncode t -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgEncodeValue = binEncDatetime BinE.timetz_int BinE.timetz_float #endif instance PGColumn "time with time zone" (Time.TimeOfDay, Time.TimeZone) where pgDecode _ = (Time.localTimeOfDay . Time.zonedTimeToLocalTime &&& Time.zonedTimeZone) . readTime "%T%Q%z" . fixTZ . BSC.unpack -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgDecodeBinary = binDecDatetime BinD.timetz_int BinD.timetz_float #endif @@ -527,12 +527,12 @@ instance PGType "timestamp without time zone" where instance PGParameter "timestamp without time zone" Time.LocalTime where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" pgLiteral t = pgQuoteUnsafe . pgEncode t -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgEncodeValue = binEncDatetime BinE.timestamp_int BinE.timestamp_float #endif instance PGColumn "timestamp without time zone" Time.LocalTime where pgDecode _ = readTime "%F %T%Q" . BSC.unpack -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgDecodeBinary = binDecDatetime BinD.timestamp_int BinD.timestamp_float #endif @@ -541,12 +541,12 @@ instance PGType "timestamp with time zone" where instance PGParameter "timestamp with time zone" Time.UTCTime where pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" -- pgLiteral t = pgQuoteUnsafe . pgEncode t -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgEncodeValue = binEncDatetime BinE.timestamptz_int BinE.timestamptz_float #endif instance PGColumn "timestamp with time zone" Time.UTCTime where pgDecode _ = readTime "%F %T%Q%z" . fixTZ . BSC.unpack -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgDecodeBinary = binDecDatetime BinD.timestamptz_int BinD.timestamptz_float #endif @@ -555,7 +555,7 @@ instance PGType "interval" where instance PGParameter "interval" Time.DiffTime where pgEncode _ = BSC.pack . show pgLiteral t = pgQuoteUnsafe . pgEncode t -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgEncodeValue = binEncDatetime BinE.interval_int BinE.interval_float #endif -- |Representation of DiffTime as interval. @@ -578,7 +578,7 @@ instance PGColumn "interval" Time.DiffTime where return $ x * u day = 86400 month = 2629746 -#ifdef USE_BINARY +#ifdef VERSION_postgresql_binary pgDecodeBinary = binDecDatetime BinD.interval_int BinD.interval_float #endif @@ -611,7 +611,7 @@ showRational r = show (ri :: Integer) ++ '.' : frac (abs rf) where frac 0 = "" frac f = intToDigit i : frac f' where (i, f') = properFraction (10 * f) -#ifdef USE_SCIENTIFIC +#ifdef VERSION_scientific instance PGParameter "numeric" Scientific where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -621,7 +621,7 @@ instance PGColumn "numeric" Scientific where BIN_DEC(binDec BinD.numeric) #endif -#ifdef USE_UUID +#ifdef VERSION_uuid instance PGType "uuid" where BIN_COL instance PGParameter "uuid" UUID.UUID where pgEncode _ = UUID.toASCIIBytes @@ -650,7 +650,7 @@ instance PGType "record" -- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). instance PGRecordType "record" -#ifdef USE_AESON +#ifdef VERSION_aeson instance PGType "json" instance PGParameter "json" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index d06c5b8..6c1b557 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -86,23 +86,17 @@ Library GHC-Options: -Wall if flag(md5) Build-Depends: cryptonite >= 0.5, memory >= 0.5 - CPP-options: -DUSE_MD5 if flag(binary) Build-Depends: postgresql-binary >= 0.7, 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 if flag(aeson) Build-Depends: aeson >= 0.7 - CPP-options: -DUSE_AESON if flag(HDBC) Build-Depends: HDBC >= 2.2 Exposed-Modules: From a95ead2c5d5d1c17f32f18269b36c06b71a8c015 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 11 Oct 2016 22:08:53 -0400 Subject: [PATCH 200/306] Simplify BIN_DEC; use binary for json/jsonb --- Database/PostgreSQL/Typed/Types.hs | 59 +++++++++++++++++------------- postgresql-typed.cabal | 2 +- 2 files changed, 35 insertions(+), 26 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 9bb9956..6a4c512 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -47,12 +47,11 @@ import qualified Data.Aeson as JSON import qualified Data.Attoparsec.ByteString as P (anyWord8) import qualified Data.Attoparsec.ByteString.Char8 as P 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 Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower) @@ -225,8 +224,8 @@ binDec :: PGType t => BinD.Decoder a -> PGTypeName t -> PGBinaryValue -> a binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . BinD.run d #define BIN_COL pgBinaryColumn _ _ = True -#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . F -#define BIN_DEC(F) pgDecodeBinary _ = F +#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . (F) +#define BIN_DEC(F) pgDecodeBinary _ = binDec (F) #else #define BIN_COL #define BIN_ENC(F) @@ -264,7 +263,7 @@ instance PGColumn "boolean" Bool where 'f' -> False 't' -> True c -> error $ "pgDecode boolean: " ++ [c] - BIN_DEC(binDec BinD.bool) + BIN_DEC(BinD.bool) type OID = Word32 instance PGType "oid" where BIN_COL @@ -274,7 +273,7 @@ instance PGParameter "oid" OID where BIN_ENC(BinE.int4_word32) instance PGColumn "oid" OID where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.int) + BIN_DEC(BinD.int) instance PGType "smallint" where BIN_COL instance PGParameter "smallint" Int16 where @@ -283,7 +282,7 @@ instance PGParameter "smallint" Int16 where BIN_ENC(BinE.int2_int16) instance PGColumn "smallint" Int16 where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.int) + BIN_DEC(BinD.int) instance PGType "integer" where BIN_COL instance PGParameter "integer" Int32 where @@ -292,7 +291,7 @@ instance PGParameter "integer" Int32 where BIN_ENC(BinE.int4_int32) instance PGColumn "integer" Int32 where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.int) + BIN_DEC(BinD.int) instance PGType "bigint" where BIN_COL instance PGParameter "bigint" Int64 where @@ -301,7 +300,7 @@ instance PGParameter "bigint" Int64 where BIN_ENC(BinE.int8_int64) instance PGColumn "bigint" Int64 where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.int) + BIN_DEC(BinD.int) instance PGType "real" where BIN_COL instance PGParameter "real" Float where @@ -310,10 +309,10 @@ instance PGParameter "real" Float where BIN_ENC(BinE.float4) instance PGColumn "real" Float where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.float4) + BIN_DEC(BinD.float4) instance PGColumn "real" Double where pgDecode _ = read . BSC.unpack - BIN_DEC((realToFrac .) . binDec BinD.float4) + BIN_DEC(realToFrac <$> BinD.float4) instance PGType "double precision" where BIN_COL instance PGParameter "double precision" Double where @@ -326,15 +325,21 @@ instance PGParameter "double precision" Float where BIN_ENC(BinE.float8 . realToFrac) instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.float8) + BIN_DEC(BinD.float8) instance PGType "\"char\"" where BIN_COL +instance PGParameter "\"char\"" Word8 where + pgEncode _ = BS.singleton + BIN_ENC(BinE.char . w2c) +instance PGColumn "\"char\"" Word8 where + pgDecode _ = BS.head + BIN_DEC(c2w <$> BinD.char) instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton BIN_ENC(BinE.char) instance PGColumn "\"char\"" Char where pgDecode _ = BSC.head - BIN_DEC(binDec BinD.char) + BIN_DEC(BinD.char) class PGType t => PGStringType t @@ -344,7 +349,7 @@ instance PGStringType t => PGParameter t String where BIN_ENC(BinE.text_strict . T.pack) instance PGStringType t => PGColumn t String where pgDecode _ = BSU.toString - BIN_DEC((T.unpack .) . binDec BinD.text_strict) + BIN_DEC(T.unpack <$> BinD.text_strict) instance #if __GLASGOW_HASKELL__ >= 710 @@ -359,7 +364,7 @@ instance #endif PGStringType t => PGColumn t BS.ByteString where pgDecode _ = id - BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text_strict) + BIN_DEC(TE.encodeUtf8 <$> BinD.text_strict) instance #if __GLASGOW_HASKELL__ >= 710 @@ -374,7 +379,7 @@ instance #endif PGStringType t => PGColumn t BSL.ByteString where pgDecode _ = BSL.fromStrict - BIN_DEC((TLE.encodeUtf8 .) . binDec BinD.text_lazy) + BIN_DEC(TLE.encodeUtf8 <$> BinD.text_lazy) #ifdef VERSION_text instance PGStringType t => PGParameter t T.Text where @@ -382,14 +387,14 @@ instance PGStringType t => PGParameter t T.Text where BIN_ENC(BinE.text_strict) instance PGStringType t => PGColumn t T.Text where pgDecode _ = TE.decodeUtf8 - BIN_DEC(binDec BinD.text_strict) + BIN_DEC(BinD.text_strict) instance PGStringType t => PGParameter t TL.Text where pgEncode _ = BSL.toStrict . TLE.encodeUtf8 BIN_ENC(BinE.text_lazy) instance PGStringType t => PGColumn t TL.Text where pgDecode _ = TL.fromStrict . TE.decodeUtf8 - BIN_DEC(binDec BinD.text_lazy) + BIN_DEC(BinD.text_lazy) #endif instance PGType "text" where BIN_COL @@ -431,7 +436,7 @@ instance #endif PGColumn "bytea" BSL.ByteString where pgDecode _ = BSL.pack . decodeBytea - BIN_DEC(binDec BinD.bytea_lazy) + BIN_DEC(BinD.bytea_lazy) instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} @@ -446,7 +451,7 @@ instance #endif PGColumn "bytea" BS.ByteString where pgDecode _ = BS.pack . decodeBytea - BIN_DEC(binDec BinD.bytea_strict) + BIN_DEC(BinD.bytea_strict) readTime :: Time.ParseTime t => String -> String -> t readTime = @@ -464,7 +469,7 @@ instance PGParameter "date" Time.Day where BIN_ENC(BinE.date) instance PGColumn "date" Time.Day where pgDecode _ = readTime "%F" . BSC.unpack - BIN_DEC(binDec BinD.date) + BIN_DEC(BinD.date) binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool #ifdef VERSION_postgresql_binary @@ -602,7 +607,7 @@ instance PGColumn "numeric" Rational where ur [(x,"")] = x ur _ = error $ "pgDecode numeric: " ++ s s = BSC.unpack bs - BIN_DEC((realToFrac .) . binDec BinD.numeric) + BIN_DEC(realToFrac <$> BinD.numeric) -- This will produce infinite(-precision) strings showRational :: Rational -> String @@ -618,7 +623,7 @@ instance PGParameter "numeric" Scientific where BIN_ENC(BinE.numeric) instance PGColumn "numeric" Scientific where pgDecode _ = read . BSC.unpack - BIN_DEC(binDec BinD.numeric) + BIN_DEC(BinD.numeric) #endif #ifdef VERSION_uuid @@ -629,7 +634,7 @@ instance PGParameter "uuid" UUID.UUID where BIN_ENC(BinE.uuid) instance PGColumn "uuid" UUID.UUID where pgDecode _ u = fromMaybe (error $ "pgDecode uuid: " ++ BSC.unpack u) $ UUID.fromASCIIBytes u - BIN_DEC(binDec BinD.uuid) + BIN_DEC(BinD.uuid) #endif -- |Generic class of composite (row or record) types. @@ -651,17 +656,21 @@ instance PGType "record" instance PGRecordType "record" #ifdef VERSION_aeson -instance PGType "json" +instance PGType "json" where BIN_COL instance PGParameter "json" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode + BIN_ENC(BinE.json_ast) instance PGColumn "json" JSON.Value where pgDecode _ j = either (error . ("pgDecode json (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j + BIN_DEC(BinD.json_ast) instance PGType "jsonb" instance PGParameter "jsonb" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode + BIN_ENC(BinE.jsonb_ast) instance PGColumn "jsonb" JSON.Value where pgDecode _ j = either (error . ("pgDecode jsonb (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j + BIN_DEC(BinD.jsonb_ast) #endif {- diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 6c1b557..5a8e48e 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -87,7 +87,7 @@ Library if flag(md5) Build-Depends: cryptonite >= 0.5, memory >= 0.5 if flag(binary) - Build-Depends: postgresql-binary >= 0.7, text >= 1, uuid >= 1.3, scientific >= 0.3 + Build-Depends: postgresql-binary >= 0.8, text >= 1, uuid >= 1.3, scientific >= 0.3 else if flag(text) Build-Depends: text >= 1 From 804a7ba7f6f582c98dfcafad54fc6121ba64fe37 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 12 Oct 2016 14:08:44 -0400 Subject: [PATCH 201/306] Add PGVal type family; move away from fundeps May require ghc 8 (UndecidableSuperClasses) -- needs testing. --- Database/PostgreSQL/Typed/Array.hs | 412 ++++++++++++++++++--------- Database/PostgreSQL/Typed/Dynamic.hs | 2 +- Database/PostgreSQL/Typed/Enum.hs | 4 +- Database/PostgreSQL/Typed/Inet.hs | 8 +- Database/PostgreSQL/Typed/Range.hs | 48 ++-- Database/PostgreSQL/Typed/Types.hs | 103 +++++-- 6 files changed, 391 insertions(+), 186 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 79e9f61..7c3cbfb 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, OverloadedStrings, TypeFamilies, UndecidableSuperClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -25,6 +25,7 @@ import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mconcat) #endif +import GHC.TypeLits (Symbol) import Database.PostgreSQL.Typed.Types @@ -35,165 +36,298 @@ type PGArray a = [Maybe a] -- |Class indicating that the first PostgreSQL type is an array of the second. -- This implies 'PGParameter' and 'PGColumn' instances that will work for any type using comma as a delimiter (i.e., anything but @box@). -- This will only work with 1-dimensional arrays. -class (PGType ta, PGType t) => PGArrayType ta t | ta -> t, t -> ta where - pgArrayElementType :: PGTypeName ta -> PGTypeName t +class (PGType t, PGType (PGElemType t)) => PGArrayType t where + type PGElemType t :: Symbol + pgArrayElementType :: PGTypeName t -> PGTypeName (PGElemType 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 :: PGTypeName t -> Char pgArrayDelim _ = ',' instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} #endif - (PGArrayType ta t, PGParameter t a) => PGParameter ta (PGArray a) where + (PGArrayType t, PGParameter (PGElemType t) a) => PGParameter t (PGArray a) where pgEncode ta l = buildPGValue $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where el Nothing = BSB.string7 "null" el (Just e) = pgDQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e #if __GLASGOW_HASKELL__ >= 710 -- |Allow entirely non-null arrays as parameter inputs only. -- (Only supported on ghc >= 7.10 due to instance overlap.) -instance {-# OVERLAPPABLE #-} (PGArrayType ta t, PGParameter t a) => PGParameter ta [a] where +instance {-# OVERLAPPABLE #-} (PGArrayType t, PGParameter (PGElemType t) a) => PGParameter t [a] where pgEncode ta = pgEncode ta . map Just #endif -instance (PGArrayType ta t, PGColumn t a) => PGColumn ta (PGArray a) where +instance (PGArrayType t, PGColumn (PGElemType t) a) => PGColumn t (PGArray a) where pgDecode ta a = either (error . ("pgDecode array (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly pa a where pa = P.char '{' *> P.sepBy (P.skipSpace *> el <* P.skipSpace) (P.char (pgArrayDelim ta)) <* P.char '}' <* P.endOfInput el = fmap (pgDecode (pgArrayElementType ta)) <$> parsePGDQuote False (pgArrayDelim ta : "{}") (("null" ==) . BSC.map toLower) -- Just a dump of pg_type: -instance PGType "boolean" => PGType "boolean[]" -instance PGType "boolean" => PGArrayType "boolean[]" "boolean" -instance PGType "bytea" => PGType "bytea[]" -instance PGType "bytea" => PGArrayType "bytea[]" "bytea" -instance PGType "\"char\"" => PGType "\"char\"[]" -instance PGType "\"char\"" => PGArrayType "\"char\"[]" "\"char\"" -instance PGType "name" => PGType "name[]" -instance PGType "name" => PGArrayType "name[]" "name" -instance PGType "bigint" => PGType "bigint[]" -instance PGType "bigint" => PGArrayType "bigint[]" "bigint" -instance PGType "smallint" => PGType "smallint[]" -instance PGType "smallint" => PGArrayType "smallint[]" "smallint" -instance PGType "int2vector" => PGType "int2vector[]" -instance PGType "int2vector" => PGArrayType "int2vector[]" "int2vector" -instance PGType "integer" => PGType "integer[]" -instance PGType "integer" => PGArrayType "integer[]" "integer" -instance PGType "regproc" => PGType "regproc[]" -instance PGType "regproc" => PGArrayType "regproc[]" "regproc" -instance PGType "text" => PGType "text[]" -instance PGType "text" => PGArrayType "text[]" "text" -instance PGType "oid" => PGType "oid[]" -instance PGType "oid" => PGArrayType "oid[]" "oid" -instance PGType "tid" => PGType "tid[]" -instance PGType "tid" => PGArrayType "tid[]" "tid" -instance PGType "xid" => PGType "xid[]" -instance PGType "xid" => PGArrayType "xid[]" "xid" -instance PGType "cid" => PGType "cid[]" -instance PGType "cid" => PGArrayType "cid[]" "cid" -instance PGType "oidvector" => PGType "oidvector[]" -instance PGType "oidvector" => PGArrayType "oidvector[]" "oidvector" -instance PGType "json" => PGType "json[]" -instance PGType "json" => PGArrayType "json[]" "json" -instance PGType "xml" => PGType "xml[]" -instance PGType "xml" => PGArrayType "xml[]" "xml" -instance PGType "point" => PGType "point[]" -instance PGType "point" => PGArrayType "point[]" "point" -instance PGType "lseg" => PGType "lseg[]" -instance PGType "lseg" => PGArrayType "lseg[]" "lseg" -instance PGType "path" => PGType "path[]" -instance PGType "path" => PGArrayType "path[]" "path" -instance PGType "box" => PGType "box[]" -instance PGType "box" => PGArrayType "box[]" "box" where +instance PGType "boolean" => PGType "boolean[]" where + type PGVal "boolean[]" = PGArray (PGVal "boolean") +instance PGType "boolean" => PGArrayType "boolean[]" where + type PGElemType "boolean[]" = "boolean" +instance PGType "bytea" => PGType "bytea[]" where + type PGVal "bytea[]" = PGArray (PGVal "bytea") +instance PGType "bytea" => PGArrayType "bytea[]" where + type PGElemType "bytea[]" = "bytea" +instance PGType "\"char\"" => PGType "\"char\"[]" where + type PGVal "\"char\"[]" = PGArray (PGVal "\"char\"") +instance PGType "\"char\"" => PGArrayType "\"char\"[]" where + type PGElemType "\"char\"[]" = "\"char\"" +instance PGType "name" => PGType "name[]" where + type PGVal "name[]" = PGArray (PGVal "name") +instance PGType "name" => PGArrayType "name[]" where + type PGElemType "name[]" = "name" +instance PGType "bigint" => PGType "bigint[]" where + type PGVal "bigint[]" = PGArray (PGVal "bigint") +instance PGType "bigint" => PGArrayType "bigint[]" where + type PGElemType "bigint[]" = "bigint" +instance PGType "smallint" => PGType "smallint[]" where + type PGVal "smallint[]" = PGArray (PGVal "smallint") +instance PGType "smallint" => PGArrayType "smallint[]" where + type PGElemType "smallint[]" = "smallint" +instance PGType "int2vector" => PGType "int2vector[]" where + type PGVal "int2vector[]" = PGArray (PGVal "int2vector") +instance PGType "int2vector" => PGArrayType "int2vector[]" where + type PGElemType "int2vector[]" = "int2vector" +instance PGType "integer" => PGType "integer[]" where + type PGVal "integer[]" = PGArray (PGVal "integer") +instance PGType "integer" => PGArrayType "integer[]" where + type PGElemType "integer[]" = "integer" +instance PGType "regproc" => PGType "regproc[]" where + type PGVal "regproc[]" = PGArray (PGVal "regproc") +instance PGType "regproc" => PGArrayType "regproc[]" where + type PGElemType "regproc[]" = "regproc" +instance PGType "text" => PGType "text[]" where + type PGVal "text[]" = PGArray (PGVal "text") +instance PGType "text" => PGArrayType "text[]" where + type PGElemType "text[]" = "text" +instance PGType "oid" => PGType "oid[]" where + type PGVal "oid[]" = PGArray (PGVal "oid") +instance PGType "oid" => PGArrayType "oid[]" where + type PGElemType "oid[]" = "oid" +instance PGType "tid" => PGType "tid[]" where + type PGVal "tid[]" = PGArray (PGVal "tid") +instance PGType "tid" => PGArrayType "tid[]" where + type PGElemType "tid[]" = "tid" +instance PGType "xid" => PGType "xid[]" where + type PGVal "xid[]" = PGArray (PGVal "xid") +instance PGType "xid" => PGArrayType "xid[]" where + type PGElemType "xid[]" = "xid" +instance PGType "cid" => PGType "cid[]" where + type PGVal "cid[]" = PGArray (PGVal "cid") +instance PGType "cid" => PGArrayType "cid[]" where + type PGElemType "cid[]" = "cid" +instance PGType "oidvector" => PGType "oidvector[]" where + type PGVal "oidvector[]" = PGArray (PGVal "oidvector") +instance PGType "oidvector" => PGArrayType "oidvector[]" where + type PGElemType "oidvector[]" = "oidvector" +instance PGType "json" => PGType "json[]" where + type PGVal "json[]" = PGArray (PGVal "json") +instance PGType "json" => PGArrayType "json[]" where + type PGElemType "json[]" = "json" +instance PGType "xml" => PGType "xml[]" where + type PGVal "xml[]" = PGArray (PGVal "xml") +instance PGType "xml" => PGArrayType "xml[]" where + type PGElemType "xml[]" = "xml" +instance PGType "point" => PGType "point[]" where + type PGVal "point[]" = PGArray (PGVal "point") +instance PGType "point" => PGArrayType "point[]" where + type PGElemType "point[]" = "point" +instance PGType "lseg" => PGType "lseg[]" where + type PGVal "lseg[]" = PGArray (PGVal "lseg") +instance PGType "lseg" => PGArrayType "lseg[]" where + type PGElemType "lseg[]" = "lseg" +instance PGType "path" => PGType "path[]" where + type PGVal "path[]" = PGArray (PGVal "path") +instance PGType "path" => PGArrayType "path[]" where + type PGElemType "path[]" = "path" +instance PGType "box" => PGType "box[]" where + type PGVal "box[]" = PGArray (PGVal "box") +instance PGType "box" => PGArrayType "box[]" where + type PGElemType "box[]" = "box" pgArrayDelim _ = ';' -instance PGType "polygon" => PGType "polygon[]" -instance PGType "polygon" => PGArrayType "polygon[]" "polygon" -instance PGType "line" => PGType "line[]" -instance PGType "line" => PGArrayType "line[]" "line" -instance PGType "cidr" => PGType "cidr[]" -instance PGType "cidr" => PGArrayType "cidr[]" "cidr" -instance PGType "real" => PGType "real[]" -instance PGType "real" => PGArrayType "real[]" "real" -instance PGType "double precision" => PGType "double precision[]" -instance PGType "double precision" => PGArrayType "double precision[]" "double precision" -instance PGType "abstime" => PGType "abstime[]" -instance PGType "abstime" => PGArrayType "abstime[]" "abstime" -instance PGType "reltime" => PGType "reltime[]" -instance PGType "reltime" => PGArrayType "reltime[]" "reltime" -instance PGType "tinterval" => PGType "tinterval[]" -instance PGType "tinterval" => PGArrayType "tinterval[]" "tinterval" -instance PGType "circle" => PGType "circle[]" -instance PGType "circle" => PGArrayType "circle[]" "circle" -instance PGType "money" => PGType "money[]" -instance PGType "money" => PGArrayType "money[]" "money" -instance PGType "macaddr" => PGType "macaddr[]" -instance PGType "macaddr" => PGArrayType "macaddr[]" "macaddr" -instance PGType "inet" => PGType "inet[]" -instance PGType "inet" => PGArrayType "inet[]" "inet" -instance PGType "aclitem" => PGType "aclitem[]" -instance PGType "aclitem" => PGArrayType "aclitem[]" "aclitem" -instance PGType "bpchar" => PGType "bpchar[]" -instance PGType "bpchar" => PGArrayType "bpchar[]" "bpchar" -instance PGType "character varying" => PGType "character varying[]" -instance PGType "character varying" => PGArrayType "character varying[]" "character varying" -instance PGType "date" => PGType "date[]" -instance PGType "date" => PGArrayType "date[]" "date" -instance PGType "time without time zone" => PGType "time without time zone[]" -instance PGType "time without time zone" => PGArrayType "time without time zone[]" "time without time zone" -instance PGType "timestamp without time zone" => PGType "timestamp without time zone[]" -instance PGType "timestamp without time zone" => PGArrayType "timestamp without time zone[]" "timestamp without time zone" -instance PGType "timestamp with time zone" => PGType "timestamp with time zone[]" -instance PGType "timestamp with time zone" => PGArrayType "timestamp with time zone[]" "timestamp with time zone" -instance PGType "interval" => PGType "interval[]" -instance PGType "interval" => PGArrayType "interval[]" "interval" -instance PGType "time with time zone" => PGType "time with time zone[]" -instance PGType "time with time zone" => PGArrayType "time with time zone[]" "time with time zone" -instance PGType "bit" => PGType "bit[]" -instance PGType "bit" => PGArrayType "bit[]" "bit" -instance PGType "varbit" => PGType "varbit[]" -instance PGType "varbit" => PGArrayType "varbit[]" "varbit" -instance PGType "numeric" => PGType "numeric[]" -instance PGType "numeric" => PGArrayType "numeric[]" "numeric" -instance PGType "refcursor" => PGType "refcursor[]" -instance PGType "refcursor" => PGArrayType "refcursor[]" "refcursor" -instance PGType "regprocedure" => PGType "regprocedure[]" -instance PGType "regprocedure" => PGArrayType "regprocedure[]" "regprocedure" -instance PGType "regoper" => PGType "regoper[]" -instance PGType "regoper" => PGArrayType "regoper[]" "regoper" -instance PGType "regoperator" => PGType "regoperator[]" -instance PGType "regoperator" => PGArrayType "regoperator[]" "regoperator" -instance PGType "regclass" => PGType "regclass[]" -instance PGType "regclass" => PGArrayType "regclass[]" "regclass" -instance PGType "regtype" => PGType "regtype[]" -instance PGType "regtype" => PGArrayType "regtype[]" "regtype" -instance PGType "record" => PGType "record[]" -instance PGType "record" => PGArrayType "record[]" "record" -instance PGType "cstring" => PGType "cstring[]" -instance PGType "cstring" => PGArrayType "cstring[]" "cstring" -instance PGType "uuid" => PGType "uuid[]" -instance PGType "uuid" => PGArrayType "uuid[]" "uuid" -instance PGType "txid_snapshot" => PGType "txid_snapshot[]" -instance PGType "txid_snapshot" => PGArrayType "txid_snapshot[]" "txid_snapshot" -instance PGType "tsvector" => PGType "tsvector[]" -instance PGType "tsvector" => PGArrayType "tsvector[]" "tsvector" -instance PGType "tsquery" => PGType "tsquery[]" -instance PGType "tsquery" => PGArrayType "tsquery[]" "tsquery" -instance PGType "gtsvector" => PGType "gtsvector[]" -instance PGType "gtsvector" => PGArrayType "gtsvector[]" "gtsvector" -instance PGType "regconfig" => PGType "regconfig[]" -instance PGType "regconfig" => PGArrayType "regconfig[]" "regconfig" -instance PGType "regdictionary" => PGType "regdictionary[]" -instance PGType "regdictionary" => PGArrayType "regdictionary[]" "regdictionary" -instance PGType "int4range" => PGType "int4range[]" -instance PGType "int4range" => PGArrayType "int4range[]" "int4range" -instance PGType "numrange" => PGType "numrange[]" -instance PGType "numrange" => PGArrayType "numrange[]" "numrange" -instance PGType "tsrange" => PGType "tsrange[]" -instance PGType "tsrange" => PGArrayType "tsrange[]" "tsrange" -instance PGType "tstzrange" => PGType "tstzrange[]" -instance PGType "tstzrange" => PGArrayType "tstzrange[]" "tstzrange" -instance PGType "daterange" => PGType "daterange[]" -instance PGType "daterange" => PGArrayType "daterange[]" "daterange" -instance PGType "int8range" => PGType "int8range[]" -instance PGType "int8range" => PGArrayType "int8range[]" "int8range" +instance PGType "polygon" => PGType "polygon[]" where + type PGVal "polygon[]" = PGArray (PGVal "polygon") +instance PGType "polygon" => PGArrayType "polygon[]" where + type PGElemType "polygon[]" = "polygon" +instance PGType "line" => PGType "line[]" where + type PGVal "line[]" = PGArray (PGVal "line") +instance PGType "line" => PGArrayType "line[]" where + type PGElemType "line[]" = "line" +instance PGType "cidr" => PGType "cidr[]" where + type PGVal "cidr[]" = PGArray (PGVal "cidr") +instance PGType "cidr" => PGArrayType "cidr[]" where + type PGElemType "cidr[]" = "cidr" +instance PGType "real" => PGType "real[]" where + type PGVal "real[]" = PGArray (PGVal "real") +instance PGType "real" => PGArrayType "real[]" where + type PGElemType "real[]" = "real" +instance PGType "double precision" => PGType "double precision[]" where + type PGVal "double precision[]" = PGArray (PGVal "double precision") +instance PGType "double precision" => PGArrayType "double precision[]" where + type PGElemType "double precision[]" = "double precision" +instance PGType "abstime" => PGType "abstime[]" where + type PGVal "abstime[]" = PGArray (PGVal "abstime") +instance PGType "abstime" => PGArrayType "abstime[]" where + type PGElemType "abstime[]" = "abstime" +instance PGType "reltime" => PGType "reltime[]" where + type PGVal "reltime[]" = PGArray (PGVal "reltime") +instance PGType "reltime" => PGArrayType "reltime[]" where + type PGElemType "reltime[]" = "reltime" +instance PGType "tinterval" => PGType "tinterval[]" where + type PGVal "tinterval[]" = PGArray (PGVal "tinterval") +instance PGType "tinterval" => PGArrayType "tinterval[]" where + type PGElemType "tinterval[]" = "tinterval" +instance PGType "circle" => PGType "circle[]" where + type PGVal "circle[]" = PGArray (PGVal "circle") +instance PGType "circle" => PGArrayType "circle[]" where + type PGElemType "circle[]" = "circle" +instance PGType "money" => PGType "money[]" where + type PGVal "money[]" = PGArray (PGVal "money") +instance PGType "money" => PGArrayType "money[]" where + type PGElemType "money[]" = "money" +instance PGType "macaddr" => PGType "macaddr[]" where + type PGVal "macaddr[]" = PGArray (PGVal "macaddr") +instance PGType "macaddr" => PGArrayType "macaddr[]" where + type PGElemType "macaddr[]" = "macaddr" +instance PGType "inet" => PGType "inet[]" where + type PGVal "inet[]" = PGArray (PGVal "inet") +instance PGType "inet" => PGArrayType "inet[]" where + type PGElemType "inet[]" = "inet" +instance PGType "aclitem" => PGType "aclitem[]" where + type PGVal "aclitem[]" = PGArray (PGVal "aclitem") +instance PGType "aclitem" => PGArrayType "aclitem[]" where + type PGElemType "aclitem[]" = "aclitem" +instance PGType "bpchar" => PGType "bpchar[]" where + type PGVal "bpchar[]" = PGArray (PGVal "bpchar") +instance PGType "bpchar" => PGArrayType "bpchar[]" where + type PGElemType "bpchar[]" = "bpchar" +instance PGType "character varying" => PGType "character varying[]" where + type PGVal "character varying[]" = PGArray (PGVal "character varying") +instance PGType "character varying" => PGArrayType "character varying[]" where + type PGElemType "character varying[]" = "character varying" +instance PGType "date" => PGType "date[]" where + type PGVal "date[]" = PGArray (PGVal "date") +instance PGType "date" => PGArrayType "date[]" where + type PGElemType "date[]" = "date" +instance PGType "time without time zone" => PGType "time without time zone[]" where + type PGVal "time without time zone[]" = PGArray (PGVal "time without time zone") +instance PGType "time without time zone" => PGArrayType "time without time zone[]" where + type PGElemType "time without time zone[]" = "time without time zone" +instance PGType "timestamp without time zone" => PGType "timestamp without time zone[]" where + type PGVal "timestamp without time zone[]" = PGArray (PGVal "timestamp without time zone") +instance PGType "timestamp without time zone" => PGArrayType "timestamp without time zone[]" where + type PGElemType "timestamp without time zone[]" = "timestamp without time zone" +instance PGType "timestamp with time zone" => PGType "timestamp with time zone[]" where + type PGVal "timestamp with time zone[]" = PGArray (PGVal "timestamp with time zone") +instance PGType "timestamp with time zone" => PGArrayType "timestamp with time zone[]" where + type PGElemType "timestamp with time zone[]" = "timestamp with time zone" +instance PGType "interval" => PGType "interval[]" where + type PGVal "interval[]" = PGArray (PGVal "interval") +instance PGType "interval" => PGArrayType "interval[]" where + type PGElemType "interval[]" = "interval" +instance PGType "time with time zone" => PGType "time with time zone[]" where + type PGVal "time with time zone[]" = PGArray (PGVal "time with time zone") +instance PGType "time with time zone" => PGArrayType "time with time zone[]" where + type PGElemType "time with time zone[]" = "time with time zone" +instance PGType "bit" => PGType "bit[]" where + type PGVal "bit[]" = PGArray (PGVal "bit") +instance PGType "bit" => PGArrayType "bit[]" where + type PGElemType "bit[]" = "bit" +instance PGType "varbit" => PGType "varbit[]" where + type PGVal "varbit[]" = PGArray (PGVal "varbit") +instance PGType "varbit" => PGArrayType "varbit[]" where + type PGElemType "varbit[]" = "varbit" +instance PGType "numeric" => PGType "numeric[]" where + type PGVal "numeric[]" = PGArray (PGVal "numeric") +instance PGType "numeric" => PGArrayType "numeric[]" where + type PGElemType "numeric[]" = "numeric" +instance PGType "refcursor" => PGType "refcursor[]" where + type PGVal "refcursor[]" = PGArray (PGVal "refcursor") +instance PGType "refcursor" => PGArrayType "refcursor[]" where + type PGElemType "refcursor[]" = "refcursor" +instance PGType "regprocedure" => PGType "regprocedure[]" where + type PGVal "regprocedure[]" = PGArray (PGVal "regprocedure") +instance PGType "regprocedure" => PGArrayType "regprocedure[]" where + type PGElemType "regprocedure[]" = "regprocedure" +instance PGType "regoper" => PGType "regoper[]" where + type PGVal "regoper[]" = PGArray (PGVal "regoper") +instance PGType "regoper" => PGArrayType "regoper[]" where + type PGElemType "regoper[]" = "regoper" +instance PGType "regoperator" => PGType "regoperator[]" where + type PGVal "regoperator[]" = PGArray (PGVal "regoperator") +instance PGType "regoperator" => PGArrayType "regoperator[]" where + type PGElemType "regoperator[]" = "regoperator" +instance PGType "regclass" => PGType "regclass[]" where + type PGVal "regclass[]" = PGArray (PGVal "regclass") +instance PGType "regclass" => PGArrayType "regclass[]" where + type PGElemType "regclass[]" = "regclass" +instance PGType "regtype" => PGType "regtype[]" where + type PGVal "regtype[]" = PGArray (PGVal "regtype") +instance PGType "regtype" => PGArrayType "regtype[]" where + type PGElemType "regtype[]" = "regtype" +instance PGType "record" => PGType "record[]" where + type PGVal "record[]" = PGArray (PGVal "record") +instance PGType "record" => PGArrayType "record[]" where + type PGElemType "record[]" = "record" +instance PGType "cstring" => PGType "cstring[]" where + type PGVal "cstring[]" = PGArray (PGVal "cstring") +instance PGType "cstring" => PGArrayType "cstring[]" where + type PGElemType "cstring[]" = "cstring" +instance PGType "uuid" => PGType "uuid[]" where + type PGVal "uuid[]" = PGArray (PGVal "uuid") +instance PGType "uuid" => PGArrayType "uuid[]" where + type PGElemType "uuid[]" = "uuid" +instance PGType "txid_snapshot" => PGType "txid_snapshot[]" where + type PGVal "txid_snapshot[]" = PGArray (PGVal "txid_snapshot") +instance PGType "txid_snapshot" => PGArrayType "txid_snapshot[]" where + type PGElemType "txid_snapshot[]" = "txid_snapshot" +instance PGType "tsvector" => PGType "tsvector[]" where + type PGVal "tsvector[]" = PGArray (PGVal "tsvector") +instance PGType "tsvector" => PGArrayType "tsvector[]" where + type PGElemType "tsvector[]" = "tsvector" +instance PGType "tsquery" => PGType "tsquery[]" where + type PGVal "tsquery[]" = PGArray (PGVal "tsquery") +instance PGType "tsquery" => PGArrayType "tsquery[]" where + type PGElemType "tsquery[]" = "tsquery" +instance PGType "gtsvector" => PGType "gtsvector[]" where + type PGVal "gtsvector[]" = PGArray (PGVal "gtsvector") +instance PGType "gtsvector" => PGArrayType "gtsvector[]" where + type PGElemType "gtsvector[]" = "gtsvector" +instance PGType "regconfig" => PGType "regconfig[]" where + type PGVal "regconfig[]" = PGArray (PGVal "regconfig") +instance PGType "regconfig" => PGArrayType "regconfig[]" where + type PGElemType "regconfig[]" = "regconfig" +instance PGType "regdictionary" => PGType "regdictionary[]" where + type PGVal "regdictionary[]" = PGArray (PGVal "regdictionary") +instance PGType "regdictionary" => PGArrayType "regdictionary[]" where + type PGElemType "regdictionary[]" = "regdictionary" +instance PGType "int4range" => PGType "int4range[]" where + type PGVal "int4range[]" = PGArray (PGVal "int4range") +instance PGType "int4range" => PGArrayType "int4range[]" where + type PGElemType "int4range[]" = "int4range" +instance PGType "numrange" => PGType "numrange[]" where + type PGVal "numrange[]" = PGArray (PGVal "numrange") +instance PGType "numrange" => PGArrayType "numrange[]" where + type PGElemType "numrange[]" = "numrange" +instance PGType "tsrange" => PGType "tsrange[]" where + type PGVal "tsrange[]" = PGArray (PGVal "tsrange") +instance PGType "tsrange" => PGArrayType "tsrange[]" where + type PGElemType "tsrange[]" = "tsrange" +instance PGType "tstzrange" => PGType "tstzrange[]" where + type PGVal "tstzrange[]" = PGArray (PGVal "tstzrange") +instance PGType "tstzrange" => PGArrayType "tstzrange[]" where + type PGElemType "tstzrange[]" = "tstzrange" +instance PGType "daterange" => PGType "daterange[]" where + type PGVal "daterange[]" = PGArray (PGVal "daterange") +instance PGType "daterange" => PGArrayType "daterange[]" where + type PGElemType "daterange[]" = "daterange" +instance PGType "int8range" => PGType "int8range[]" where + type PGVal "int8range[]" = PGArray (PGVal "int8range") +instance PGType "int8range" => PGArrayType "int8range[]" where + type PGElemType "int8range[]" = "int8range" diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 5a9fb89..f04394c 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies, UndecidableSuperClasses #-} -- | -- Module: Database.PostgreSQL.Typed.Dynamic -- Copyright: 2015 Dylan Simon diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 41e623c..1d6d03c 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -70,7 +70,9 @@ makePGEnum name typs valnf = do [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []] (TH.NormalB $ TH.LitE v) []) valn ] - , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) [] + , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) + [ TH.TySynInstD ''PGVal $ TH.TySynEqn [typl] typt + ] , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgEncode $ map (\(n, l, _) -> TH.Clause [TH.WildP, TH.ConP n []] (TH.NormalB $ TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) []) valn diff --git a/Database/PostgreSQL/Typed/Inet.hs b/Database/PostgreSQL/Typed/Inet.hs index 983fedc..8631797 100644 --- a/Database/PostgreSQL/Typed/Inet.hs +++ b/Database/PostgreSQL/Typed/Inet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Inet @@ -120,8 +120,10 @@ instance Read PGInet where jb :: Word8 -> Word8 -> Word16 jb x y = fromIntegral x `shiftL` 8 .|. fromIntegral y -instance PGType "inet" -instance PGType "cidr" +instance PGType "inet" where + type PGVal "inet" = PGInet +instance PGType "cidr" where + type PGVal "cidr" = PGInet instance PGParameter "inet" PGInet where pgEncode _ = BSC.pack . show instance PGParameter "cidr" PGInet where diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index c981b1c..749bc87 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings, TypeFamilies, UndecidableSuperClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range @@ -21,6 +21,7 @@ import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) #endif +import GHC.TypeLits (Symbol) import Database.PostgreSQL.Typed.Types @@ -216,11 +217,12 @@ instance Ord a => Monoid (Range a) where -- |Class indicating that the first PostgreSQL type is a range of the second. -- This implies 'PGParameter' and 'PGColumn' instances that will work for any type. -class (PGType tr, PGType t) => PGRangeType tr t | tr -> t where - pgRangeElementType :: PGTypeName tr -> PGTypeName t +class (PGType t, PGType (PGSubType t)) => PGRangeType t where + type PGSubType t :: Symbol + pgRangeElementType :: PGTypeName t -> PGTypeName (PGSubType t) pgRangeElementType PGTypeProxy = PGTypeProxy -instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range a) where +instance (PGRangeType t, PGParameter (PGSubType t) a) => PGParameter t (Range a) where pgEncode _ Empty = BSC.pack "empty" pgEncode tr (Range (Lower l) (Upper u)) = buildPGValue $ pc '[' '(' l @@ -232,7 +234,7 @@ instance (PGRangeType tr t, PGParameter t a) => PGParameter tr (Range a) where pb Nothing = mempty pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b pc c o b = BSB.char7 $ if boundClosed b then c else o -instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where +instance (PGRangeType t, PGColumn (PGSubType t) a) => PGColumn t (Range a) where pgDecode tr a = either (error . ("pgDecode range (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly per a where per = (Empty <$ pe) <> pr pe = P.stringCI "empty" @@ -247,16 +249,28 @@ instance (PGRangeType tr t, PGColumn t a) => PGColumn tr (Range a) where uc <- pc ']' ')' return $ Range (Lower (mb lc lb)) (Upper (mb uc ub)) -instance PGType "int4range" -instance PGRangeType "int4range" "integer" -instance PGType "numrange" -instance PGRangeType "numrange" "numeric" -instance PGType "tsrange" -instance PGRangeType "tsrange" "timestamp without time zone" -instance PGType "tstzrange" -instance PGRangeType "tstzrange" "timestamp with time zone" -instance PGType "daterange" -instance PGRangeType "daterange" "date" -instance PGType "int8range" -instance PGRangeType "int8range" "bigint" +instance PGType "int4range" where + type PGVal "int4range" = Range (PGVal (PGSubType "int4range")) +instance PGRangeType "int4range" where + type PGSubType "int4range" = "integer" +instance PGType "numrange" where + type PGVal "numrange" = Range (PGVal (PGSubType "numrange")) +instance PGRangeType "numrange" where + type PGSubType "numrange" = "numeric" +instance PGType "tsrange" where + type PGVal "tsrange" = Range (PGVal (PGSubType "tsrange")) +instance PGRangeType "tsrange" where + type PGSubType "tsrange" = "timestamp without time zone" +instance PGType "tstzrange" where + type PGVal "tstzrange" = Range (PGVal (PGSubType "tstzrange")) +instance PGRangeType "tstzrange" where + type PGSubType "tstzrange" = "timestamp with time zone" +instance PGType "daterange" where + type PGVal "daterange" = Range (PGVal (PGSubType "daterange")) +instance PGRangeType "daterange" where + type PGSubType "daterange" = "date" +instance PGType "int8range" where + type PGVal "int8range" = Range (PGVal (PGSubType "int8range")) +instance PGRangeType "int8range" where + type PGSubType "int8range" = "bigint" diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 6a4c512..23c0b2b 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, UndecidableInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableSuperClasses #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif @@ -118,7 +118,8 @@ data PGTypeName (t :: Symbol) = PGTypeProxy -- |A valid PostgreSQL type. -- This is just an indicator class: no implementation is needed. -- Unfortunately this will generate orphan instances wherever used. -class KnownSymbol t => PGType t where +class (KnownSymbol t, PGParameter t (PGVal t), PGColumn t (PGVal t)) => PGType t where + type PGVal t :: * pgTypeName :: PGTypeName t -> String pgTypeName = symbolVal -- |Does this type support binary decoding? @@ -232,7 +233,8 @@ binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ #define BIN_DEC(F) #endif -instance PGType "any" +instance PGType "any" where + type PGVal "any" = PGValue instance PGType t => PGColumn t PGValue where pgDecode _ = PGTextValue pgDecodeBinary _ _ = PGBinaryValue @@ -243,7 +245,8 @@ instance PGParameter "any" PGValue where pgEncode _ (PGBinaryValue _) = error "pgEncode any: binary" pgEncodeValue _ _ = id -instance PGType "void" +instance PGType "void" where + type PGVal "void" = () instance PGParameter "void" () where pgEncode _ _ = BSC.empty instance PGColumn "void" () where @@ -251,7 +254,9 @@ instance PGColumn "void" () where pgDecodeBinary _ _ _ = () pgDecodeValue _ _ _ = () -instance PGType "boolean" where BIN_COL +instance PGType "boolean" where + type PGVal "boolean" = Bool + BIN_COL instance PGParameter "boolean" Bool where pgEncode _ False = BSC.singleton 'f' pgEncode _ True = BSC.singleton 't' @@ -266,7 +271,9 @@ instance PGColumn "boolean" Bool where BIN_DEC(BinD.bool) type OID = Word32 -instance PGType "oid" where BIN_COL +instance PGType "oid" where + type PGVal "oid" = OID + BIN_COL instance PGParameter "oid" OID where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -275,7 +282,9 @@ instance PGColumn "oid" OID where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.int) -instance PGType "smallint" where BIN_COL +instance PGType "smallint" where + type PGVal "smallint" = Int16 + BIN_COL instance PGParameter "smallint" Int16 where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -284,7 +293,9 @@ instance PGColumn "smallint" Int16 where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.int) -instance PGType "integer" where BIN_COL +instance PGType "integer" where + type PGVal "integer" = Int32 + BIN_COL instance PGParameter "integer" Int32 where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -293,7 +304,9 @@ instance PGColumn "integer" Int32 where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.int) -instance PGType "bigint" where BIN_COL +instance PGType "bigint" where + type PGVal "bigint" = Int64 + BIN_COL instance PGParameter "bigint" Int64 where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -302,7 +315,9 @@ instance PGColumn "bigint" Int64 where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.int) -instance PGType "real" where BIN_COL +instance PGType "real" where + type PGVal "real" = Float + BIN_COL instance PGParameter "real" Float where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -314,7 +329,9 @@ instance PGColumn "real" Double where pgDecode _ = read . BSC.unpack BIN_DEC(realToFrac <$> BinD.float4) -instance PGType "double precision" where BIN_COL +instance PGType "double precision" where + type PGVal "double precision" = Double + BIN_COL instance PGParameter "double precision" Double where pgEncode _ = BSC.pack . show pgLiteral = pgEncode @@ -327,7 +344,9 @@ instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.float8) -instance PGType "\"char\"" where BIN_COL +instance PGType "\"char\"" where + type PGVal "\"char\"" = Word8 + BIN_COL instance PGParameter "\"char\"" Word8 where pgEncode _ = BS.singleton BIN_ENC(BinE.char . w2c) @@ -395,12 +414,23 @@ instance PGStringType t => PGParameter t TL.Text where instance PGStringType t => PGColumn t TL.Text where pgDecode _ = TL.fromStrict . TE.decodeUtf8 BIN_DEC(BinD.text_lazy) -#endif - -instance PGType "text" where BIN_COL -instance PGType "character varying" where BIN_COL -instance PGType "name" where BIN_COL -instance PGType "bpchar" where BIN_COL +#define PGVALSTRING T.Text +#else +#define PGVALSTRING String +#endif + +instance PGType "text" where + type PGVal "text" = PGVALSTRING + BIN_COL +instance PGType "character varying" where + type PGVal "character varying" = PGVALSTRING + BIN_COL +instance PGType "name" where + type PGVal "name" = PGVALSTRING + BIN_COL +instance PGType "bpchar" where + type PGVal "bpchar" = PGVALSTRING + BIN_COL instance PGStringType "text" instance PGStringType "character varying" instance PGStringType "name" -- limit 63 characters; not strictly textsend but essentially the same @@ -421,7 +451,9 @@ decodeBytea s pd [x] = error $ "pgDecode bytea: " ++ show x unhex = fromIntegral . digitToInt . w2c -instance PGType "bytea" where BIN_COL +instance PGType "bytea" where + type PGVal "bytea" = BS.ByteString + BIN_COL instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} @@ -462,7 +494,9 @@ readTime = #endif defaultTimeLocale -instance PGType "date" where BIN_COL +instance PGType "date" where + type PGVal "date" = Time.Day + BIN_COL instance PGParameter "date" Time.Day where pgEncode _ = BSC.pack . Time.showGregorian pgLiteral t = pgQuoteUnsafe . pgEncode t @@ -500,6 +534,7 @@ fixTZ ['-',h1,h2,m1,m2] | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = fixTZ (c:s) = c:fixTZ s instance PGType "time without time zone" where + type PGVal "time without time zone" = Time.TimeOfDay pgBinaryColumn = binColDatetime instance PGParameter "time without time zone" Time.TimeOfDay where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%T%Q" @@ -514,6 +549,7 @@ instance PGColumn "time without time zone" Time.TimeOfDay where #endif instance PGType "time with time zone" where + type PGVal "time with time zone" = (Time.TimeOfDay, Time.TimeZone) pgBinaryColumn = binColDatetime instance PGParameter "time with time zone" (Time.TimeOfDay, Time.TimeZone) where pgEncode _ (t, z) = BSC.pack $ Time.formatTime defaultTimeLocale "%T%Q" t ++ fixTZ (Time.formatTime defaultTimeLocale "%z" z) @@ -528,6 +564,7 @@ instance PGColumn "time with time zone" (Time.TimeOfDay, Time.TimeZone) where #endif instance PGType "timestamp without time zone" where + type PGVal "timestamp without time zone" = Time.LocalTime pgBinaryColumn = binColDatetime instance PGParameter "timestamp without time zone" Time.LocalTime where pgEncode _ = BSC.pack . Time.formatTime defaultTimeLocale "%F %T%Q" @@ -542,6 +579,7 @@ instance PGColumn "timestamp without time zone" Time.LocalTime where #endif instance PGType "timestamp with time zone" where + type PGVal "timestamp with time zone" = Time.UTCTime pgBinaryColumn = binColDatetime instance PGParameter "timestamp with time zone" Time.UTCTime where pgEncode _ = BSC.pack . fixTZ . Time.formatTime defaultTimeLocale "%F %T%Q%z" @@ -556,6 +594,7 @@ instance PGColumn "timestamp with time zone" Time.UTCTime where #endif instance PGType "interval" where + type PGVal "interval" = Time.DiffTime pgBinaryColumn = binColDatetime instance PGParameter "interval" Time.DiffTime where pgEncode _ = BSC.pack . show @@ -587,7 +626,14 @@ instance PGColumn "interval" Time.DiffTime where pgDecodeBinary = binDecDatetime BinD.interval_int BinD.interval_float #endif -instance PGType "numeric" where BIN_COL +instance PGType "numeric" where + type PGVal "numeric" = +#ifdef VERSION_scientific + Scientific +#else + Rational +#endif + BIN_COL instance PGParameter "numeric" Rational where pgEncode _ r | denominator r == 0 = BSC.pack "NaN" -- this can't happen @@ -627,7 +673,9 @@ instance PGColumn "numeric" Scientific where #endif #ifdef VERSION_uuid -instance PGType "uuid" where BIN_COL +instance PGType "uuid" where + type PGVal "uuid" = UUID.UUID + BIN_COL instance PGParameter "uuid" UUID.UUID where pgEncode _ = UUID.toASCIIBytes pgLiteral t = pgQuoteUnsafe . pgEncode t @@ -650,13 +698,16 @@ instance PGRecordType t => PGColumn t PGRecord where pa = P.char '(' *> P.sepBy el (P.char ',') <* P.char ')' <* P.endOfInput el = parsePGDQuote True "()," BS.null -instance PGType "record" +instance PGType "record" where + type PGVal "record" = PGRecord -- |The generic anonymous record type, as created by @ROW@. -- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals). instance PGRecordType "record" #ifdef VERSION_aeson -instance PGType "json" where BIN_COL +instance PGType "json" where + type PGVal "json" = JSON.Value + BIN_COL instance PGParameter "json" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode BIN_ENC(BinE.json_ast) @@ -664,7 +715,9 @@ instance PGColumn "json" JSON.Value where pgDecode _ j = either (error . ("pgDecode json (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j BIN_DEC(BinD.json_ast) -instance PGType "jsonb" +instance PGType "jsonb" where + type PGVal "jsonb" = JSON.Value + BIN_COL instance PGParameter "jsonb" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode BIN_ENC(BinE.jsonb_ast) From 8d0c8d65f8239142c7000ecebda5c84227518b98 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 12 Oct 2016 15:45:30 -0400 Subject: [PATCH 202/306] Make cyclic superclasses only on ghc 8 --- Database/PostgreSQL/Typed/Array.hs | 5 ++++- Database/PostgreSQL/Typed/Dynamic.hs | 5 ++++- Database/PostgreSQL/Typed/Range.hs | 5 ++++- Database/PostgreSQL/Typed/Types.hs | 14 +++++++++++--- 4 files changed, 23 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 7c3cbfb..5899539 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, OverloadedStrings, TypeFamilies, UndecidableSuperClasses #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, OverloadedStrings, TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index f04394c..66665f8 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies, UndecidableSuperClasses #-} +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, DataKinds, DefaultSignatures, TemplateHaskell, TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif -- | -- Module: Database.PostgreSQL.Typed.Dynamic -- Copyright: 2015 Dylan Simon diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 749bc87..0ab08f5 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings, TypeFamilies, UndecidableSuperClasses #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings, TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 23c0b2b..1df5acf 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableSuperClasses #-} +{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif -- | -- Module: Database.PostgreSQL.Typed.Types -- Copyright: 2015 Dylan Simon @@ -116,10 +119,15 @@ unknownPGTypeEnv = PGTypeEnv data PGTypeName (t :: Symbol) = PGTypeProxy -- |A valid PostgreSQL type. --- This is just an indicator class: no implementation is needed. -- Unfortunately this will generate orphan instances wherever used. -class (KnownSymbol t, PGParameter t (PGVal t), PGColumn t (PGVal t)) => PGType t where +class (KnownSymbol t +#if __GLASGOW_HASKELL__ >= 800 + , PGParameter t (PGVal t), PGColumn t (PGVal t) +#endif + ) => PGType t where + -- |The default, native Haskell representation of this type, which should be as close as possible to the PostgreSQL representation. type PGVal t :: * + -- |The string name of this type: specialized version of 'symbolVal'. pgTypeName :: PGTypeName t -> String pgTypeName = symbolVal -- |Does this type support binary decoding? From b7081d0e0e954e6eee3a7f9377b571d03b909e3a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 17 Oct 2016 16:55:20 -0400 Subject: [PATCH 203/306] Split PGTypes cache into separate module; rename PGTypeName Change HDBC describeTable table search semantics to avoid getting multiple tables. --- Database/PostgreSQL/Typed/Array.hs | 4 +- Database/PostgreSQL/Typed/Dynamic.hs | 8 +- Database/PostgreSQL/Typed/Enum.hs | 2 +- Database/PostgreSQL/Typed/HDBC.hs | 75 ++++++++--------- Database/PostgreSQL/Typed/Range.hs | 2 +- Database/PostgreSQL/Typed/TH.hs | 110 +++++++++---------------- Database/PostgreSQL/Typed/TypeCache.hs | 71 ++++++++++++++++ Database/PostgreSQL/Typed/Types.hs | 51 ++++++------ postgresql-typed.cabal | 1 + 9 files changed, 182 insertions(+), 142 deletions(-) create mode 100644 Database/PostgreSQL/Typed/TypeCache.hs diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 5899539..78f7980 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -41,10 +41,10 @@ type PGArray a = [Maybe a] -- This will only work with 1-dimensional arrays. class (PGType t, PGType (PGElemType t)) => PGArrayType t where type PGElemType t :: Symbol - pgArrayElementType :: PGTypeName t -> PGTypeName (PGElemType t) + pgArrayElementType :: PGTypeID t -> PGTypeID (PGElemType t) pgArrayElementType PGTypeProxy = PGTypeProxy -- |The character used as a delimeter. The default @,@ is correct for all standard types (except @box@). - pgArrayDelim :: PGTypeName t -> Char + pgArrayDelim :: PGTypeID t -> Char pgArrayDelim _ = ',' instance diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 66665f8..6de8b0e 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -55,7 +55,7 @@ class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where -- |The PostgreSOL type that this type should be converted to. type PGRepType a :: Symbol -pgTypeOf :: a -> PGTypeName (PGRepType a) +pgTypeOf :: a -> PGTypeID (PGRepType a) pgTypeOf _ = PGTypeProxy -- |Encode a value using 'pgEncodeValue'. @@ -68,7 +68,7 @@ pgLiteralRep x = pgLiteral (pgTypeOf x) x -- |Decode a value using 'pgDecodeValue'. pgDecodeRep :: forall a . PGRep a => PGValue -> a -pgDecodeRep = pgDecodeValue unknownPGTypeEnv (PGTypeProxy :: PGTypeName (PGRepType a)) +pgDecodeRep = pgDecodeValue unknownPGTypeEnv (PGTypeProxy :: PGTypeID (PGRepType a)) -- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement. pgLiteralString :: PGRep a => a -> String @@ -76,11 +76,11 @@ pgLiteralString = BSC.unpack . pgLiteralRep -- |Produce a safely type-cast literal value for interpolation in a SQL statement, e.g., "'123'::integer". pgSafeLiteral :: PGRep a => a -> BS.ByteString -pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) +pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeID (pgTypeOf x)) -- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. pgSafeLiteralString :: PGRep a => a -> String -pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeName (pgTypeOf x) +pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeID (pgTypeOf x) instance PGRep a => PGRep (Maybe a) where type PGRepType (Maybe a) = PGRepType a diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 1d6d03c..af9d5c8 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -44,7 +44,7 @@ pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- > instance PGRep "foo" Foo -- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] -- --- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies makePGEnum :: String -- ^ PostgreSQL enum type name -> String -- ^ Haskell type to create -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index 72b4331..f5f6f2d 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -10,9 +10,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Database.PostgreSQL.Typed.HDBC - ( Connection, connectionPG + ( Connection , connect , fromPGConnection + , withPGConnection , reloadTypes , connectionFetchSize , setFetchSize @@ -39,10 +40,10 @@ import qualified Database.HDBC.ColTypes as HDBC import System.Mem.Weak (addFinalizer) import Text.Read (readMaybe) -import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.Dynamic -import Database.PostgreSQL.Typed.TH +import Database.PostgreSQL.Typed.TypeCache import Database.PostgreSQL.Typed.SQLToken import Paths_postgresql_typed (version) @@ -54,7 +55,7 @@ import Paths_postgresql_typed (version) -- 3. It provides a mutex around the underlying 'PGConnection' for thread-safety -- data Connection = Connection - { connectionPG :: MVar PGConnection -- ^Access the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. + { connectionPG :: MVar PGConnection , connectionServerVer :: String , connectionTypes :: IntMap.IntMap SqlType , connectionFetchSize :: Word32 -- ^Number of rows to fetch (and cache) with 'HDBC.execute' and each time 'HDBC.fetchRow' requires more rows. A higher value will result in fewer round-trips to the database but potentially more wasted data. Defaults to 1. 0 means fetch all rows. @@ -71,8 +72,9 @@ sqlError = handle $ \(PGError m) -> , HDBC.seErrorMsg = f 'S' ++ ": " ++ f 'M' ++ if null fD then fD else '\n':fD } -withPG :: Connection -> (PGConnection -> IO a) -> IO a -withPG c = sqlError . withMVar (connectionPG c) +-- ^Use the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. +withPGConnection :: Connection -> (PGConnection -> IO a) -> IO a +withPGConnection c = sqlError . withMVar (connectionPG c) takePGConnection :: PGConnection -> IO (MVar PGConnection) takePGConnection pg = do @@ -101,8 +103,8 @@ connect d = sqlError $ do -- |Reload the table of all types from the database. -- This may be needed if you make structural changes to the database. reloadTypes :: Connection -> IO Connection -reloadTypes c = withPG c $ \pg -> do - t <- pgLoadTypes pg +reloadTypes c = withPGConnection c $ \pg -> do + t <- pgGetTypes pg return c{ connectionTypes = IntMap.map (sqlType $ pgTypeEnv pg) t } -- |Change the 'connectionFetchSize' for new 'HDBC.Statement's created with 'HDBC.prepare'. @@ -149,26 +151,26 @@ getType c pg nul PGColDescription{..} = ColDesc } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show colType) (fromIntegral colType) (connectionTypes c) instance HDBC.IConnection Connection where - disconnect c = withPG c + disconnect c = withPGConnection c pgDisconnectOnce - commit c = withPG c $ \pg -> do + commit c = withPGConnection c $ \pg -> do pgCommitAll pg pgBegin pg - rollback c = withPG c $ \pg -> do + rollback c = withPGConnection c $ \pg -> do pgRollbackAll pg pgBegin pg - runRaw c q = withPG c $ \pg -> + runRaw c q = withPGConnection c $ \pg -> pgSimpleQueries_ pg $ sqls q - run c q v = withPG c $ \pg -> do + run c q v = withPGConnection c $ \pg -> do let q' = sqls $ show $ placeholders 1 $ sqlTokens q v' = map encode v fromMaybe 0 <$> pgRun pg q' [] v' prepare c q = do let q' = sqls $ show $ placeholders 1 $ sqlTokens q - n <- withPG c $ \pg -> pgPrepare pg q' [] + n <- withPGConnection c $ \pg -> pgPrepare pg q' [] cr <- newIORef $ error "Cursor" let - execute v = withPG c $ \pg -> do + execute v = withPGConnection c $ \pg -> do d <- pgBind pg n (map encode v) (r, e) <- pgFetch pg n (connectionFetchSize c) modifyIORef' cr $ \p -> p @@ -181,10 +183,10 @@ instance HDBC.IConnection Connection where { HDBC.execute = execute , HDBC.executeRaw = void $ execute [] , HDBC.executeMany = mapM_ execute - , HDBC.finish = withPG c $ \pg -> do + , HDBC.finish = withPGConnection c $ \pg -> do writeIORef cr $ noCursor stmt pgClose pg n - , HDBC.fetchRow = withPG c $ \pg -> do + , HDBC.fetchRow = withPGConnection c $ \pg -> do p <- readIORef cr fmap (zipWith colDescDecode (cursorDesc p)) <$> case cursorRow p of [] | cursorActive p -> do @@ -207,9 +209,9 @@ instance HDBC.IConnection Connection where map (colDescName &&& colDesc) . cursorDesc <$> readIORef cr } writeIORef cr $ noCursor stmt - addFinalizer stmt $ withPG c $ \pg -> pgClose pg n + addFinalizer stmt $ withPGConnection c $ \pg -> pgClose pg n return stmt - clone c = withPG c $ \pg -> do + clone c = withPGConnection c $ \pg -> do pg' <- pgConnect $ pgConnectionDatabase pg pgv <- takePGConnection pg' return c{ connectionPG = pgv } @@ -219,16 +221,15 @@ instance HDBC.IConnection Connection where proxiedClientVer = HDBC.hdbcClientVer dbServerVer = connectionServerVer dbTransactionSupport _ = True - getTables c = withPG c $ \pg -> + getTables c = withPGConnection c $ \pg -> map (pgDecodeRep . head) . snd <$> pgSimpleQuery pg (BSLC.fromChunks - [ "SELECT relname " - , "FROM pg_class " - , "JOIN pg_namespace " - , "ON relnamespace = pg_namespace.oid " - , "WHERE nspname = ANY (current_schemas(false)) " - , "AND relkind IN ('r','v','m','f')" + [ "SELECT relname" + , " FROM pg_class" + , " JOIN pg_namespace ON relnamespace = pg_namespace.oid" + , " WHERE nspname = ANY (current_schemas(false))" + , " AND relkind IN ('r','v','m','f')" ]) - describeTable c t = withPG c $ \pg -> do + describeTable c t = withPGConnection c $ \pg -> do let makecol ~[attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull] = colDescName &&& colDesc $ getType c pg (Just $ not $ pgDecodeRep attnotnull) PGColDescription { colName = pgDecodeRep attname @@ -240,17 +241,11 @@ instance HDBC.IConnection Connection where , colBinary = False } map makecol . snd <$> pgSimpleQuery pg (BSLC.fromChunks - [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull " - , "FROM pg_attribute " - , "JOIN pg_class " - , "ON attrelid = pg_class.oid " - , "JOIN pg_namespace " - , "ON relnamespace = pg_namespace.oid " - , "WHERE nspname = ANY (current_schemas(false)) " - , "AND relkind IN ('r','v','m','f') " - , "AND relname = ", pgLiteralRep t - , " AND attnum > 0 AND NOT attisdropped " - , "ORDER BY attnum" + [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull" + , " FROM pg_attribute" + , " WHERE attrelid = ", pgLiteralRep t, "::regclass::oid" + , " AND attnum > 0 AND NOT attisdropped" + , " ORDER BY attrelid, attnum" ]) encodeRep :: PGRep a => a -> PGValue @@ -318,13 +313,13 @@ typeId "numeric" = HDBC.SqlDecimalT typeId "uuid" = HDBC.SqlGUIDT typeId t = HDBC.SqlUnknownT t -decodeRep :: PGColumn t a => PGTypeName t -> PGTypeEnv -> (a -> HDBC.SqlValue) -> PGValue -> HDBC.SqlValue +decodeRep :: PGColumn t a => PGTypeID t -> PGTypeEnv -> (a -> HDBC.SqlValue) -> PGValue -> HDBC.SqlValue decodeRep t e f (PGBinaryValue v) = f $ pgDecodeBinary e t v decodeRep t _ f (PGTextValue v) = f $ pgDecode t v decodeRep _ _ _ PGNullValue = HDBC.SqlNull #define DECODE(T) \ - decode T e = decodeRep (PGTypeProxy :: PGTypeName T) e + decode T e = decodeRep (PGTypeProxy :: PGTypeID T) e decode :: String -> PGTypeEnv -> PGValue -> HDBC.SqlValue DECODE("boolean") HDBC.SqlBool diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 0ab08f5..0c7fb9a 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -222,7 +222,7 @@ instance Ord a => Monoid (Range a) where -- This implies 'PGParameter' and 'PGColumn' instances that will work for any type. class (PGType t, PGType (PGSubType t)) => PGRangeType t where type PGSubType t :: Symbol - pgRangeElementType :: PGTypeName t -> PGTypeName (PGSubType t) + pgRangeElementType :: PGTypeID t -> PGTypeID (PGSubType t) pgRangeElementType PGTypeProxy = PGTypeProxy instance (PGRangeType t, PGParameter (PGSubType t) a) => PGParameter t (Range a) where diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 5ca8212..e72c34d 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -8,6 +8,7 @@ module Database.PostgreSQL.Typed.TH ( getTPGDatabase + , withTPGTypeConnection , withTPGConnection , useTPGDatabase , reloadTPGTypes @@ -16,25 +17,19 @@ module Database.PostgreSQL.Typed.TH , tpgTypeEncoder , tpgTypeDecoder , tpgTypeBinary - -- * HDBC support - , PGTypes - , pgLoadTypes ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) #endif import Control.Applicative ((<|>)) -import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, modifyMVar_) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) import Control.Exception (onException, finally) import Control.Monad (liftM2) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Data.ByteString.UTF8 as BSU 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 @@ -43,11 +38,8 @@ import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) import Database.PostgreSQL.Typed.Types -import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol - --- |A particular PostgreSQL type, identified by full formatted name (from @format_type@ or @\\dT@). -type TPGType = String +import Database.PostgreSQL.Typed.TypeCache -- |Generate a 'PGDatabase' based on the environment variables: -- @TPG_HOST@ (localhost); @TPG_SOCK@ or @TPG_PORT@ (5432); @TPG_DB@ or user; @TPG_USER@ or @USER@ (postgres); @TPG_PASS@ () @@ -70,44 +62,22 @@ getTPGDatabase = do } {-# NOINLINE tpgState #-} -tpgState :: MVar (PGDatabase, Maybe TPGState) +tpgState :: MVar (PGDatabase, Maybe PGTypeConnection) tpgState = unsafePerformIO $ do db <- unsafeInterleaveIO getTPGDatabase newMVar (db, Nothing) -data TPGState = TPGState - { tpgConnection :: PGConnection - , tpgTypes :: PGTypes - } - --- |Map keyed on fromIntegral OID. -type PGTypes = IntMap.IntMap TPGType - --- |Load a map of types from the database. -pgLoadTypes :: PGConnection -> IO PGTypes -pgLoadTypes c = - IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . - snd <$> pgSimpleQuery c (BSLC.pack "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") - -tpgLoadTypes :: TPGState -> IO TPGState -tpgLoadTypes tpg = do - t <- pgLoadTypes (tpgConnection tpg) - return tpg{ tpgTypes = t } - -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 +withTPGTypeConnection :: (PGTypeConnection -> IO a) -> IO a +withTPGTypeConnection f = do (db, tpg') <- takeMVar tpgState - tpg <- maybe (tpgInit =<< pgConnect db) return tpg' + tpg <- maybe (newPGTypeConnection =<< pgConnect db) return tpg' `onException` putMVar tpgState (db, Nothing) -- might leave connection open f tpg `finally` putMVar tpgState (db, Just tpg) -- |Run an action using the Template Haskell PostgreSQL connection. withTPGConnection :: (PGConnection -> IO a) -> IO a -withTPGConnection f = withTPGState (f . tpgConnection) +withTPGConnection f = withTPGTypeConnection (f . pgConnection) -- |Specify an alternative database to use during compilation. -- This lets you override the default connection parameters that are based on TPG environment variables. @@ -119,62 +89,64 @@ useTPGDatabase db = TH.runIO $ do 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') + c <- pgReconnect (pgConnection t) db + return t{ pgConnection = c }) tpg' + else Nothing <$ Fold.mapM_ (pgDisconnect . pgConnection) tpg') `onException` putMVar tpgState (db, Nothing) return [] -- |Force reloading of all types from the database. -- This may be needed if you make structural changes to the database during compile-time. reloadTPGTypes :: TH.DecsQ -reloadTPGTypes = TH.runIO $ [] <$ modifyMVar_ tpgState (\(d, c) -> (,) d <$> Tv.mapM tpgLoadTypes c) +reloadTPGTypes = TH.runIO $ [] <$ withMVar tpgState (mapM_ flushPGTypeConnection . snd) -- |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 ++ "\nYour postgresql-typed application may need to be rebuilt.") (fromIntegral t) types +tpgType :: PGTypeConnection -> OID -> IO PGTypeName +tpgType c o = + maybe (fail $ "Unknown PostgreSQL type: " ++ show o ++ "\nYour postgresql-typed application may need to be rebuilt.") return =<< lookupPGType c o -- |Lookup a type OID by type name. -- This is less common and thus less efficient than going the other way. -- Fail if not found. -getTPGTypeOID :: 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 +getTPGTypeOID :: PGTypeConnection -> PGTypeName -> IO OID +getTPGTypeOID c t = + maybe (fail $ "Unknown PostgreSQL type: " ++ t ++ "; be sure to use the exact type name from \\dTS") return =<< findPGType c t data TPGValueInfo = TPGValueInfo { tpgValueName :: BS.ByteString , tpgValueTypeOID :: !OID - , tpgValueType :: TPGType + , tpgValueType :: PGTypeName , tpgValueNullable :: Bool } -- |A type-aware wrapper to 'pgDescribe' tpgDescribe :: BS.ByteString -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo]) -tpgDescribe sql types nulls = withTPGState $ \tpg -> do +tpgDescribe sql types nulls = withTPGTypeConnection $ \tpg -> do at <- mapM (getTPGTypeOID tpg) types - (pt, rt) <- pgDescribe (tpgConnection tpg) (BSL.fromStrict sql) at nulls - return - ( map (\o -> TPGValueInfo - { tpgValueName = BS.empty - , tpgValueTypeOID = o - , tpgValueType = tpgType tpg o - , tpgValueNullable = True - }) pt - , map (\(c, o, n) -> TPGValueInfo - { tpgValueName = c - , tpgValueTypeOID = o - , tpgValueType = tpgType tpg o - , tpgValueNullable = n && o /= 2278 -- "void" - }) rt - ) - -typeApply :: TPGType -> TH.Name -> TH.Name -> TH.Exp + (pt, rt) <- pgDescribe (pgConnection tpg) (BSL.fromStrict sql) at nulls + (,) + <$> mapM (\o -> do + ot <- tpgType tpg o + return TPGValueInfo + { tpgValueName = BS.empty + , tpgValueTypeOID = o + , tpgValueType = ot + , tpgValueNullable = True + }) pt + <*> mapM (\(c, o, n) -> do + ot <- tpgType tpg o + return TPGValueInfo + { tpgValueName = c + , tpgValueTypeOID = o + , tpgValueType = ot + , tpgValueNullable = n && o /= 2278 -- "void" + }) rt + +typeApply :: PGTypeName -> TH.Name -> TH.Name -> TH.Exp typeApply t f e = TH.VarE f `TH.AppE` TH.VarE e - `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeName `TH.AppT` TH.LitT (TH.StrTyLit t))) + `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeID `TH.AppT` TH.LitT (TH.StrTyLit t))) -- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. diff --git a/Database/PostgreSQL/Typed/TypeCache.hs b/Database/PostgreSQL/Typed/TypeCache.hs new file mode 100644 index 0000000..45c03b9 --- /dev/null +++ b/Database/PostgreSQL/Typed/TypeCache.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.PostgreSQL.Typed.TypeCache + ( PGTypeName + , PGTypes + , pgGetTypes + , PGTypeConnection + , pgConnection + , newPGTypeConnection + , flushPGTypeConnection + , lookupPGType + , findPGType + ) where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.IntMap as IntMap +import Data.List (find) + +import Database.PostgreSQL.Typed.Types (OID) +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol + +-- |A particular PostgreSQL type, identified by full formatted name (from @format_type@ or @\\dT@). +type PGTypeName = String + +-- |Map keyed on fromIntegral OID. +type PGTypes = IntMap.IntMap PGTypeName + +-- |A 'PGConnection' along with cached information about types. +data PGTypeConnection = PGTypeConnection + { pgConnection :: !PGConnection + , pgTypes :: IORef (Maybe PGTypes) + } + +-- |Create a 'PGTypeConnection'. +newPGTypeConnection :: PGConnection -> IO PGTypeConnection +newPGTypeConnection c = do + t <- newIORef Nothing + return $ PGTypeConnection c t + +-- |Flush the cached type list, forcing it to be reloaded. +flushPGTypeConnection :: PGTypeConnection -> IO () +flushPGTypeConnection c = + writeIORef (pgTypes c) Nothing + +-- |Get a map of types from the database. +pgGetTypes :: PGConnection -> IO PGTypes +pgGetTypes c = + IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . + snd <$> pgSimpleQuery c "SELECT 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" + +-- |Get a cached map of types. +getPGTypes :: PGTypeConnection -> IO PGTypes +getPGTypes (PGTypeConnection c tr) = + maybe (do + t <- pgGetTypes c + writeIORef tr $ Just t + return t) + return + =<< readIORef tr + +-- |Lookup a type name by OID. +-- This is an efficient, often pure operation. +lookupPGType :: PGTypeConnection -> OID -> IO (Maybe PGTypeName) +lookupPGType c o = + IntMap.lookup (fromIntegral o) <$> getPGTypes c + +-- |Lookup a type OID by type name. +-- This is less common and thus less efficient than going the other way. +findPGType :: PGTypeConnection -> PGTypeName -> IO (Maybe OID) +findPGType c t = + fmap (fromIntegral . fst) . find ((==) t . snd) . IntMap.toList <$> getPGTypes c diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 1df5acf..cbb693e 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -17,7 +17,7 @@ module Database.PostgreSQL.Typed.Types OID , PGValue(..) , PGValues - , PGTypeName(..) + , PGTypeID(..) , PGTypeEnv(..) , unknownPGTypeEnv , PGRecord(..) @@ -116,10 +116,11 @@ unknownPGTypeEnv = PGTypeEnv } -- |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 +data PGTypeID (t :: Symbol) = PGTypeProxy --- |A valid PostgreSQL type. --- Unfortunately this will generate orphan instances wherever used. +-- |A valid PostgreSQL type, its metadata, and corresponding Haskell representation. +-- For conversion the other way (from Haskell type to PostgreSQL), see 'Database.PostgreSQL.Typed.Dynamic.PGRep'. +-- Unfortunately any instances of this will be orphans. class (KnownSymbol t #if __GLASGOW_HASKELL__ >= 800 , PGParameter t (PGVal t), PGColumn t (PGVal t) @@ -128,41 +129,41 @@ class (KnownSymbol t -- |The default, native Haskell representation of this type, which should be as close as possible to the PostgreSQL representation. type PGVal t :: * -- |The string name of this type: specialized version of 'symbolVal'. - pgTypeName :: PGTypeName t -> String - pgTypeName = symbolVal + pgTypeID :: PGTypeID t -> String + pgTypeID = symbolVal -- |Does this type support binary decoding? -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type. - pgBinaryColumn :: PGTypeEnv -> PGTypeName t -> Bool + pgBinaryColumn :: PGTypeEnv -> PGTypeID t -> Bool pgBinaryColumn _ _ = False -- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@. class PGType t => PGParameter t a where -- |Encode a value to a PostgreSQL text representation. - pgEncode :: PGTypeName t -> a -> PGTextValue + pgEncode :: PGTypeID t -> a -> PGTextValue -- |Encode a value to a (quoted) literal value for use in SQL statements. -- Defaults to a quoted version of 'pgEncode' - pgLiteral :: PGTypeName t -> a -> BS.ByteString + pgLiteral :: PGTypeID t -> a -> BS.ByteString pgLiteral t = pgQuote . pgEncode t -- |Encode a value to a PostgreSQL representation. -- Defaults to the text representation by pgEncode - pgEncodeValue :: PGTypeEnv -> PGTypeName t -> a -> PGValue + pgEncodeValue :: PGTypeEnv -> PGTypeID t -> a -> PGValue pgEncodeValue _ t = PGTextValue . pgEncode t -- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@. class PGType t => PGColumn t a where -- |Decode the PostgreSQL text representation into a value. - pgDecode :: PGTypeName t -> PGTextValue -> a + pgDecode :: PGTypeID t -> PGTextValue -> a -- |Decode the PostgreSQL binary representation into a value. -- Only needs to be implemented if 'pgBinaryColumn' is true. - pgDecodeBinary :: PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a - pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgTypeName t ++ ": not supported" - pgDecodeValue :: PGTypeEnv -> PGTypeName t -> PGValue -> a + pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a + pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgTypeID t ++ ": not supported" + pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> a pgDecodeValue _ t (PGTextValue v) = pgDecode t v pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v - pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgTypeName t ++ " column (use Maybe or COALESCE)" + pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgTypeID t ++ " column (use Maybe or COALESCE)" instance PGParameter t a => PGParameter t (Maybe a) where - pgEncode t = maybe (error $ "pgEncode " ++ pgTypeName t ++ ": Nothing") (pgEncode t) + pgEncode t = maybe (error $ "pgEncode " ++ pgTypeID t ++ ": Nothing") (pgEncode t) pgLiteral = maybe (BSC.pack "NULL") . pgLiteral pgEncodeValue e = maybe PGNullValue . pgEncodeValue e @@ -173,19 +174,19 @@ instance PGColumn t a => PGColumn t (Maybe a) where pgDecodeValue e t v = Just $ pgDecodeValue e t v -- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query. -pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> PGValue +pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> PGValue pgEncodeParameter = pgEncodeValue -- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query. -pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeName t -> a -> BS.ByteString +pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> BS.ByteString pgEscapeParameter _ = pgLiteral -- |Final column decoding function used for a nullable result value. -pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeName t -> PGValue -> Maybe a +pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a pgDecodeColumn = pgDecodeValue -- |Final column decoding function used for a non-nullable result value. -pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeName t -> PGValue -> a +pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeID t -> PGValue -> a pgDecodeColumnNotNull = pgDecodeValue @@ -229,8 +230,8 @@ parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where | otherwise = Just s #ifdef VERSION_postgresql_binary -binDec :: PGType t => BinD.Decoder a -> PGTypeName t -> PGBinaryValue -> a -binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeName t ++ ": " ++ show e) id . BinD.run d +binDec :: PGType t => BinD.Decoder a -> PGTypeID t -> PGBinaryValue -> a +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeID t ++ ": " ++ show e) id . BinD.run d #define BIN_COL pgBinaryColumn _ _ = True #define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . (F) @@ -513,19 +514,19 @@ instance PGColumn "date" Time.Day where pgDecode _ = readTime "%F" . BSC.unpack BIN_DEC(BinD.date) -binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool +binColDatetime :: PGTypeEnv -> PGTypeID t -> Bool #ifdef VERSION_postgresql_binary binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True #endif binColDatetime _ _ = False #ifdef VERSION_postgresql_binary -binEncDatetime :: PGParameter t a => BinE.Encoder a -> BinE.Encoder a -> PGTypeEnv -> PGTypeName t -> a -> PGValue +binEncDatetime :: PGParameter t a => BinE.Encoder a -> BinE.Encoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue binEncDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } _ = PGBinaryValue . buildPGValue . ff binEncDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } _ = PGBinaryValue . buildPGValue . fi binEncDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } t = PGTextValue . pgEncode t -binDecDatetime :: PGColumn t a => BinD.Decoder a -> BinD.Decoder a -> PGTypeEnv -> PGTypeName t -> PGBinaryValue -> a +binDecDatetime :: PGColumn t a => BinD.Decoder a -> BinD.Decoder a -> PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a binDecDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } = binDec ff binDecDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } = binDec fi binDecDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } = error "pgDecodeBinary: unknown integer_datetimes value" diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 5a8e48e..1d9fe07 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -83,6 +83,7 @@ Library Database.PostgreSQL.Typed.ErrCodes Other-Modules: Paths_postgresql_typed + Database.PostgreSQL.Typed.TypeCache GHC-Options: -Wall if flag(md5) Build-Depends: cryptonite >= 0.5, memory >= 0.5 From 71e46a86e41555ec5ec2b1fcfd41b2cad5d42634 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 17 Oct 2016 17:11:57 -0400 Subject: [PATCH 204/306] Basic TH data model derivation from PG table --- Database/PostgreSQL/Typed/Enum.hs | 17 ++++--- Database/PostgreSQL/Typed/HDBC.hs | 2 +- Database/PostgreSQL/Typed/Models.hs | 71 +++++++++++++++++++++++++++++ postgresql-typed.cabal | 1 + test/Main.hs | 14 ++++-- 5 files changed, 95 insertions(+), 10 deletions(-) create mode 100644 Database/PostgreSQL/Typed/Models.hs diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index af9d5c8..81424ce 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -8,6 +8,7 @@ module Database.PostgreSQL.Typed.Enum ( PGEnum , pgEnumValues + , dataPGEnum , makePGEnum ) where @@ -25,7 +26,7 @@ import Database.PostgreSQL.Typed.TH import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic --- |A type based on a PostgreSQL enum. Automatically instantiated by 'makePGEnum'. +-- |A type based on a PostgreSQL enum. Automatically instantiated by 'dataPGEnum'. class (Eq a, Ord a, Enum a, Bounded a, Show a) => PGEnum a -- |List of all the values in the enum along with their database names. @@ -34,7 +35,7 @@ pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- |Create a new enum type corresponding to the given PostgreSQL enum type. -- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\');@, then --- @makePGEnum \"foo\" \"Foo\" (\"Foo_\"++)@ will be equivalent to: +-- @dataPGEnum \"Foo\" \"foo\" (\"Foo_\"++)@ will be equivalent to: -- -- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable) -- > instance Show Foo where show Foo_abc = "abc" ... @@ -45,14 +46,14 @@ pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies -makePGEnum :: String -- ^ PostgreSQL enum type name - -> String -- ^ Haskell type to create +dataPGEnum :: String -- ^ Haskell type to create + -> String -- ^ PostgreSQL enum type name -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ -> TH.DecsQ -makePGEnum name typs valnf = do +dataPGEnum typs name valnf = do (_, vals) <- TH.runIO $ withTPGConnection $ \c -> pgSimpleQuery c $ BSL.fromChunks [BSC.pack "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 (fromString name), BSC.pack " ORDER BY enumsortorder"] - when (null vals) $ fail $ "makePGEnum: enum " ++ name ++ " not found" + when (null vals) $ fail $ "dataPGEnum: enum " ++ name ++ " not found" let valn = map (\[PGTextValue v] -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals dv <- TH.newName "x" @@ -99,3 +100,7 @@ makePGEnum name typs valnf = do #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif + +-- |A deprecated alias for 'dataPGEnum' with its arguments flipped. +makePGEnum :: String -> String -> (String -> String) -> TH.DecsQ +makePGEnum = flip dataPGEnum diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index f5f6f2d..8a98659 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -72,7 +72,7 @@ sqlError = handle $ \(PGError m) -> , HDBC.seErrorMsg = f 'S' ++ ": " ++ f 'M' ++ if null fD then fD else '\n':fD } --- ^Use the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. +-- |Use the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe. withPGConnection :: Connection -> (PGConnection -> IO a) -> IO a withPGConnection c = sqlError . withMVar (connectionPG c) diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Models.hs new file mode 100644 index 0000000..ce07923 --- /dev/null +++ b/Database/PostgreSQL/Typed/Models.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +-- | +-- Module: Database.PostgreSQL.Typed.Models +-- Copyright: 2016 Dylan Simon +-- +-- Automatically create data models based on tables. + +module Database.PostgreSQL.Typed.Models + ( dataPGTable + ) where + +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (fromMaybe) +import qualified Language.Haskell.TH as TH + +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TypeCache +import Database.PostgreSQL.Typed.TH + +-- |Create a new data type corresponding to the given PostgreSQL table. +-- For example, if you have @CREATE TABLE foo (abc integer NOT NULL, def text);@, then +-- @dataPGTable \"Foo\" \"foo\" (\"foo_\"++)@ will be equivalent to: +-- +-- > data Foo = Foo{ foo_abc :: PGVal "integer", foo_def :: Maybe (PGVal "text") } +-- +-- (Note that @type PGVal "integer" = Int32@ and @type PGVal "text" = Text@ by default.) +-- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving. +-- +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies +dataPGTable :: String -- ^ Haskell type and constructor to create + -> String -- ^ PostgreSQL table/relation name + -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_" ++)@ + -> TH.DecsQ +dataPGTable dats tabs colf = do + cols <- TH.runIO $ withTPGTypeConnection $ \tpg -> + mapM (\(~[cn, ct, cnn]) -> + let n = pgDecodeRep cn + o = pgDecodeRep ct in + (n, , pgDecodeRep cnn) + . fromMaybe (error $ "dataPGTable " ++ dats ++ " = " ++ tabs ++ ": column '" ++ n ++ "' has unknown type " ++ show o) + <$> lookupPGType tpg o) + . snd + =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks + [ "SELECT attname, atttypid, attnotnull" + , " FROM pg_attribute" + , " WHERE attrelid = ", pgLiteralRep tabs, "::regclass::oid" + , " AND attnum > 0 AND NOT attisdropped" + , " ORDER BY attrelid, attnum" + ]) + return [TH.DataD + [] + datn + [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + [ TH.RecC datn $ map (\(cn, ct, cnn) -> + ( TH.mkName (colf cn) + , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness + , (if cnn then id else TH.AppT (TH.ConT ''Maybe)) + (TH.ConT ''PGVal `TH.AppT` TH.LitT (TH.StrTyLit ct)))) + cols + ] + []] + where + datn = TH.mkName dats diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 1d9fe07..ee546d7 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -81,6 +81,7 @@ Library Database.PostgreSQL.Typed.TemplatePG Database.PostgreSQL.Typed.SQLToken Database.PostgreSQL.Typed.ErrCodes + Database.PostgreSQL.Typed.Models Other-Modules: Paths_postgresql_typed Database.PostgreSQL.Typed.TypeCache diff --git a/test/Main.hs b/test/Main.hs index 638d3e3..03a25ea 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- {-# OPTIONS_GHC -ddump-splices #-} +--{-# OPTIONS_GHC -ddump-splices #-} module Main (main) where import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC -import Data.Char (isDigit) +import Data.Char (isDigit, toUpper) import Data.Int (Int32) import qualified Data.Time as Time import System.Exit (exitSuccess, exitFailure) @@ -19,6 +19,7 @@ import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum import Database.PostgreSQL.Typed.Inet import Database.PostgreSQL.Typed.SQLToken +import Database.PostgreSQL.Typed.Models import Connect @@ -31,7 +32,14 @@ useTPGDatabase db -- This runs at compile-time: [pgSQL|!CREATE TYPE myenum AS enum ('abc', 'DEF', 'XX_ye')|] -makePGEnum "myenum" "MyEnum" ("MyEnum_" ++) +dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) + +[pgSQL|!CREATE TABLE myfoo (id serial primary key, adx myenum, bar char(4))|] + +dataPGTable "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) + +fooRow :: MyFoo +fooRow = MyFoo{ fooId = 1, fooAdx = Just MyEnum_DEF, fooBar = Just "abcd" } instance Q.Arbitrary MyEnum where arbitrary = Q.arbitraryBoundedEnum From 0de30a9ccacc40b7a2ed5366d47c66231ee550d8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 17 Oct 2016 17:16:15 -0400 Subject: [PATCH 205/306] Fix for ghc 7.10/template-haskell 2.10 --- Database/PostgreSQL/Typed/Models.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Models.hs index ce07923..2fc1800 100644 --- a/Database/PostgreSQL/Typed/Models.hs +++ b/Database/PostgreSQL/Typed/Models.hs @@ -61,7 +61,11 @@ dataPGTable dats tabs colf = do #endif [ TH.RecC datn $ map (\(cn, ct, cnn) -> ( TH.mkName (colf cn) +#if MIN_VERSION_template_haskell(2,11,0) , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness +#else + , TH.NotStrict +#endif , (if cnn then id else TH.AppT (TH.ConT ''Maybe)) (TH.ConT ''PGVal `TH.AppT` TH.LitT (TH.StrTyLit ct)))) cols From e129a7a48ca48de3e2d2d6ad3b3e54527a73d0a0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 17 Oct 2016 21:24:28 -0400 Subject: [PATCH 206/306] Record-type marshalling for table models This is fine, but it would be nicer to marshal multiple parameters or column returns, somehow. --- Database/PostgreSQL/Typed/Enum.hs | 38 ++++--- Database/PostgreSQL/Typed/HDBC.hs | 40 +++---- Database/PostgreSQL/Typed/Models.hs | 151 ++++++++++++++++++++----- Database/PostgreSQL/Typed/TH.hs | 2 +- Database/PostgreSQL/Typed/TypeCache.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 2 + test/Main.hs | 10 +- 7 files changed, 173 insertions(+), 72 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 81424ce..01764f1 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Database.PostgreSQL.Typed.Enum -- Copyright: 2015 Dylan Simon @@ -12,19 +13,18 @@ module Database.PostgreSQL.Typed.Enum , makePGEnum ) where -import Control.Monad (when) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import Data.Ix (Ix) -import Data.String (fromString) import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH -import Database.PostgreSQL.Typed.Protocol -import Database.PostgreSQL.Typed.TH import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic +import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.TypeCache +import Database.PostgreSQL.Typed.TH -- |A type based on a PostgreSQL enum. Automatically instantiated by 'dataPGEnum'. class (Eq a, Ord a, Enum a, Bounded a, Show a) => PGEnum a @@ -39,10 +39,10 @@ pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- -- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable) -- > instance Show Foo where show Foo_abc = "abc" ... --- > instance PGType "foo" +-- > instance PGType "foo" where PGVal "foo" = Foo -- > instance PGParameter "foo" Foo where ... -- > instance PGColumn "foo" Foo where ... --- > instance PGRep "foo" Foo +-- > instance PGRep Foo where PGRepType = "foo" -- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies @@ -50,12 +50,23 @@ dataPGEnum :: String -- ^ Haskell type to create -> String -- ^ PostgreSQL enum type name -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ -> TH.DecsQ -dataPGEnum typs name valnf = do - (_, vals) <- TH.runIO $ withTPGConnection $ \c -> - pgSimpleQuery c $ BSL.fromChunks [BSC.pack "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 (fromString name), BSC.pack " ORDER BY enumsortorder"] - when (null vals) $ fail $ "dataPGEnum: enum " ++ name ++ " not found" - let - valn = map (\[PGTextValue v] -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals +dataPGEnum typs pgenum valnf = do + (pgid, vals) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do + vals <- map (\([eo, PGTextValue v]) -> (pgDecodeRep eo, v)) . snd + <$> pgSimpleQuery (pgConnection tpg) (BSL.fromChunks + [ "SELECT enumtypid, enumlabel" + , " FROM pg_catalog.pg_enum" + , " WHERE enumtypid = ", pgLiteralRep pgenum, "::regtype" + , " ORDER BY enumsortorder" + ]) + case vals of + [] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ pgenum ++ ": no values found" + (eo, _):_ -> do + et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return + =<< lookupPGType tpg eo + return (et, map snd vals) + let valn = map (\v -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals + typl = TH.LitT (TH.StrTyLit pgid) dv <- TH.newName "x" return [ TH.DataD [] typn [] @@ -83,7 +94,7 @@ dataPGEnum typs name valnf = do (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l, _) -> TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE n) []) valn ++ [TH.Match TH.WildP (TH.NormalB $ TH.AppE (TH.VarE 'error) $ - TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ name ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) + TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) []]) []] ] @@ -95,7 +106,6 @@ dataPGEnum typs name valnf = do where typn = TH.mkName typs typt = TH.ConT typn - typl = TH.LitT (TH.StrTyLit name) instanceD = TH.InstanceD #if MIN_VERSION_template_haskell(2,11,0) Nothing diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index 8a98659..b6da468 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -224,29 +224,29 @@ instance HDBC.IConnection Connection where getTables c = withPGConnection c $ \pg -> map (pgDecodeRep . head) . snd <$> pgSimpleQuery pg (BSLC.fromChunks [ "SELECT relname" - , " FROM pg_class" - , " JOIN pg_namespace ON relnamespace = pg_namespace.oid" + , " FROM pg_catalog.pg_class" + , " JOIN pg_catalog.pg_namespace ON relnamespace = pg_namespace.oid" , " WHERE nspname = ANY (current_schemas(false))" , " AND relkind IN ('r','v','m','f')" ]) - describeTable c t = withPGConnection c $ \pg -> do - let makecol ~[attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull] = - colDescName &&& colDesc $ getType c pg (Just $ not $ pgDecodeRep attnotnull) PGColDescription - { colName = pgDecodeRep attname - , colTable = pgDecodeRep attrelid - , colNumber = pgDecodeRep attnum - , colType = pgDecodeRep atttypid - , colSize = pgDecodeRep attlen - , colModifier = pgDecodeRep atttypmod - , colBinary = False - } - map makecol . snd <$> pgSimpleQuery pg (BSLC.fromChunks - [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull" - , " FROM pg_attribute" - , " WHERE attrelid = ", pgLiteralRep t, "::regclass::oid" - , " AND attnum > 0 AND NOT attisdropped" - , " ORDER BY attrelid, attnum" - ]) + describeTable c t = withPGConnection c $ \pg -> + map (\[attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull] -> + colDescName &&& colDesc $ getType c pg (Just $ not $ pgDecodeRep attnotnull) PGColDescription + { colName = pgDecodeRep attname + , colTable = pgDecodeRep attrelid + , colNumber = pgDecodeRep attnum + , colType = pgDecodeRep atttypid + , colSize = pgDecodeRep attlen + , colModifier = pgDecodeRep atttypmod + , colBinary = False + }) + . snd <$> pgSimpleQuery pg (BSLC.fromChunks + [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull" + , " FROM pg_catalog.pg_attribute" + , " WHERE attrelid = ", pgLiteralRep t, "::regclass" + , " AND attnum > 0 AND NOT attisdropped" + , " ORDER BY attrelid, attnum" + ]) encodeRep :: PGRep a => a -> PGValue encodeRep x = PGTextValue $ pgEncode (pgTypeOf x) x diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Models.hs index 2fc1800..b2f3fe9 100644 --- a/Database/PostgreSQL/Typed/Models.hs +++ b/Database/PostgreSQL/Typed/Models.hs @@ -13,7 +13,6 @@ module Database.PostgreSQL.Typed.Models ) where import qualified Data.ByteString.Lazy as BSL -import Data.Maybe (fromMaybe) import qualified Language.Haskell.TH as TH import Database.PostgreSQL.Typed.Types @@ -27,49 +26,139 @@ import Database.PostgreSQL.Typed.TH -- @dataPGTable \"Foo\" \"foo\" (\"foo_\"++)@ will be equivalent to: -- -- > data Foo = Foo{ foo_abc :: PGVal "integer", foo_def :: Maybe (PGVal "text") } +-- > instance PGType "foo" where PGVal "foo" = Foo +-- > instance PGParameter "foo" Foo where ... +-- > instance PGColumn "foo" Foo where ... +-- > instance PGColumn "foo" (Maybe Foo) where ... -- to handle NULL in not null columns +-- > instance PGRep Foo where PGRepType = "foo" +-- > instance PGRecordType "foo" -- -- (Note that @type PGVal "integer" = Int32@ and @type PGVal "text" = Text@ by default.) +-- This provides instances for marshalling the corresponding composite/record types, e.g., using @SELECT foo.*::foo FROM foo@. -- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving. -- --- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies +-- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds, TypeFamilies, PatternGuards dataPGTable :: String -- ^ Haskell type and constructor to create -> String -- ^ PostgreSQL table/relation name -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_" ++)@ -> TH.DecsQ -dataPGTable dats tabs colf = do - cols <- TH.runIO $ withTPGTypeConnection $ \tpg -> - mapM (\(~[cn, ct, cnn]) -> +dataPGTable typs pgtab colf = do + (pgid, cold) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do + cl <- mapM (\[to, cn, ct, cnn] -> do let n = pgDecodeRep cn - o = pgDecodeRep ct in - (n, , pgDecodeRep cnn) - . fromMaybe (error $ "dataPGTable " ++ dats ++ " = " ++ tabs ++ ": column '" ++ n ++ "' has unknown type " ++ show o) - <$> lookupPGType tpg o) - . snd - =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks - [ "SELECT attname, atttypid, attnotnull" - , " FROM pg_attribute" - , " WHERE attrelid = ", pgLiteralRep tabs, "::regclass::oid" - , " AND attnum > 0 AND NOT attisdropped" - , " ORDER BY attrelid, attnum" - ]) - return [TH.DataD - [] - datn - [] + o = pgDecodeRep ct + t <- maybe (fail $ "dataPGTable " ++ typs ++ " = " ++ pgtab ++ ": column '" ++ n ++ "' has unknown type " ++ show o) return + =<< lookupPGType tpg o + return (pgDecodeRep to, (n, TH.LitT (TH.StrTyLit t), pgDecodeRep cnn))) + . snd =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks + [ "SELECT reltype, attname, atttypid, attnotnull" + , " FROM pg_catalog.pg_attribute" + , " JOIN pg_catalog.pg_class ON attrelid = pg_class.oid" + , " WHERE attrelid = ", pgLiteralRep pgtab, "::regclass" + , " AND attnum > 0 AND NOT attisdropped" + , " ORDER BY attnum" + ]) + case cl of + [] -> fail $ "dataPGTable " ++ typs ++ " = " ++ pgtab ++ ": no columns found" + (to, _):_ -> do + tt <- maybe (fail $ "dataPGTable " ++ typs ++ " = " ++ pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return + =<< lookupPGType tpg to + return (tt, map snd cl) + cols <- mapM (\(n, t, nn) -> do + v <- TH.newName n + return (v, t, not nn)) + cold + let typl = TH.LitT (TH.StrTyLit pgid) + encfun f = TH.FunD f [TH.Clause [TH.WildP, TH.ConP typn (map (\(v, _, _) -> TH.VarP v) cols)] + (TH.NormalB $ pgcall f rect `TH.AppE` + (TH.ConE 'PGRecord `TH.AppE` TH.ListE (map (colenc f) cols))) + [] ] + dv <- TH.newName "x" + tv <- TH.newName "t" + ev <- TH.newName "e" + return + [ TH.DataD + [] + typn + [] #if MIN_VERSION_template_haskell(2,11,0) - Nothing + Nothing #endif - [ TH.RecC datn $ map (\(cn, ct, cnn) -> - ( TH.mkName (colf cn) + [ TH.RecC typn $ map (\(n, t, nn) -> + ( TH.mkName (colf n) #if MIN_VERSION_template_haskell(2,11,0) - , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness + , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness #else - , TH.NotStrict + , TH.NotStrict #endif - , (if cnn then id else TH.AppT (TH.ConT ''Maybe)) - (TH.ConT ''PGVal `TH.AppT` TH.LitT (TH.StrTyLit ct)))) - cols + , (if nn then id else (TH.ConT ''Maybe `TH.AppT`)) + (TH.ConT ''PGVal `TH.AppT` t))) + cold + ] + [] + , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) + [ TH.TySynInstD ''PGVal $ TH.TySynEqn [typl] typt + ] + , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) + [ encfun 'pgEncode + , encfun 'pgLiteral + ] + , instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) + [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.GuardedB + [ (TH.PatG [TH.BindS + (TH.ConP 'PGRecord [TH.ListP $ map colpat cols]) + (pgcall 'pgDecode rect `TH.AppE` TH.VarE dv)] + , foldl (\f -> TH.AppE f . coldec) (TH.ConE typn) cols) + , (TH.NormalG (TH.ConE 'True) + , TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL $ "pgDecode " ++ typs ++ ": NULL in not null record column")) + ]) + [] ] + ] +#if MIN_VERSION_template_haskell(2,11,0) + , TH.InstanceD (Just TH.Overlapping) [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` (TH.ConT ''Maybe `TH.AppT` typt)) + [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.GuardedB + [ (TH.PatG [TH.BindS + (TH.ConP 'PGRecord [TH.ListP $ map colpat cols]) + (pgcall 'pgDecode rect `TH.AppE` TH.VarE dv)] + , TH.ConE 'Just `TH.AppE` foldl (\f -> TH.AppE f . coldec) (TH.ConE typn) cols) + , (TH.NormalG (TH.ConE 'True) + , TH.ConE 'Nothing) + ]) + [] ] +#endif + , TH.FunD 'pgDecodeValue + [ TH.Clause [TH.WildP, TH.WildP, TH.ConP 'PGNullValue []] + (TH.NormalB $ TH.ConE 'Nothing) + [] + , TH.Clause [TH.WildP, TH.VarP tv, TH.ConP 'PGTextValue [TH.VarP dv]] + (TH.NormalB $ TH.VarE 'pgDecode `TH.AppE` TH.VarE tv `TH.AppE` TH.VarE dv) + [] + , TH.Clause [TH.VarP ev, TH.VarP tv, TH.ConP 'PGBinaryValue [TH.VarP dv]] + (TH.NormalB $ TH.VarE 'pgDecodeBinary `TH.AppE` TH.VarE ev `TH.AppE` TH.VarE tv `TH.AppE` TH.VarE dv) + [] + ] + ] + , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) + [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl + ] + , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] ] - []] where - datn = TH.mkName dats + typn = TH.mkName typs + typt = TH.ConT typn + instanceD = TH.InstanceD +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + pgcall f t = TH.VarE f `TH.AppE` + (TH.ConE 'PGTypeProxy `TH.SigE` + (TH.ConT ''PGTypeID `TH.AppT` t)) + colenc f (v, t, False) = TH.ConE 'Just `TH.AppE` (pgcall f t `TH.AppE` TH.VarE v) + colenc f (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall f t `TH.AppE` TH.VarE v + colpat (v, _, False) = TH.ConP 'Just [TH.VarP v] + colpat (v, _, True) = TH.VarP v + coldec (v, t, False) = pgcall 'pgDecode t `TH.AppE` TH.VarE v + coldec (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall 'pgDecode t `TH.AppE` TH.VarE v + rect = TH.LitT $ TH.StrTyLit "record" diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index e72c34d..11328b8 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -104,7 +104,7 @@ reloadTPGTypes = TH.runIO $ [] <$ withMVar tpgState (mapM_ flushPGTypeConnection -- Error if not found. tpgType :: PGTypeConnection -> OID -> IO PGTypeName tpgType c o = - maybe (fail $ "Unknown PostgreSQL type: " ++ show o ++ "\nYour postgresql-typed application may need to be rebuilt.") return =<< lookupPGType c o + maybe (fail $ "Unknown PostgreSQL type: " ++ show o ++ "\nYou may need to use reloadTPGTypes or adjust search_path, or your postgresql-typed application may need to be rebuilt.") return =<< lookupPGType c o -- |Lookup a type OID by type name. -- This is less common and thus less efficient than going the other way. diff --git a/Database/PostgreSQL/Typed/TypeCache.hs b/Database/PostgreSQL/Typed/TypeCache.hs index 45c03b9..a862bb6 100644 --- a/Database/PostgreSQL/Typed/TypeCache.hs +++ b/Database/PostgreSQL/Typed/TypeCache.hs @@ -46,7 +46,7 @@ flushPGTypeConnection c = pgGetTypes :: PGConnection -> IO PGTypes pgGetTypes c = IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . - snd <$> pgSimpleQuery c "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" + snd <$> pgSimpleQuery c "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 = ANY (current_schemas(true)) ORDER BY typ.oid" -- |Get a cached map of types. getPGTypes :: PGTypeConnection -> IO PGTypes diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index cbb693e..3a83932 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -26,6 +26,8 @@ module Database.PostgreSQL.Typed.Types , PGType(..) , PGParameter(..) , PGColumn(..) + , PGStringType + , PGRecordType -- * Marshalling interface , pgEncodeParameter diff --git a/test/Main.hs b/test/Main.hs index 03a25ea..9252214 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies, PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --{-# OPTIONS_GHC -ddump-splices #-} module Main (main) where @@ -32,14 +32,14 @@ useTPGDatabase db -- This runs at compile-time: [pgSQL|!CREATE TYPE myenum AS enum ('abc', 'DEF', 'XX_ye')|] -dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) - [pgSQL|!CREATE TABLE myfoo (id serial primary key, adx myenum, bar char(4))|] +dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) + dataPGTable "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) -fooRow :: MyFoo -fooRow = MyFoo{ fooId = 1, fooAdx = Just MyEnum_DEF, fooBar = Just "abcd" } +_fooRow :: MyFoo +_fooRow = MyFoo{ fooId = 1, fooAdx = Just MyEnum_DEF, fooBar = Just "abcd" } instance Q.Arbitrary MyEnum where arbitrary = Q.arbitraryBoundedEnum From 78e992cfd169fb3de845e24de69aef5692d05c78 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 18 Oct 2016 13:18:44 -0400 Subject: [PATCH 207/306] Generate uncurryFoo function from dataPGTable --- Database/PostgreSQL/Typed/Models.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Models.hs index b2f3fe9..0d6650b 100644 --- a/Database/PostgreSQL/Typed/Models.hs +++ b/Database/PostgreSQL/Typed/Models.hs @@ -32,8 +32,9 @@ import Database.PostgreSQL.Typed.TH -- > instance PGColumn "foo" (Maybe Foo) where ... -- to handle NULL in not null columns -- > instance PGRep Foo where PGRepType = "foo" -- > instance PGRecordType "foo" +-- > uncurryFoo :: (PGVal "integer", Maybe (PGVal "text")) -> Foo -- --- (Note that @type PGVal "integer" = Int32@ and @type PGVal "text" = Text@ by default.) +-- (Note that @PGVal "integer" = Int32@ and @PGVal "text" = Text@ by default.) -- This provides instances for marshalling the corresponding composite/record types, e.g., using @SELECT foo.*::foo FROM foo@. -- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving. -- @@ -144,6 +145,17 @@ dataPGTable typs pgtab colf = do [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl ] , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] + , TH.SigD (TH.mkName ("uncurry" ++ typs)) $ TH.ArrowT `TH.AppT` + foldl (\f (_, t, n) -> f `TH.AppT` + (if n then (TH.ConT ''Maybe `TH.AppT`) else id) + (TH.ConT ''PGVal `TH.AppT` t)) + (TH.ConT (TH.tupleTypeName (length cols))) + cols `TH.AppT` typt + , TH.FunD (TH.mkName ("uncurry" ++ typs)) + [ TH.Clause [TH.ConP (TH.tupleDataName (length cols)) (map (\(v, _, _) -> TH.VarP v) cols)] + (TH.NormalB $ foldl (\f (v, _, _) -> f `TH.AppE` TH.VarE v) (TH.ConE typn) cols) + [] + ] ] where typn = TH.mkName typs From c51911c31c5a3eb9398dc66cd9836db503efaa84 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 18 Oct 2016 13:20:26 -0400 Subject: [PATCH 208/306] Fix for ghc 7.10 --- Database/PostgreSQL/Typed/Models.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Models.hs index 0d6650b..60b2357 100644 --- a/Database/PostgreSQL/Typed/Models.hs +++ b/Database/PostgreSQL/Typed/Models.hs @@ -128,7 +128,6 @@ dataPGTable typs pgtab colf = do , TH.ConE 'Nothing) ]) [] ] -#endif , TH.FunD 'pgDecodeValue [ TH.Clause [TH.WildP, TH.WildP, TH.ConP 'PGNullValue []] (TH.NormalB $ TH.ConE 'Nothing) @@ -141,6 +140,7 @@ dataPGTable typs pgtab colf = do [] ] ] +#endif , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl ] From 65d6487556b72a8e979a35b93b5b6826017630f8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 18 Oct 2016 13:43:51 -0400 Subject: [PATCH 209/306] Update license --- COPYING | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/COPYING b/COPYING index a8ddaa4..e077c9c 100644 --- a/COPYING +++ b/COPYING @@ -1,4 +1,4 @@ -Copyright (c) 2014, 2015, Dylan Simon +Copyright (c) 2014-2016, Dylan Simon Portions Copyright (c) 2010, 2011, Chris Forno All rights reserved. @@ -9,9 +9,9 @@ modification, are permitted provided that the following conditions are met: * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Chris Forno nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. + * Neither the name of postgresql-typed nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED From 158d8a86a086d060ef5cfeb602af02cf302ee15e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 18 Oct 2016 18:40:44 -0400 Subject: [PATCH 210/306] Create PGRelation class for table data types --- Database/PostgreSQL/Typed/Enum.hs | 7 ++++-- Database/PostgreSQL/Typed/Models.hs | 35 ++++++++++++++++++++--------- test/Main.hs | 2 +- 3 files changed, 31 insertions(+), 13 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 01764f1..5c58821 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif -- | -- Module: Database.PostgreSQL.Typed.Enum -- Copyright: 2015 Dylan Simon @@ -27,14 +30,14 @@ import Database.PostgreSQL.Typed.TypeCache import Database.PostgreSQL.Typed.TH -- |A type based on a PostgreSQL enum. Automatically instantiated by 'dataPGEnum'. -class (Eq a, Ord a, Enum a, Bounded a, Show a) => PGEnum a +class (Eq a, Ord a, Enum a, Bounded a, Show a, PGRep a) => PGEnum a -- |List of all the values in the enum along with their database names. pgEnumValues :: PGEnum a => [(a, String)] pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- |Create a new enum type corresponding to the given PostgreSQL enum type. --- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\');@, then +-- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\')@, then -- @dataPGEnum \"Foo\" \"foo\" (\"Foo_\"++)@ will be equivalent to: -- -- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable) diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Models.hs index 60b2357..abe5d7e 100644 --- a/Database/PostgreSQL/Typed/Models.hs +++ b/Database/PostgreSQL/Typed/Models.hs @@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif -- | -- Module: Database.PostgreSQL.Typed.Models -- Copyright: 2016 Dylan Simon @@ -9,7 +13,7 @@ -- Automatically create data models based on tables. module Database.PostgreSQL.Typed.Models - ( dataPGTable + ( dataPGRelation ) where import qualified Data.ByteString.Lazy as BSL @@ -21,9 +25,14 @@ import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TypeCache import Database.PostgreSQL.Typed.TH --- |Create a new data type corresponding to the given PostgreSQL table. --- For example, if you have @CREATE TABLE foo (abc integer NOT NULL, def text);@, then --- @dataPGTable \"Foo\" \"foo\" (\"foo_\"++)@ will be equivalent to: +-- |Data types that are based on database relations. +class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where + -- |Database names of columns. Argument value is ignored. + pgColumnNames :: a -> [String] + +-- |Create a new data type corresponding to the given PostgreSQL relation. +-- For example, if you have @CREATE TABLE foo (abc integer NOT NULL, def text)@, then +-- @dataPGRelation \"Foo\" \"foo\" (\"foo_\"++)@ will be equivalent to: -- -- > data Foo = Foo{ foo_abc :: PGVal "integer", foo_def :: Maybe (PGVal "text") } -- > instance PGType "foo" where PGVal "foo" = Foo @@ -32,6 +41,7 @@ import Database.PostgreSQL.Typed.TH -- > instance PGColumn "foo" (Maybe Foo) where ... -- to handle NULL in not null columns -- > instance PGRep Foo where PGRepType = "foo" -- > instance PGRecordType "foo" +-- > instance PGRelation Foo where pgColumnNames _ = ["abc", "def"] -- > uncurryFoo :: (PGVal "integer", Maybe (PGVal "text")) -> Foo -- -- (Note that @PGVal "integer" = Int32@ and @PGVal "text" = Text@ by default.) @@ -39,16 +49,16 @@ import Database.PostgreSQL.Typed.TH -- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving. -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds, TypeFamilies, PatternGuards -dataPGTable :: String -- ^ Haskell type and constructor to create +dataPGRelation :: String -- ^ Haskell type and constructor to create -> String -- ^ PostgreSQL table/relation name -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_" ++)@ -> TH.DecsQ -dataPGTable typs pgtab colf = do +dataPGRelation typs pgtab colf = do (pgid, cold) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do cl <- mapM (\[to, cn, ct, cnn] -> do let n = pgDecodeRep cn o = pgDecodeRep ct - t <- maybe (fail $ "dataPGTable " ++ typs ++ " = " ++ pgtab ++ ": column '" ++ n ++ "' has unknown type " ++ show o) return + t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ pgtab ++ ": column '" ++ n ++ "' has unknown type " ++ show o) return =<< lookupPGType tpg o return (pgDecodeRep to, (n, TH.LitT (TH.StrTyLit t), pgDecodeRep cnn))) . snd =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks @@ -60,9 +70,9 @@ dataPGTable typs pgtab colf = do , " ORDER BY attnum" ]) case cl of - [] -> fail $ "dataPGTable " ++ typs ++ " = " ++ pgtab ++ ": no columns found" + [] -> fail $ "dataPGRelation " ++ typs ++ " = " ++ pgtab ++ ": no columns found" (to, _):_ -> do - tt <- maybe (fail $ "dataPGTable " ++ typs ++ " = " ++ pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return + tt <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return =<< lookupPGType tpg to return (tt, map snd cl) cols <- mapM (\(n, t, nn) -> do @@ -145,6 +155,11 @@ dataPGTable typs pgtab colf = do [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl ] , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] + , instanceD [] (TH.ConT ''PGRelation `TH.AppT` typt) + [ TH.FunD 'pgColumnNames [TH.Clause [TH.WildP] + (TH.NormalB $ TH.ListE $ map (\(n, _, _) -> TH.LitE $ TH.StringL n) cold) + [] ] + ] , TH.SigD (TH.mkName ("uncurry" ++ typs)) $ TH.ArrowT `TH.AppT` foldl (\f (_, t, n) -> f `TH.AppT` (if n then (TH.ConT ''Maybe `TH.AppT`) else id) diff --git a/test/Main.hs b/test/Main.hs index 9252214..2b4a7af 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -36,7 +36,7 @@ useTPGDatabase db dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) -dataPGTable "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) +dataPGRelation "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) _fooRow :: MyFoo _fooRow = MyFoo{ fooId = 1, fooAdx = Just MyEnum_DEF, fooBar = Just "abcd" } From 279e12f390257e219a22fe790f6be34c9ea38414 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 1 Nov 2016 16:05:21 -0400 Subject: [PATCH 211/306] Add some more documentation about makePGQuery Relevant to #2 --- Database/PostgreSQL/Typed/Query.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 95c6703..156c917 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -170,6 +170,13 @@ newName :: Char -> BS.ByteString -> TH.Q TH.Name newName pre = TH.newName . ('_':) . (pre:) . filter (\c -> isAlphaNum c || c == '_') . BSC.unpack -- |Construct a 'PGQuery' from a SQL string. +-- This is the underlying template function for 'pgSQL' which you can use in largely the same way when you want to construct query strings from other variables. +-- For example: +-- +-- > selectQuery = "SELECT * FROM" +-- > selectFoo = $(makePGQuery simpleQueryFlags (selectQuery ++ " foo")) +-- +-- The only caveat is that variables or functions like @selectQuery@ need to be defined in a different module (due to TH stage restrictions). makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do @@ -257,6 +264,8 @@ qqTop err sql = do -- -- 'pgSQL' can also be used at the top-level to execute SQL statements at compile-time (without any parameters and ignoring results). -- Here the query can only be prefixed with @!@ to make errors non-fatal. +-- +-- If you want to construct queries out of string variables rather than quasi-quoted strings, you can use the lower-level 'makePGQuery' instead. pgSQL :: QuasiQuoter pgSQL = QuasiQuoter { quoteExp = qqQuery From f2a5f0225c19f9e549fb9fa8e171adbd6f2d65fd Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 1 Nov 2016 16:08:07 -0400 Subject: [PATCH 212/306] Rename Database.PostgreSQL.Typed.Models to Relation Since this is to relations as, say, Enum is to Enums, this seems to make more sense. Models could eventually provide more composability. --- Database/PostgreSQL/Typed/{Models.hs => Relation.hs} | 4 ++-- postgresql-typed.cabal | 2 +- test/Main.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) rename Database/PostgreSQL/Typed/{Models.hs => Relation.hs} (98%) diff --git a/Database/PostgreSQL/Typed/Models.hs b/Database/PostgreSQL/Typed/Relation.hs similarity index 98% rename from Database/PostgreSQL/Typed/Models.hs rename to Database/PostgreSQL/Typed/Relation.hs index abe5d7e..234cc5e 100644 --- a/Database/PostgreSQL/Typed/Models.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -7,12 +7,12 @@ {-# LANGUAGE UndecidableSuperClasses #-} #endif -- | --- Module: Database.PostgreSQL.Typed.Models +-- Module: Database.PostgreSQL.Typed.Relation -- Copyright: 2016 Dylan Simon -- -- Automatically create data models based on tables. -module Database.PostgreSQL.Typed.Models +module Database.PostgreSQL.Typed.Relation ( dataPGRelation ) where diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index ee546d7..ee22ce2 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -81,7 +81,7 @@ Library Database.PostgreSQL.Typed.TemplatePG Database.PostgreSQL.Typed.SQLToken Database.PostgreSQL.Typed.ErrCodes - Database.PostgreSQL.Typed.Models + Database.PostgreSQL.Typed.Relation Other-Modules: Paths_postgresql_typed Database.PostgreSQL.Typed.TypeCache diff --git a/test/Main.hs b/test/Main.hs index 2b4a7af..0ef08ea 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -19,7 +19,7 @@ import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum import Database.PostgreSQL.Typed.Inet import Database.PostgreSQL.Typed.SQLToken -import Database.PostgreSQL.Typed.Models +import Database.PostgreSQL.Typed.Relation import Connect From 18b0fb80082923d5ad6db37161eb537dc548e0a3 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 1 Nov 2016 16:16:24 -0400 Subject: [PATCH 213/306] Add PGRelation.pgRelationName --- Database/PostgreSQL/Typed/Relation.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index 234cc5e..5161f52 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -25,8 +25,12 @@ import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.TypeCache import Database.PostgreSQL.Typed.TH --- |Data types that are based on database relations. +-- |Data types that are based on database relations. +-- Normally these instances are created using 'dataPGRelation'. class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where + -- |Database name of table/relation (i.e., second argument to 'dataPGRelation'). Normally this is the same as @'pgTypeID' . 'pgTypeOf'@, but this preserves any specified schema qualification. Argument value is ignored. + pgRelationName :: a -> String + pgRelationName = pgTypeID . pgTypeOf -- |Database names of columns. Argument value is ignored. pgColumnNames :: a -> [String] @@ -156,7 +160,10 @@ dataPGRelation typs pgtab colf = do ] , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] , instanceD [] (TH.ConT ''PGRelation `TH.AppT` typt) - [ TH.FunD 'pgColumnNames [TH.Clause [TH.WildP] + [ TH.FunD 'pgRelationName [TH.Clause [TH.WildP] + (TH.NormalB $ TH.LitE $ TH.StringL pgtab) + [] ] + , TH.FunD 'pgColumnNames [TH.Clause [TH.WildP] (TH.NormalB $ TH.ListE $ map (\(n, _, _) -> TH.LitE $ TH.StringL n) cold) [] ] ] From 354bd5756909445650010371089b767b1cf6af58 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 4 Nov 2016 20:11:02 -0400 Subject: [PATCH 214/306] Allow referencing types/tables from other namespaces This includes postgres namespaces that add a lot of cruft like information_schema and pg_toast. --- Database/PostgreSQL/Typed/TypeCache.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/TypeCache.hs b/Database/PostgreSQL/Typed/TypeCache.hs index a862bb6..1c17a43 100644 --- a/Database/PostgreSQL/Typed/TypeCache.hs +++ b/Database/PostgreSQL/Typed/TypeCache.hs @@ -46,7 +46,7 @@ flushPGTypeConnection c = pgGetTypes :: PGConnection -> IO PGTypes pgGetTypes c = IntMap.fromAscList . map (\[to, tn] -> (fromIntegral (pgDecodeRep to :: OID), pgDecodeRep tn)) . - snd <$> pgSimpleQuery c "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 = ANY (current_schemas(true)) ORDER BY typ.oid" + snd <$> pgSimpleQuery c "SELECT oid, format_type(CASE WHEN typtype = 'd' THEN typbasetype ELSE oid END, -1) FROM pg_catalog.pg_type ORDER BY oid" -- |Get a cached map of types. getPGTypes :: PGTypeConnection -> IO PGTypes diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 3a83932..4aba5e2 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -117,7 +117,8 @@ unknownPGTypeEnv = PGTypeEnv { pgIntegerDatetimes = Nothing } --- |A proxy type for PostgreSQL types. The type argument should be an (internal) name of a database type (see @\\dT+@). +-- |A proxy type for PostgreSQL types. The type argument should be an (internal) name of a database type, as per @format_type(OID)@ (usually the same as @\\dT+@). +-- When the type's namespace (schema) is not in @search_path@, this will be explicitly qualified, so you should be sure to have a consistent @search_path@ for all database connections. data PGTypeID (t :: Symbol) = PGTypeProxy -- |A valid PostgreSQL type, its metadata, and corresponding Haskell representation. From b51e17f37d05ab663f66750d97c3ade40b5aa44b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 5 Nov 2016 14:05:51 -0400 Subject: [PATCH 215/306] Introduce PGName abstraction for postgresql identifiers --- Database/PostgreSQL/Typed/Dynamic.hs | 13 +++- Database/PostgreSQL/Typed/Enum.hs | 86 +++++++++++++++----------- Database/PostgreSQL/Typed/HDBC.hs | 2 +- Database/PostgreSQL/Typed/Relation.hs | 38 +++++++----- Database/PostgreSQL/Typed/TH.hs | 15 ++--- Database/PostgreSQL/Typed/TypeCache.hs | 14 ++--- Database/PostgreSQL/Typed/Types.hs | 46 +++++++++++--- test/Main.hs | 4 +- 8 files changed, 136 insertions(+), 82 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 6de8b0e..38b3dab 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -12,6 +12,7 @@ module Database.PostgreSQL.Typed.Dynamic ( PGRep(..) , pgTypeOf + , pgTypeOfProxy , pgEncodeRep , pgDecodeRep , pgLiteralRep @@ -30,8 +31,9 @@ import qualified Data.Aeson as JSON import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL -import Data.Monoid ((<>)) import Data.Int +import Data.Monoid ((<>)) +import Data.Proxy (Proxy) #ifdef VERSION_scientific import Data.Scientific (Scientific) #endif @@ -58,6 +60,9 @@ class (PGParameter (PGRepType a) a, PGColumn (PGRepType a) a) => PGRep a where pgTypeOf :: a -> PGTypeID (PGRepType a) pgTypeOf _ = PGTypeProxy +pgTypeOfProxy :: Proxy a -> PGTypeID (PGRepType a) +pgTypeOfProxy _ = PGTypeProxy + -- |Encode a value using 'pgEncodeValue'. pgEncodeRep :: PGRep a => a -> PGValue pgEncodeRep x = pgEncodeValue unknownPGTypeEnv (pgTypeOf x) x @@ -76,11 +81,11 @@ pgLiteralString = BSC.unpack . pgLiteralRep -- |Produce a safely type-cast literal value for interpolation in a SQL statement, e.g., "'123'::integer". pgSafeLiteral :: PGRep a => a -> BS.ByteString -pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeID (pgTypeOf x)) +pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> pgNameBS (pgTypeName (pgTypeOf x)) -- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. pgSafeLiteralString :: PGRep a => a -> String -pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeID (pgTypeOf x) +pgSafeLiteralString x = pgLiteralString x ++ "::" ++ BSC.unpack (pgNameBS (pgTypeName (pgTypeOf x))) instance PGRep a => PGRep (Maybe a) where type PGRepType (Maybe a) = PGRepType a @@ -107,6 +112,8 @@ instance PGRep String where type PGRepType String = "text" instance PGRep BS.ByteString where type PGRepType BS.ByteString = "text" +instance PGRep PGName where + type PGRepType PGName = "text" -- superset of "name" #ifdef VERSION_text instance PGRep T.Text where type PGRepType T.Text = "text" diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 5c58821..91bcf70 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -10,17 +10,18 @@ -- Support for PostgreSQL enums. module Database.PostgreSQL.Typed.Enum - ( PGEnum - , pgEnumValues + ( PGEnum(..) , dataPGEnum - , makePGEnum ) where +import Control.Arrow ((&&&)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL -import Data.Ix (Ix) -import Data.Typeable (Typeable) +import Data.Ix (Ix) +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple (swap) +import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH import Database.PostgreSQL.Typed.Types @@ -30,18 +31,23 @@ import Database.PostgreSQL.Typed.TypeCache import Database.PostgreSQL.Typed.TH -- |A type based on a PostgreSQL enum. Automatically instantiated by 'dataPGEnum'. -class (Eq a, Ord a, Enum a, Bounded a, Show a, PGRep a) => PGEnum a - --- |List of all the values in the enum along with their database names. -pgEnumValues :: PGEnum a => [(a, String)] -pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound +class (Eq a, Ord a, Enum a, Bounded a, PGRep a) => PGEnum a where + {-# MINIMAL pgEnumName | pgEnumValues #-} + -- |The database name of a value. + pgEnumName :: a -> PGName + pgEnumName a = fromJust $ lookup a pgEnumValues + -- |Lookup a value matching the given database name. + pgEnumValue :: PGName -> Maybe a + pgEnumValue n = lookup n $ map swap pgEnumValues + -- |List of all the values in the enum along with their database names. + pgEnumValues :: [(a, PGName)] + pgEnumValues = map (id &&& pgEnumName) $ enumFromTo minBound maxBound -- |Create a new enum type corresponding to the given PostgreSQL enum type. -- For example, if you have @CREATE TYPE foo AS ENUM (\'abc\', \'DEF\')@, then -- @dataPGEnum \"Foo\" \"foo\" (\"Foo_\"++)@ will be equivalent to: -- -- > data Foo = Foo_abc | Foo_DEF deriving (Eq, Ord, Enum, Bounded, Typeable) --- > instance Show Foo where show Foo_abc = "abc" ... -- > instance PGType "foo" where PGVal "foo" = Foo -- > instance PGParameter "foo" Foo where ... -- > instance PGColumn "foo" Foo where ... @@ -50,12 +56,12 @@ pgEnumValues = map (\e -> (e, show e)) $ enumFromTo minBound maxBound -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies dataPGEnum :: String -- ^ Haskell type to create - -> String -- ^ PostgreSQL enum type name - -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ + -> PGName -- ^ PostgreSQL enum type name + -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ (input is 'pgNameString') -> TH.DecsQ dataPGEnum typs pgenum valnf = do (pgid, vals) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do - vals <- map (\([eo, PGTextValue v]) -> (pgDecodeRep eo, v)) . snd + vals <- map (\([eo, v]) -> (pgDecodeRep eo, pgDecodeRep v)) . snd <$> pgSimpleQuery (pgConnection tpg) (BSL.fromChunks [ "SELECT enumtypid, enumlabel" , " FROM pg_catalog.pg_enum" @@ -63,48 +69,58 @@ dataPGEnum typs pgenum valnf = do , " ORDER BY enumsortorder" ]) case vals of - [] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ pgenum ++ ": no values found" + [] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ pgNameString pgenum ++ ": no values found" (eo, _):_ -> do - et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return + et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ pgNameString pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return =<< lookupPGType tpg eo return (et, map snd vals) - let valn = map (\v -> let u = BSC.unpack v in (TH.mkName $ valnf u, map (TH.IntegerL . fromIntegral) $ BS.unpack v, TH.StringL u)) vals - typl = TH.LitT (TH.StrTyLit pgid) + let valn = map (TH.mkName . valnf . pgNameString &&& map (TH.IntegerL . fromIntegral) . BS.unpack . pgNameBS) vals + typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) dv <- TH.newName "x" return [ TH.DataD [] typn [] #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif - (map (\(n, _, _) -> TH.NormalC n []) valn) $ + (map (\(n, _) -> TH.NormalC n []) valn) $ #if MIN_VERSION_template_haskell(2,11,0) map TH.ConT #endif [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] - , instanceD [] (TH.ConT ''Show `TH.AppT` typt) - [ TH.FunD 'show $ map (\(n, _, v) -> TH.Clause [TH.ConP n []] - (TH.NormalB $ TH.LitE v) []) valn - ] , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) [ TH.TySynInstD ''PGVal $ TH.TySynEqn [typl] typt ] , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) - [ TH.FunD 'pgEncode $ map (\(n, l, _) -> TH.Clause [TH.WildP, TH.ConP n []] - (TH.NormalB $ TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) []) valn + [ TH.FunD 'pgEncode [TH.Clause [TH.WildP, TH.VarP dv] + (TH.NormalB $ TH.VarE 'pgNameBS `TH.AppE` (TH.VarE 'pgEnumName `TH.AppE` TH.VarE dv)) + []] ] , instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] - (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l, _) -> - TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE n) []) valn ++ - [TH.Match TH.WildP (TH.NormalB $ TH.AppE (TH.VarE 'error) $ - TH.InfixE (Just $ TH.LitE (TH.StringL ("pgDecode " ++ pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) - []]) - []] + (TH.NormalB $ TH.VarE 'fromMaybe `TH.AppE` + (TH.AppE (TH.VarE 'error) $ + TH.InfixE (Just $ TH.LitE (TH.StringL ("pgEnumValue " ++ pgNameString pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) + `TH.AppE` (TH.VarE 'pgEnumValue `TH.AppE` (TH.ConE 'PGName `TH.AppE` TH.VarE dv))) + []] ] , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl ] - , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) [] + , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) + [ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [TH.ConP n []] + (TH.NormalB $ namelit l) + []) valn + , TH.FunD 'pgEnumValue [TH.Clause [TH.ConP 'PGName [TH.VarP dv]] + (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l) -> + TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE 'Just `TH.AppE` TH.ConE n) []) valn ++ + [TH.Match TH.WildP (TH.NormalB $ TH.ConE 'Nothing) + []]) + []] + , TH.FunD 'pgEnumValues [TH.Clause [] + (TH.NormalB $ TH.ListE $ map (\(n, l) -> + TH.ConE '(,) `TH.AppE` TH.ConE n `TH.AppE` namelit l) valn) + []] + ] ] where typn = TH.mkName typs @@ -113,7 +129,5 @@ dataPGEnum typs pgenum valnf = do #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif - --- |A deprecated alias for 'dataPGEnum' with its arguments flipped. -makePGEnum :: String -> String -> (String -> String) -> TH.DecsQ -makePGEnum = flip dataPGEnum + namelit l = TH.ConE 'PGName `TH.AppE` + (TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index b6da468..a6bc385 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -105,7 +105,7 @@ connect d = sqlError $ do reloadTypes :: Connection -> IO Connection reloadTypes c = withPGConnection c $ \pg -> do t <- pgGetTypes pg - return c{ connectionTypes = IntMap.map (sqlType $ pgTypeEnv pg) t } + return c{ connectionTypes = IntMap.map (sqlType (pgTypeEnv pg) . pgNameString) t } -- |Change the 'connectionFetchSize' for new 'HDBC.Statement's created with 'HDBC.prepare'. -- Ideally this could be set with each call to 'HDBC.execute' and 'HDBC.fetchRow', but the HDBC interface provides no way to do this. diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index 5161f52..895e559 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -10,13 +10,15 @@ -- Module: Database.PostgreSQL.Typed.Relation -- Copyright: 2016 Dylan Simon -- --- Automatically create data models based on tables. +-- Automatically create data types based on tables and other relations. module Database.PostgreSQL.Typed.Relation ( dataPGRelation ) where +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Proxy (Proxy(..)) import qualified Language.Haskell.TH as TH import Database.PostgreSQL.Typed.Types @@ -28,11 +30,11 @@ import Database.PostgreSQL.Typed.TH -- |Data types that are based on database relations. -- Normally these instances are created using 'dataPGRelation'. class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where - -- |Database name of table/relation (i.e., second argument to 'dataPGRelation'). Normally this is the same as @'pgTypeID' . 'pgTypeOf'@, but this preserves any specified schema qualification. Argument value is ignored. - pgRelationName :: a -> String - pgRelationName = pgTypeID . pgTypeOf - -- |Database names of columns. Argument value is ignored. - pgColumnNames :: a -> [String] + -- |Database name of table/relation (i.e., second argument to 'dataPGRelation'). Normally this is the same as @'pgTypeID' . 'pgTypeOfProxy'@, but this preserves any specified schema qualification. + pgRelationName :: Proxy a -> PGName + pgRelationName = pgTypeName . pgTypeOfProxy + -- |Database names of columns. + pgColumnNames :: Proxy a -> [PGName] -- |Create a new data type corresponding to the given PostgreSQL relation. -- For example, if you have @CREATE TABLE foo (abc integer NOT NULL, def text)@, then @@ -54,17 +56,17 @@ class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds, TypeFamilies, PatternGuards dataPGRelation :: String -- ^ Haskell type and constructor to create - -> String -- ^ PostgreSQL table/relation name - -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_" ++)@ + -> PGName -- ^ PostgreSQL table/relation name + -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_"++)@ (input is 'pgNameString') -> TH.DecsQ dataPGRelation typs pgtab colf = do (pgid, cold) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do cl <- mapM (\[to, cn, ct, cnn] -> do let n = pgDecodeRep cn o = pgDecodeRep ct - t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ pgtab ++ ": column '" ++ n ++ "' has unknown type " ++ show o) return + t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": column '" ++ show n ++ "' has unknown type " ++ show o) return =<< lookupPGType tpg o - return (pgDecodeRep to, (n, TH.LitT (TH.StrTyLit t), pgDecodeRep cnn))) + return (pgDecodeRep to, (n, TH.LitT (TH.StrTyLit $ pgNameString t), pgDecodeRep cnn))) . snd =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks [ "SELECT reltype, attname, atttypid, attnotnull" , " FROM pg_catalog.pg_attribute" @@ -74,16 +76,16 @@ dataPGRelation typs pgtab colf = do , " ORDER BY attnum" ]) case cl of - [] -> fail $ "dataPGRelation " ++ typs ++ " = " ++ pgtab ++ ": no columns found" + [] -> fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": no columns found" (to, _):_ -> do - tt <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return + tt <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return =<< lookupPGType tpg to return (tt, map snd cl) cols <- mapM (\(n, t, nn) -> do - v <- TH.newName n + v <- TH.newName $ pgNameString n return (v, t, not nn)) cold - let typl = TH.LitT (TH.StrTyLit pgid) + let typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) encfun f = TH.FunD f [TH.Clause [TH.WildP, TH.ConP typn (map (\(v, _, _) -> TH.VarP v) cols)] (TH.NormalB $ pgcall f rect `TH.AppE` (TH.ConE 'PGRecord `TH.AppE` TH.ListE (map (colenc f) cols))) @@ -100,7 +102,7 @@ dataPGRelation typs pgtab colf = do Nothing #endif [ TH.RecC typn $ map (\(n, t, nn) -> - ( TH.mkName (colf n) + ( TH.mkName (colf $ pgNameString n) #if MIN_VERSION_template_haskell(2,11,0) , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness #else @@ -161,10 +163,10 @@ dataPGRelation typs pgtab colf = do , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] , instanceD [] (TH.ConT ''PGRelation `TH.AppT` typt) [ TH.FunD 'pgRelationName [TH.Clause [TH.WildP] - (TH.NormalB $ TH.LitE $ TH.StringL pgtab) + (TH.NormalB $ namelit pgtab) [] ] , TH.FunD 'pgColumnNames [TH.Clause [TH.WildP] - (TH.NormalB $ TH.ListE $ map (\(n, _, _) -> TH.LitE $ TH.StringL n) cold) + (TH.NormalB $ TH.ListE $ map (\(n, _, _) -> namelit n) cold) [] ] ] , TH.SigD (TH.mkName ("uncurry" ++ typs)) $ TH.ArrowT `TH.AppT` @@ -196,3 +198,5 @@ dataPGRelation typs pgtab colf = do coldec (v, t, False) = pgcall 'pgDecode t `TH.AppE` TH.VarE v coldec (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall 'pgDecode t `TH.AppE` TH.VarE v rect = TH.LitT $ TH.StrTyLit "record" + namelit n = TH.ConE 'PGName `TH.AppE` + (TH.VarE 'BS.pack `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . fromIntegral) $ BS.unpack $ pgNameBS n)) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 11328b8..df16714 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -31,6 +31,7 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold import Data.Maybe (isJust, fromMaybe) +import Data.String (fromString) import qualified Data.Traversable as Tv import qualified Language.Haskell.TH as TH import Network (PortID(UnixSocket, PortNumber), PortNumber) @@ -102,28 +103,28 @@ reloadTPGTypes = TH.runIO $ [] <$ withMVar tpgState (mapM_ flushPGTypeConnection -- |Lookup a type name by OID. -- Error if not found. -tpgType :: PGTypeConnection -> OID -> IO PGTypeName +tpgType :: PGTypeConnection -> OID -> IO PGName tpgType c o = maybe (fail $ "Unknown PostgreSQL type: " ++ show o ++ "\nYou may need to use reloadTPGTypes or adjust search_path, or your postgresql-typed application may need to be rebuilt.") return =<< lookupPGType c o -- |Lookup a type OID by type name. -- This is less common and thus less efficient than going the other way. -- Fail if not found. -getTPGTypeOID :: PGTypeConnection -> PGTypeName -> IO OID +getTPGTypeOID :: PGTypeConnection -> PGName -> IO OID getTPGTypeOID c t = - maybe (fail $ "Unknown PostgreSQL type: " ++ t ++ "; be sure to use the exact type name from \\dTS") return =<< findPGType c t + maybe (fail $ "Unknown PostgreSQL type: " ++ show t ++ "; be sure to use the exact type name from \\dTS") return =<< findPGType c t data TPGValueInfo = TPGValueInfo { tpgValueName :: BS.ByteString , tpgValueTypeOID :: !OID - , tpgValueType :: PGTypeName + , tpgValueType :: PGName , tpgValueNullable :: Bool } -- |A type-aware wrapper to 'pgDescribe' tpgDescribe :: BS.ByteString -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo]) tpgDescribe sql types nulls = withTPGTypeConnection $ \tpg -> do - at <- mapM (getTPGTypeOID tpg) types + at <- mapM (getTPGTypeOID tpg . fromString) types (pt, rt) <- pgDescribe (pgConnection tpg) (BSL.fromStrict sql) at nulls (,) <$> mapM (\o -> do @@ -143,10 +144,10 @@ tpgDescribe sql types nulls = withTPGTypeConnection $ \tpg -> do , tpgValueNullable = n && o /= 2278 -- "void" }) rt -typeApply :: PGTypeName -> TH.Name -> TH.Name -> TH.Exp +typeApply :: PGName -> TH.Name -> TH.Name -> TH.Exp typeApply t f e = TH.VarE f `TH.AppE` TH.VarE e - `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeID `TH.AppT` TH.LitT (TH.StrTyLit t))) + `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeID `TH.AppT` TH.LitT (TH.StrTyLit $ pgNameString $ t))) -- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'. diff --git a/Database/PostgreSQL/Typed/TypeCache.hs b/Database/PostgreSQL/Typed/TypeCache.hs index 1c17a43..c642300 100644 --- a/Database/PostgreSQL/Typed/TypeCache.hs +++ b/Database/PostgreSQL/Typed/TypeCache.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Database.PostgreSQL.Typed.TypeCache - ( PGTypeName - , PGTypes + ( PGTypes , pgGetTypes , PGTypeConnection , pgConnection @@ -15,15 +14,12 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.IntMap as IntMap import Data.List (find) -import Database.PostgreSQL.Typed.Types (OID) +import Database.PostgreSQL.Typed.Types (PGName, OID) import Database.PostgreSQL.Typed.Dynamic import Database.PostgreSQL.Typed.Protocol --- |A particular PostgreSQL type, identified by full formatted name (from @format_type@ or @\\dT@). -type PGTypeName = String - -- |Map keyed on fromIntegral OID. -type PGTypes = IntMap.IntMap PGTypeName +type PGTypes = IntMap.IntMap PGName -- |A 'PGConnection' along with cached information about types. data PGTypeConnection = PGTypeConnection @@ -60,12 +56,12 @@ getPGTypes (PGTypeConnection c tr) = -- |Lookup a type name by OID. -- This is an efficient, often pure operation. -lookupPGType :: PGTypeConnection -> OID -> IO (Maybe PGTypeName) +lookupPGType :: PGTypeConnection -> OID -> IO (Maybe PGName) lookupPGType c o = IntMap.lookup (fromIntegral o) <$> getPGTypes c -- |Lookup a type OID by type name. -- This is less common and thus less efficient than going the other way. -findPGType :: PGTypeConnection -> PGTypeName -> IO (Maybe OID) +findPGType :: PGTypeConnection -> PGName -> IO (Maybe OID) findPGType c t = fmap (fromIntegral . fst) . find ((==) t . snd) . IntMap.toList <$> getPGTypes c diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 4aba5e2..bd65665 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -18,8 +18,8 @@ module Database.PostgreSQL.Typed.Types , PGValue(..) , PGValues , PGTypeID(..) - , PGTypeEnv(..) - , unknownPGTypeEnv + , PGTypeEnv(..), unknownPGTypeEnv + , PGName(..), pgNameString , PGRecord(..) -- * Marshalling classes @@ -71,6 +71,7 @@ import Data.Ratio ((%), numerator, denominator) #ifdef VERSION_scientific import Data.Scientific (Scientific) #endif +import Data.String (IsString(..)) #ifdef VERSION_text import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -117,8 +118,22 @@ unknownPGTypeEnv = PGTypeEnv { pgIntegerDatetimes = Nothing } +-- |A PostgreSQL literal identifier, generally corresponding to the \"name\" type (63-byte strings), but as it would be entered in a query, so may include double-quoting for special characters or schema-qualification. +newtype PGName = PGName{ pgNameBS :: BS.ByteString } + deriving (Eq, Ord) + +-- Applies utf-8 encoding. +instance IsString PGName where + fromString = PGName . BSU.fromString +instance Show PGName where + show = pgNameString + +pgNameString :: PGName -> String +pgNameString = BSU.toString . pgNameBS + -- |A proxy type for PostgreSQL types. The type argument should be an (internal) name of a database type, as per @format_type(OID)@ (usually the same as @\\dT+@). -- When the type's namespace (schema) is not in @search_path@, this will be explicitly qualified, so you should be sure to have a consistent @search_path@ for all database connections. +-- The underlying 'Symbol' should be considered a lifted 'PGName'. data PGTypeID (t :: Symbol) = PGTypeProxy -- |A valid PostgreSQL type, its metadata, and corresponding Haskell representation. @@ -132,8 +147,8 @@ class (KnownSymbol t -- |The default, native Haskell representation of this type, which should be as close as possible to the PostgreSQL representation. type PGVal t :: * -- |The string name of this type: specialized version of 'symbolVal'. - pgTypeID :: PGTypeID t -> String - pgTypeID = symbolVal + pgTypeName :: PGTypeID t -> PGName + pgTypeName = fromString . symbolVal -- |Does this type support binary decoding? -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type. pgBinaryColumn :: PGTypeEnv -> PGTypeID t -> Bool @@ -159,14 +174,14 @@ class PGType t => PGColumn t a where -- |Decode the PostgreSQL binary representation into a value. -- Only needs to be implemented if 'pgBinaryColumn' is true. pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a - pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgTypeID t ++ ": not supported" + pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgNameString (pgTypeName t) ++ ": not supported" pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> a pgDecodeValue _ t (PGTextValue v) = pgDecode t v pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v - pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgTypeID t ++ " column (use Maybe or COALESCE)" + pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgNameString (pgTypeName t) ++ " column (use Maybe or COALESCE)" instance PGParameter t a => PGParameter t (Maybe a) where - pgEncode t = maybe (error $ "pgEncode " ++ pgTypeID t ++ ": Nothing") (pgEncode t) + pgEncode t = maybe (error $ "pgEncode " ++ pgNameString (pgTypeName t) ++ ": Nothing") (pgEncode t) pgLiteral = maybe (BSC.pack "NULL") . pgLiteral pgEncodeValue e = maybe PGNullValue . pgEncodeValue e @@ -234,7 +249,7 @@ parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where #ifdef VERSION_postgresql_binary binDec :: PGType t => BinD.Decoder a -> PGTypeID t -> PGBinaryValue -> a -binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgTypeID t ++ ": " ++ show e) id . BinD.run d +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgNameString (pgTypeName t) ++ ": " ++ show e) id . BinD.run d #define BIN_COL pgBinaryColumn _ _ = True #define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . (F) @@ -397,6 +412,21 @@ instance pgDecode _ = id BIN_DEC(TE.encodeUtf8 <$> BinD.text_strict) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGParameter t PGName where + pgEncode _ = pgNameBS + BIN_ENC(BinE.text_strict . TE.decodeUtf8 . pgNameBS) +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + PGStringType t => PGColumn t PGName where + pgDecode _ = PGName + BIN_DEC(PGName . TE.encodeUtf8 <$> BinD.text_strict) + instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-} diff --git a/test/Main.hs b/test/Main.hs index 0ef08ea..92c82e1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies, PatternGuards #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies, PatternGuards, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --{-# OPTIONS_GHC -ddump-splices #-} module Main (main) where @@ -36,6 +36,8 @@ useTPGDatabase db dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) +deriving instance Show MyEnum + dataPGRelation "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) _fooRow :: MyFoo From 38024fbb632a5b63e398c0342208a01852c2466e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 5 Nov 2016 20:05:56 -0400 Subject: [PATCH 216/306] Add PGName annotations for PGEnum and PGRelation required changing PGName impl as Data ByteString instance is partly broken --- Database/PostgreSQL/Typed/Dynamic.hs | 3 ++- Database/PostgreSQL/Typed/Enum.hs | 34 ++++++++++++------------ Database/PostgreSQL/Typed/Relation.hs | 31 ++++++++++++---------- Database/PostgreSQL/Typed/Types.hs | 37 +++++++++++++++++---------- 4 files changed, 61 insertions(+), 44 deletions(-) diff --git a/Database/PostgreSQL/Typed/Dynamic.hs b/Database/PostgreSQL/Typed/Dynamic.hs index 38b3dab..ae0ef58 100644 --- a/Database/PostgreSQL/Typed/Dynamic.hs +++ b/Database/PostgreSQL/Typed/Dynamic.hs @@ -30,6 +30,7 @@ import qualified Data.Aeson as JSON #endif import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as BSL import Data.Int import Data.Monoid ((<>)) @@ -85,7 +86,7 @@ pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> pgNameBS (pgTypeName (pgTyp -- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. pgSafeLiteralString :: PGRep a => a -> String -pgSafeLiteralString x = pgLiteralString x ++ "::" ++ BSC.unpack (pgNameBS (pgTypeName (pgTypeOf x))) +pgSafeLiteralString x = pgLiteralString x ++ "::" ++ map w2c (pgNameBytes (pgTypeName (pgTypeOf x))) instance PGRep a => PGRep (Maybe a) where type PGRepType (Maybe a) = PGRepType a diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 91bcf70..9c68128 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -69,15 +69,15 @@ dataPGEnum typs pgenum valnf = do , " ORDER BY enumsortorder" ]) case vals of - [] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ pgNameString pgenum ++ ": no values found" + [] -> fail $ "dataPGEnum " ++ typs ++ " = " ++ show pgenum ++ ": no values found" (eo, _):_ -> do - et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ pgNameString pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return + et <- maybe (fail $ "dataPGEnum " ++ typs ++ " = " ++ show pgenum ++ ": enum type not found (you may need to use reloadTPGTypes or adjust search_path)") return =<< lookupPGType tpg eo return (et, map snd vals) - let valn = map (TH.mkName . valnf . pgNameString &&& map (TH.IntegerL . fromIntegral) . BS.unpack . pgNameBS) vals + let valn = map (TH.mkName . valnf . pgNameString &&& map (TH.IntegerL . fromIntegral) . pgNameBytes) vals typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) dv <- TH.newName "x" - return + return $ [ TH.DataD [] typn [] #if MIN_VERSION_template_haskell(2,11,0) Nothing @@ -97,10 +97,11 @@ dataPGEnum typs pgenum valnf = do ] , instanceD [] (TH.ConT ''PGColumn `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] - (TH.NormalB $ TH.VarE 'fromMaybe `TH.AppE` - (TH.AppE (TH.VarE 'error) $ - TH.InfixE (Just $ TH.LitE (TH.StringL ("pgEnumValue " ++ pgNameString pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) - `TH.AppE` (TH.VarE 'pgEnumValue `TH.AppE` (TH.ConE 'PGName `TH.AppE` TH.VarE dv))) + (TH.NormalB $ TH.VarE 'fromMaybe + `TH.AppE` (TH.AppE (TH.VarE 'error) $ + TH.InfixE (Just $ TH.LitE (TH.StringL ("pgEnumValue " ++ show pgid ++ ": "))) (TH.VarE '(++)) (Just $ TH.VarE 'BSC.unpack `TH.AppE` TH.VarE dv)) + `TH.AppE` (TH.VarE 'pgEnumValue `TH.AppE` (TH.ConE 'PGName + `TH.AppE` (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv)))) []] ] , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) @@ -110,18 +111,20 @@ dataPGEnum typs pgenum valnf = do [ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [TH.ConP n []] (TH.NormalB $ namelit l) []) valn - , TH.FunD 'pgEnumValue [TH.Clause [TH.ConP 'PGName [TH.VarP dv]] - (TH.NormalB $ TH.CaseE (TH.VarE 'BS.unpack `TH.AppE` TH.VarE dv) $ map (\(n, l) -> - TH.Match (TH.ListP (map TH.LitP l)) (TH.NormalB $ TH.ConE 'Just `TH.AppE` TH.ConE n) []) valn ++ - [TH.Match TH.WildP (TH.NormalB $ TH.ConE 'Nothing) - []]) - []] + , TH.FunD 'pgEnumValue $ map (\(n, l) -> + TH.Clause [TH.ConP 'PGName [TH.ListP (map TH.LitP l)]] + (TH.NormalB $ TH.ConE 'Just `TH.AppE` TH.ConE n) + []) valn + ++ [TH.Clause [TH.WildP] (TH.NormalB $ TH.ConE 'Nothing) []] , TH.FunD 'pgEnumValues [TH.Clause [] (TH.NormalB $ TH.ListE $ map (\(n, l) -> TH.ConE '(,) `TH.AppE` TH.ConE n `TH.AppE` namelit l) valn) []] ] + , TH.PragmaD $ TH.AnnP (TH.TypeAnnotation typn) $ namelit $ map (TH.IntegerL . fromIntegral) $ pgNameBytes pgid ] + ++ map (\(n, l) -> + TH.PragmaD $ TH.AnnP (TH.ValueAnnotation n) $ namelit l) valn where typn = TH.mkName typs typt = TH.ConT typn @@ -129,5 +132,4 @@ dataPGEnum typs pgenum valnf = do #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif - namelit l = TH.ConE 'PGName `TH.AppE` - (TH.VarE 'BS.pack `TH.AppE` TH.ListE (map TH.LitE l)) + namelit l = TH.ConE 'PGName `TH.AppE` TH.ListE (map TH.LitE l) diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index 895e559..bfd0a61 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -16,7 +16,6 @@ module Database.PostgreSQL.Typed.Relation ( dataPGRelation ) where -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Proxy (Proxy(..)) import qualified Language.Haskell.TH as TH @@ -62,11 +61,12 @@ dataPGRelation :: String -- ^ Haskell type and constructor to create dataPGRelation typs pgtab colf = do (pgid, cold) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do cl <- mapM (\[to, cn, ct, cnn] -> do - let n = pgDecodeRep cn + let c = pgDecodeRep cn + n = TH.mkName $ colf $ pgNameString c o = pgDecodeRep ct - t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": column '" ++ show n ++ "' has unknown type " ++ show o) return + t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": column '" ++ show c ++ "' has unknown type " ++ show o) return =<< lookupPGType tpg o - return (pgDecodeRep to, (n, TH.LitT (TH.StrTyLit $ pgNameString t), pgDecodeRep cnn))) + return (pgDecodeRep to, (c, n, TH.LitT (TH.StrTyLit $ pgNameString t), not $ pgDecodeRep cnn))) . snd =<< pgSimpleQuery (pgConnection tpg) (BSL.fromChunks [ "SELECT reltype, attname, atttypid, attnotnull" , " FROM pg_catalog.pg_attribute" @@ -81,9 +81,9 @@ dataPGRelation typs pgtab colf = do tt <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": table type not found (you may need to use reloadTPGTypes or adjust search_path)") return =<< lookupPGType tpg to return (tt, map snd cl) - cols <- mapM (\(n, t, nn) -> do - v <- TH.newName $ pgNameString n - return (v, t, not nn)) + cols <- mapM (\(c, _, t, nn) -> do + v <- TH.newName $ pgNameString c + return (v, t, nn)) cold let typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) encfun f = TH.FunD f [TH.Clause [TH.WildP, TH.ConP typn (map (\(v, _, _) -> TH.VarP v) cols)] @@ -93,7 +93,7 @@ dataPGRelation typs pgtab colf = do dv <- TH.newName "x" tv <- TH.newName "t" ev <- TH.newName "e" - return + return $ [ TH.DataD [] typn @@ -101,14 +101,14 @@ dataPGRelation typs pgtab colf = do #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif - [ TH.RecC typn $ map (\(n, t, nn) -> - ( TH.mkName (colf $ pgNameString n) + [ TH.RecC typn $ map (\(_, n, t, nn) -> + ( n #if MIN_VERSION_template_haskell(2,11,0) , TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness #else , TH.NotStrict #endif - , (if nn then id else (TH.ConT ''Maybe `TH.AppT`)) + , (if nn then (TH.ConT ''Maybe `TH.AppT`) else id) (TH.ConT ''PGVal `TH.AppT` t))) cold ] @@ -166,7 +166,7 @@ dataPGRelation typs pgtab colf = do (TH.NormalB $ namelit pgtab) [] ] , TH.FunD 'pgColumnNames [TH.Clause [TH.WildP] - (TH.NormalB $ TH.ListE $ map (\(n, _, _) -> namelit n) cold) + (TH.NormalB $ TH.ListE $ map (\(c, _, _, _) -> namelit c) cold) [] ] ] , TH.SigD (TH.mkName ("uncurry" ++ typs)) $ TH.ArrowT `TH.AppT` @@ -180,7 +180,10 @@ dataPGRelation typs pgtab colf = do (TH.NormalB $ foldl (\f (v, _, _) -> f `TH.AppE` TH.VarE v) (TH.ConE typn) cols) [] ] - ] + , TH.PragmaD $ TH.AnnP (TH.TypeAnnotation typn) $ namelit pgid + , TH.PragmaD $ TH.AnnP (TH.ValueAnnotation typn) $ namelit pgid + ] ++ map (\(c, n, _, _) -> + TH.PragmaD $ TH.AnnP (TH.ValueAnnotation n) $ namelit c) cold where typn = TH.mkName typs typt = TH.ConT typn @@ -199,4 +202,4 @@ dataPGRelation typs pgtab colf = do coldec (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall 'pgDecode t `TH.AppE` TH.VarE v rect = TH.LitT $ TH.StrTyLit "record" namelit n = TH.ConE 'PGName `TH.AppE` - (TH.VarE 'BS.pack `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . fromIntegral) $ BS.unpack $ pgNameBS n)) + TH.ListE (map (TH.LitE . TH.IntegerL . fromIntegral) $ pgNameBytes n) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index bd65665..99d21f6 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies #-} +{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif @@ -19,7 +19,7 @@ module Database.PostgreSQL.Typed.Types , PGValues , PGTypeID(..) , PGTypeEnv(..), unknownPGTypeEnv - , PGName(..), pgNameString + , PGName(..), pgNameBS, pgNameString , PGRecord(..) -- * Marshalling classes @@ -42,6 +42,7 @@ module Database.PostgreSQL.Typed.Types , buildPGValue ) where +import qualified Codec.Binary.UTF8.String as UTF8 #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$), (<*), (*>)) #endif @@ -60,6 +61,7 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower) +import Data.Data (Data) import Data.Int import Data.List (intersperse) import Data.Maybe (fromMaybe) @@ -84,6 +86,7 @@ import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif +import Data.Typeable (Typeable) #ifdef VERSION_uuid import qualified Data.UUID as UUID #endif @@ -119,17 +122,25 @@ unknownPGTypeEnv = PGTypeEnv } -- |A PostgreSQL literal identifier, generally corresponding to the \"name\" type (63-byte strings), but as it would be entered in a query, so may include double-quoting for special characters or schema-qualification. -newtype PGName = PGName{ pgNameBS :: BS.ByteString } - deriving (Eq, Ord) +newtype PGName = PGName + { pgNameBytes :: [Word8] -- ^Raw bytes of the identifier (should really be a 'BS.ByteString', but we need a working 'Data' instance for annotations). + } + deriving (Eq, Ord, Typeable, Data) + +-- |The literal identifier as used in a query. +pgNameBS :: PGName -> BS.ByteString +pgNameBS = BS.pack . pgNameBytes --- Applies utf-8 encoding. +-- |Applies utf-8 encoding. instance IsString PGName where - fromString = PGName . BSU.fromString + fromString = PGName . UTF8.encode +-- |Unquoted 'pgNameString'. instance Show PGName where show = pgNameString +-- |Reverses the 'IsString' instantce. pgNameString :: PGName -> String -pgNameString = BSU.toString . pgNameBS +pgNameString = UTF8.decode . pgNameBytes -- |A proxy type for PostgreSQL types. The type argument should be an (internal) name of a database type, as per @format_type(OID)@ (usually the same as @\\dT+@). -- When the type's namespace (schema) is not in @search_path@, this will be explicitly qualified, so you should be sure to have a consistent @search_path@ for all database connections. @@ -174,14 +185,14 @@ class PGType t => PGColumn t a where -- |Decode the PostgreSQL binary representation into a value. -- Only needs to be implemented if 'pgBinaryColumn' is true. pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a - pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ pgNameString (pgTypeName t) ++ ": not supported" + pgDecodeBinary _ t _ = error $ "pgDecodeBinary " ++ show (pgTypeName t) ++ ": not supported" pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> a pgDecodeValue _ t (PGTextValue v) = pgDecode t v pgDecodeValue e t (PGBinaryValue v) = pgDecodeBinary e t v - pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ pgNameString (pgTypeName t) ++ " column (use Maybe or COALESCE)" + pgDecodeValue _ t PGNullValue = error $ "NULL in " ++ show (pgTypeName t) ++ " column (use Maybe or COALESCE)" instance PGParameter t a => PGParameter t (Maybe a) where - pgEncode t = maybe (error $ "pgEncode " ++ pgNameString (pgTypeName t) ++ ": Nothing") (pgEncode t) + pgEncode t = maybe (error $ "pgEncode " ++ show (pgTypeName t) ++ ": Nothing") (pgEncode t) pgLiteral = maybe (BSC.pack "NULL") . pgLiteral pgEncodeValue e = maybe PGNullValue . pgEncodeValue e @@ -249,7 +260,7 @@ parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where #ifdef VERSION_postgresql_binary binDec :: PGType t => BinD.Decoder a -> PGTypeID t -> PGBinaryValue -> a -binDec d t = either (\e -> error $ "pgDecodeBinary " ++ pgNameString (pgTypeName t) ++ ": " ++ show e) id . BinD.run d +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ show (pgTypeName t) ++ ": " ++ show e) id . BinD.run d #define BIN_COL pgBinaryColumn _ _ = True #define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . (F) @@ -424,8 +435,8 @@ instance {-# OVERLAPPABLE #-} #endif PGStringType t => PGColumn t PGName where - pgDecode _ = PGName - BIN_DEC(PGName . TE.encodeUtf8 <$> BinD.text_strict) + pgDecode _ = PGName . BS.unpack + BIN_DEC(PGName . BS.unpack . TE.encodeUtf8 <$> BinD.text_strict) instance #if __GLASGOW_HASKELL__ >= 710 From cf20b7aafe427492f2c9c23cb73b87cd7f335bcf Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 26 Jan 2017 16:30:08 -0500 Subject: [PATCH 217/306] Bump version to 0.5.0 Rather significant changes since last release. Some of which I kind of stopped mid-goals... --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index ee22ce2..c9f52d3 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.4.5 +Version: 0.5.0 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From b56bb83a117f7d0ab94a8aaa306eca13479140ea Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 26 Jan 2017 16:55:06 -0500 Subject: [PATCH 218/306] Ignore duplicate ReadyForQuery after Sync Strangely enough, this is the second time I've fixed this bug, the first being dd510bb1c57ba8b5a887d73690c373c2db307d0f, which I broke again in 01328ba653d2be293c038097a038f5fd0f329160, so now I'm suspicious. This appears to happen as a race-condition when the ready hasn't arrived and we send a sync, though really we should know we've sent a sync, but oh well, should be no harm in ignoring it. --- COPYING | 2 +- Database/PostgreSQL/Typed/Enum.hs | 6 +++--- Database/PostgreSQL/Typed/Protocol.hs | 30 +++++++++++++++++---------- Database/PostgreSQL/Typed/Relation.hs | 4 ++-- postgresql-typed.cabal | 2 +- 5 files changed, 26 insertions(+), 18 deletions(-) diff --git a/COPYING b/COPYING index e077c9c..95909fc 100644 --- a/COPYING +++ b/COPYING @@ -1,4 +1,4 @@ -Copyright (c) 2014-2016, Dylan Simon +Copyright (c) 2014-2017, Dylan Simon Portions Copyright (c) 2010, 2011, Chris Forno All rights reserved. diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 9c68128..d4c56e8 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -9,7 +9,7 @@ -- -- Support for PostgreSQL enums. -module Database.PostgreSQL.Typed.Enum +module Database.PostgreSQL.Typed.Enum ( PGEnum(..) , dataPGEnum ) where @@ -55,14 +55,14 @@ class (Eq a, Ord a, Enum a, Bounded a, PGRep a) => PGEnum a where -- > instance PGEnum Foo where pgEnumValues = [(Foo_abc, "abc"), (Foo_DEF, "DEF")] -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, DataKinds, TypeFamilies -dataPGEnum :: String -- ^ Haskell type to create +dataPGEnum :: String -- ^ Haskell type to create -> PGName -- ^ PostgreSQL enum type name -> (String -> String) -- ^ How to generate constructor names from enum values, e.g. @(\"Type_\"++)@ (input is 'pgNameString') -> TH.DecsQ dataPGEnum typs pgenum valnf = do (pgid, vals) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do vals <- map (\([eo, v]) -> (pgDecodeRep eo, pgDecodeRep v)) . snd - <$> pgSimpleQuery (pgConnection tpg) (BSL.fromChunks + <$> pgSimpleQuery (pgConnection tpg) (BSL.fromChunks [ "SELECT enumtypid, enumlabel" , " FROM pg_catalog.pg_enum" , " WHERE enumtypid = ", pgLiteralRep pgenum, "::regtype" diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index cb62e76..2b09554 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -411,22 +411,26 @@ pgRecv :: Bool -> PGConnection -> IO (Maybe PGBackendMessage) pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = go =<< readIORef dr where next = writeIORef dr - state s d = writeIORef sr s >> next d new = G.pushChunk getMessage go (G.Done b _ m) = do when (connDebug c) $ putStrLn $ "< " ++ show m - got (new b) m =<< readIORef sr + 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 -> PGState -> 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 StateUnsync d - got d m _ = Just m <$ next d + got :: G.Decoder PGBackendMessage -> PGBackendMessage -> IO (Maybe PGBackendMessage) + got d (NoticeResponse m) = connLogMessage c m >> go d + got d m@(ReadyForQuery s) = do + s' <- atomicModifyIORef' sr ((,) s) + if s == s' + then go d + else done d m + got d m@(ErrorResponse _) = writeIORef sr StateUnsync >> done d m + got d m = done d m + done d m = Just m <$ next d -- |Receive the next message from PostgreSQL (low-level). Note that this will -- block until it gets a message. @@ -534,10 +538,14 @@ pgSync c@PGConnection{ connState = sr } = do wait s = do r <- pgRecv s c case r of - Nothing -> do - pgSend c Sync - pgFlush c - wait True + Nothing + | s -> do + writeIORef sr StateClosed + fail $ "pgReceive: connection closed" + | otherwise -> do + pgSend c Sync + pgFlush c + wait True (Just (ErrorResponse{ messageFields = m })) -> do connLogMessage c m wait s diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index bfd0a61..276e1ab 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -54,7 +54,7 @@ class (PGRep a, PGRecordType (PGRepType a)) => PGRelation a where -- If you want any derived instances, you'll need to create them yourself using StandaloneDeriving. -- -- Requires language extensions: TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, DataKinds, TypeFamilies, PatternGuards -dataPGRelation :: String -- ^ Haskell type and constructor to create +dataPGRelation :: String -- ^ Haskell type and constructor to create -> PGName -- ^ PostgreSQL table/relation name -> (String -> String) -- ^ How to generate field names from column names, e.g. @("table_"++)@ (input is 'pgNameString') -> TH.DecsQ @@ -144,7 +144,7 @@ dataPGRelation typs pgtab colf = do , TH.ConE 'Nothing) ]) [] ] - , TH.FunD 'pgDecodeValue + , TH.FunD 'pgDecodeValue [ TH.Clause [TH.WildP, TH.WildP, TH.ConP 'PGNullValue []] (TH.NormalB $ TH.ConE 'Nothing) [] diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index c9f52d3..0fb549a 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -3,7 +3,7 @@ Version: 0.5.0 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING -Copyright: 2010-2013 Chris Forno, 2014-2016 Dylan Simon +Copyright: 2010-2013 Chris Forno, 2014-2017 Dylan Simon Author: Dylan Simon Maintainer: Dylan Simon Stability: provisional From e6f93bfb00789c3c72cef060077f79f99b885cbd Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 26 Jan 2017 20:16:04 -0500 Subject: [PATCH 219/306] Add stack.yaml I guess I'm finally entering the modern world --- .gitignore | 1 + stack.yaml | 6 ++++++ 2 files changed, 7 insertions(+) create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index a7e4f5f..1b740bd 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ /dist +/.stack-work/ /errcodes /errcodes.hi /errcodes.o diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..a6dea46 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-7.17 +packages: +- '.' +extra-deps: [] +flags: {} +extra-package-dbs: [] From 03c3f982fedbcbf58938a958cbad9ce14807f20a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 26 Jan 2017 21:54:01 -0500 Subject: [PATCH 220/306] Cleanup old TODO file --- TODO | 20 -------------------- 1 file changed, 20 deletions(-) delete mode 100644 TODO diff --git a/TODO b/TODO deleted file mode 100644 index 531fcd8..0000000 --- a/TODO +++ /dev/null @@ -1,20 +0,0 @@ -* Handle bounds for integers better (automatically allow anything smaller through, but block bigger values). -* Add support for returning records (instead of tuples). -* Make insertIgnore useable in transactions. -* Figure out how to make withTransaction useable in other monads. -* Add explicit casts to all values going in: - $(execute - "UPDATE link_to_review \ - \SET target_time = {reviewedAt} + {diff} \ - \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h - - reviewedAt is a UTCTime and diff is a DiffTime, but to PostgreSQL it's ambigious (PGException "42725" "operator is not unique: unknown + unknown"). To fix it: - - $(execute - "UPDATE link_to_review \ - \SET target_time = {reviewedAt}::timestamp with time zone + {diff}::interval \ - \WHERE member_no = {memberNumber member} AND link_no = {linkNo}") h - - But easier for the programmer would be to have TemplatePG add explicit casts to all values it sends in. This is probably safer in the long run as well, although possibly less flexible. - Prepared placeholder type specification provides one solution to this [pgSQL|$(type,...)SQL...|] -* Consider using postgresql-libpq (worse performance but much easier maintenance) From 3a2341d6f35b5b0175036ff6d1484aaa67ec2c15 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 13 Feb 2017 13:39:06 -0500 Subject: [PATCH 221/306] Add missing HDBC test modules --- postgresql-typed.cabal | 9 +++++++++ stack.yaml | 2 +- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0fb549a..0565d32 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -117,6 +117,15 @@ test-suite hdbc type: exitcode-stdio-1.0 hs-source-dirs: test/hdbc, test main-is: runtests.hs + other-modules: + Connect + SpecificDB + TestMisc + TestSbasics + TestTime + TestUtils + Testbasics + Tests if flag(HDBC) build-depends: base, network, time, containers, convertible, postgresql-typed, HDBC, HUnit else diff --git a/stack.yaml b/stack.yaml index a6dea46..1242622 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-7.17 +resolver: lts-8.0 packages: - '.' extra-deps: [] From c20d5d98ec6c840a6c10e15ea91dd50617f6c038 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 22 Mar 2017 13:07:12 -0400 Subject: [PATCH 222/306] Restrict postgresql-binary < 0.11 Until can fix with 0.12. See #4. --- postgresql-typed.cabal | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0565d32..0b993ca 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -89,7 +89,7 @@ Library if flag(md5) Build-Depends: cryptonite >= 0.5, memory >= 0.5 if flag(binary) - Build-Depends: postgresql-binary >= 0.8, text >= 1, uuid >= 1.3, scientific >= 0.3 + Build-Depends: postgresql-binary >= 0.8 && < 0.11, text >= 1, uuid >= 1.3, scientific >= 0.3 else if flag(text) Build-Depends: text >= 1 diff --git a/stack.yaml b/stack.yaml index 1242622..e3c2b78 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-8.0 +resolver: lts-8.5 packages: - '.' extra-deps: [] From a3bd5b5bef2dd53e4f1c4638971df68fd83ed0c2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 22 Mar 2017 16:15:02 -0400 Subject: [PATCH 223/306] Add support for postgresql-binary 0.12 --- Database/PostgreSQL/Typed/Types.hs | 46 ++++++++++++++++++++++-------- postgresql-typed.cabal | 2 +- 2 files changed, 35 insertions(+), 13 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 99d21f6..a6581b0 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -94,9 +94,14 @@ import Data.Word (Word8, Word32) import GHC.TypeLits (Symbol, symbolVal, KnownSymbol) import Numeric (readFloat) #ifdef VERSION_postgresql_binary +#if MIN_VERSION_postgresql_binary(0,12,0) +import qualified PostgreSQL.Binary.Decoding as BinD +import qualified PostgreSQL.Binary.Encoding as BinE +#else import qualified PostgreSQL.Binary.Decoder as BinD import qualified PostgreSQL.Binary.Encoder as BinE #endif +#endif type PGTextValue = BS.ByteString type PGBinaryValue = BS.ByteString @@ -259,11 +264,31 @@ parsePGDQuote blank unsafe isnul = (Just <$> q) <> (mnul <$> uq) where | otherwise = Just s #ifdef VERSION_postgresql_binary -binDec :: PGType t => BinD.Decoder a -> PGTypeID t -> PGBinaryValue -> a -binDec d t = either (\e -> error $ "pgDecodeBinary " ++ show (pgTypeName t) ++ ": " ++ show e) id . BinD.run d +binEnc :: BinEncoder a -> a -> BS.ByteString +binEnc = (.) +#if MIN_VERSION_postgresql_binary(0,12,0) + BinE.encodingBytes + +type BinDecoder = BinD.Value +type BinEncoder a = a -> BinE.Encoding +#else + buildPGValue + +type BinDecoder = BinD.Decoder +type BinEncoder a = BinE.Encoder a +#endif + +binDec :: PGType t => BinDecoder a -> PGTypeID t -> PGBinaryValue -> a +binDec d t = either (\e -> error $ "pgDecodeBinary " ++ show (pgTypeName t) ++ ": " ++ show e) id . +#if MIN_VERSION_postgresql_binary(0,12,0) + BinD.valueParser +#else + BinD.run +#endif + d #define BIN_COL pgBinaryColumn _ _ = True -#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . buildPGValue . (F) +#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . binEnc (F) #define BIN_DEC(F) pgDecodeBinary _ = binDec (F) #else #define BIN_COL @@ -382,21 +407,18 @@ instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.float8) +-- XXX need real encoding as text; single byte as binary +-- but then no one should be using this type really... instance PGType "\"char\"" where type PGVal "\"char\"" = Word8 - BIN_COL instance PGParameter "\"char\"" Word8 where pgEncode _ = BS.singleton - BIN_ENC(BinE.char . w2c) instance PGColumn "\"char\"" Word8 where pgDecode _ = BS.head - BIN_DEC(c2w <$> BinD.char) instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton - BIN_ENC(BinE.char) instance PGColumn "\"char\"" Char where pgDecode _ = BSC.head - BIN_DEC(BinD.char) class PGType t => PGStringType t @@ -565,12 +587,12 @@ binColDatetime PGTypeEnv{ pgIntegerDatetimes = Just _ } _ = True binColDatetime _ _ = False #ifdef VERSION_postgresql_binary -binEncDatetime :: PGParameter t a => BinE.Encoder a -> BinE.Encoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue -binEncDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } _ = PGBinaryValue . buildPGValue . ff -binEncDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } _ = PGBinaryValue . buildPGValue . fi +binEncDatetime :: PGParameter t a => BinEncoder a -> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue +binEncDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } _ = PGBinaryValue . binEnc ff +binEncDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } _ = PGBinaryValue . binEnc fi binEncDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } t = PGTextValue . pgEncode t -binDecDatetime :: PGColumn t a => BinD.Decoder a -> BinD.Decoder a -> PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a +binDecDatetime :: PGColumn t a => BinDecoder a -> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a binDecDatetime _ ff PGTypeEnv{ pgIntegerDatetimes = Just False } = binDec ff binDecDatetime fi _ PGTypeEnv{ pgIntegerDatetimes = Just True } = binDec fi binDecDatetime _ _ PGTypeEnv{ pgIntegerDatetimes = Nothing } = error "pgDecodeBinary: unknown integer_datetimes value" diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0b993ca..0565d32 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -89,7 +89,7 @@ Library if flag(md5) Build-Depends: cryptonite >= 0.5, memory >= 0.5 if flag(binary) - Build-Depends: postgresql-binary >= 0.8 && < 0.11, text >= 1, uuid >= 1.3, scientific >= 0.3 + Build-Depends: postgresql-binary >= 0.8, text >= 1, uuid >= 1.3, scientific >= 0.3 else if flag(text) Build-Depends: text >= 1 From b5cf5cab5f4f09e2d35a8a84c0cbb0fbd5213a77 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 22 Mar 2017 16:20:31 -0400 Subject: [PATCH 224/306] Bump version 0.5.1 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0565d32..0f5a5c9 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.5.0 +Version: 0.5.1 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From 0cdb9ce4bd5c3c8424cdaf1c256d340aa44ab286 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 22 Mar 2017 16:26:28 -0400 Subject: [PATCH 225/306] Fix binary (but not text) "char" encoding Add test case --- Database/PostgreSQL/Typed/Types.hs | 7 ++++++- test/Main.hs | 10 ++++++---- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index a6581b0..4256695 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -407,18 +407,23 @@ instance PGColumn "double precision" Double where pgDecode _ = read . BSC.unpack BIN_DEC(BinD.float8) --- XXX need real encoding as text; single byte as binary +-- XXX need real encoding as text -- but then no one should be using this type really... instance PGType "\"char\"" where type PGVal "\"char\"" = Word8 + BIN_COL instance PGParameter "\"char\"" Word8 where pgEncode _ = BS.singleton + pgEncodeValue _ _ = PGBinaryValue . BS.singleton instance PGColumn "\"char\"" Word8 where pgDecode _ = BS.head + pgDecodeBinary _ _ = BS.head instance PGParameter "\"char\"" Char where pgEncode _ = BSC.singleton + pgEncodeValue _ _ = PGBinaryValue . BSC.singleton instance PGColumn "\"char\"" Char where pgDecode _ = BSC.head + pgDecodeBinary _ _ = BSC.head class PGType t => PGStringType t diff --git a/test/Main.hs b/test/Main.hs index 92c82e1..5e2ea3f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,6 +8,7 @@ import qualified Data.ByteString.Char8 as BSC import Data.Char (isDigit, toUpper) import Data.Int (Int32) import qualified Data.Time as Time +import Data.Word (Word8) import System.Exit (exitSuccess, exitFailure) import qualified Test.QuickCheck as Q import Test.QuickCheck.Test (isSuccess) @@ -96,12 +97,13 @@ prepared c t = pgQuery c . [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE preparedApply :: PGConnection -> Int32 -> IO [String] preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] -selectProp :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Str -> [Maybe Str] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property -selectProp c b i f t z d p s l r e a = Q.ioProperty $ do - [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery c - [pgSQL|$SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] +selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Str -> [Maybe Str] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp pgc b c i f t z d p s l r e a = Q.ioProperty $ do + [(Just b', Just c', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc + [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] return $ Q.conjoin [ i Q.=== i' + , c Q.=== c' , b Q.=== b' , strString s Q.=== s' , f Q.=== f' From 18f23bb5fa1836e6de1dd3bac533f9d35220bfa8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 22 Mar 2017 16:32:29 -0400 Subject: [PATCH 226/306] Trim package synopsis --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0f5a5c9..8920976 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -10,7 +10,7 @@ Stability: provisional Bug-Reports: https://github.com/dylex/postgresql-typed/issues Homepage: https://github.com/dylex/postgresql-typed Category: Database -Synopsis: A PostgreSQL library with compile-time SQL type inference and optional HDBC backend +Synopsis: PostgreSQL interface with compile-time SQL type checking, optional HDBC backend Description: Automatically type-check SQL statements at compile time. Uses Template Haskell and the raw PostgreSQL protocol to describe SQL statements at compile time and provide appropriate type marshalling for both parameters and results. Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell. From ee3b27daf768b50d234a40d0de4bac7eea597471 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 24 Oct 2017 11:29:22 -0400 Subject: [PATCH 227/306] Register upper-bound for template-haskell --- postgresql-typed.cabal | 2 +- stack.yaml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 8920976..c147bb1 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -62,7 +62,7 @@ Library old-locale, time, bytestring >= 0.10.2, - template-haskell, + template-haskell < 2.12, haskell-src-meta, network, attoparsec >= 0.12 && < 0.14, diff --git a/stack.yaml b/stack.yaml index e3c2b78..3df2756 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ -resolver: lts-8.5 +resolver: lts-9.10 packages: - '.' -extra-deps: [] +extra-deps: flags: {} extra-package-dbs: [] From 390a026e0989f531b6951b90b25880f285d5ef2d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 24 Oct 2017 20:15:58 -0400 Subject: [PATCH 228/306] Compatibility with template-haskell 2.12 Fixes #6 --- Database/PostgreSQL/Typed/Enum.hs | 3 +++ postgresql-typed.cabal | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index d4c56e8..82ca3ad 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -84,6 +84,9 @@ dataPGEnum typs pgenum valnf = do #endif (map (\(n, _) -> TH.NormalC n []) valn) $ #if MIN_VERSION_template_haskell(2,11,0) +#if MIN_VERSION_template_haskell(2,12,0) + return $ TH.DerivClause Nothing $ +#endif map TH.ConT #endif [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index c147bb1..8920976 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -62,7 +62,7 @@ Library old-locale, time, bytestring >= 0.10.2, - template-haskell < 2.12, + template-haskell, haskell-src-meta, network, attoparsec >= 0.12 && < 0.14, From 16a93643e60c74f82b2ae77b6d459856b27a078d Mon Sep 17 00:00:00 2001 From: Franco Lucchini Date: Wed, 1 Nov 2017 22:14:04 +0100 Subject: [PATCH 229/306] fixed build on Windows/mingw (no UnixSocket) --- Database/PostgreSQL/Typed/TH.hs | 8 ++++++++ test/Connect.hs | 3 +-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index df16714..62eb137 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -34,7 +34,11 @@ import Data.Maybe (isJust, fromMaybe) import Data.String (fromString) import qualified Data.Traversable as Tv import qualified Language.Haskell.TH as TH +#ifdef mingw32_HOST_OS +import Network (PortID(PortNumber), PortNumber) +#else import Network (PortID(UnixSocket, PortNumber), PortNumber) +#endif import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) @@ -50,7 +54,11 @@ getTPGDatabase = do db <- fromMaybe user <$> lookupEnv "TPG_DB" host <- fromMaybe "localhost" <$> lookupEnv "TPG_HOST" pnum <- maybe (5432 :: PortNumber) ((fromIntegral :: Int -> PortNumber) . read) <$> lookupEnv "TPG_PORT" +#ifdef mingw32_HOST_OS + let port = PortNumber pnum +#else port <- maybe (PortNumber pnum) UnixSocket <$> lookupEnv "TPG_SOCK" +#endif pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" debug <- isJust <$> lookupEnv "TPG_DEBUG" return $ defaultPGDatabase diff --git a/test/Connect.hs b/test/Connect.hs index 213867a..c697300 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -6,8 +6,7 @@ import Network (PortID(UnixSocket)) db :: PGDatabase db = defaultPGDatabase - { pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432" - , pgDBName = "templatepg" + { pgDBName = "templatepg" , pgDBUser = "templatepg" , pgDBDebug = True , pgDBParams = [("TimeZone", "UTC")] From 819dc843f24d2db6c5a20cff903a7ddff2805005 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 2 Nov 2017 10:29:32 -0400 Subject: [PATCH 230/306] Restore test default port on unix --- Database/PostgreSQL/Typed/TH.hs | 8 ++++---- stack.yaml | 2 +- test/Connect.hs | 5 ++++- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 62eb137..116029c 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -34,11 +34,11 @@ import Data.Maybe (isJust, fromMaybe) import Data.String (fromString) import qualified Data.Traversable as Tv import qualified Language.Haskell.TH as TH -#ifdef mingw32_HOST_OS -import Network (PortID(PortNumber), PortNumber) -#else -import Network (PortID(UnixSocket, PortNumber), PortNumber) +import Network (PortID(PortNumber +#ifndef mingw32_HOST_OS + , UnixSocket #endif + ), PortNumber) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) diff --git a/stack.yaml b/stack.yaml index 3df2756..2cced8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.10 +resolver: lts-9.11 packages: - '.' extra-deps: diff --git a/test/Connect.hs b/test/Connect.hs index c697300..dc9ade7 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module Connect where import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase) @@ -7,6 +7,9 @@ import Network (PortID(UnixSocket)) db :: PGDatabase db = defaultPGDatabase { pgDBName = "templatepg" +#ifndef mingw32_HOST_OS + , pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432" +#endif , pgDBUser = "templatepg" , pgDBDebug = True , pgDBParams = [("TimeZone", "UTC")] From 19b978262e77210ea5fdbf3d731bc00ba2a9c9f6 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 2 Nov 2017 10:31:29 -0400 Subject: [PATCH 231/306] Bump version for release --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 8920976..9215b79 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.5.1 +Version: 0.5.2 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From 18139ea86d0cd272f444254772a638e1409df4cc Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Tue, 12 Dec 2017 20:36:22 +0000 Subject: [PATCH 232/306] Avoid sporadic unexpected response when an SQL statement raises an exception --- Database/PostgreSQL/Typed/Protocol.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 2b09554..869118a 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -621,6 +621,7 @@ pgSimpleQuery h sql = do start (RowDescription rd) = go $ row (map colBinary rd) id start (CommandComplete c) = got c [] start EmptyQueryResponse = return (0, []) + start (ReadyForQuery StateTransactionFailed) = go start start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m row bc r (DataRow fs) = go $ row bc (r . (fixBinary bc fs :)) row _ r (CommandComplete c) = got c (r []) From 47857927146df5982a6c1b6d4a305be88f98865f Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Jan 2018 11:39:22 -0500 Subject: [PATCH 233/306] Improve Sync/ReadyForQuery handling for #11 Keep better track of when we're expecting a ReadyForQuery, which includes after a SimpleQuery and when a connection completes. This obviates the need to send a Sync, and eliminates the possibility of a Sync and ReadyForQuery response crossing on the wire. Previously, this would trigger an unexpected second ReadyForQuery message that was handled incorrectly. --- Database/PostgreSQL/Typed/Protocol.hs | 50 +++++++++++++++------------ test/Main.hs | 12 ++++++- 2 files changed, 38 insertions(+), 24 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 2b09554..37ba230 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -87,7 +87,7 @@ import Database.PostgreSQL.Typed.Dynamic data PGState = StateUnsync -- no Sync - | StatePending -- Sync sent + | StatePending -- expecting ReadyForQuery -- ReadyForQuery received: | StateIdle | StateTransaction @@ -237,7 +237,16 @@ defaultLogMessage = hPutStrLn stderr . displayMessage -- |A database connection with sane defaults: -- localhost:5432:postgres defaultPGDatabase :: PGDatabase -defaultPGDatabase = PGDatabase "localhost" (PortNumber 5432) (BSC.pack "postgres") (BSC.pack "postgres") BS.empty [] False defaultLogMessage +defaultPGDatabase = PGDatabase + { pgDBHost = "localhost" + , pgDBPort = PortNumber 5432 + , pgDBName = BSC.pack "postgres" + , pgDBUser = BSC.pack "postgres" + , pgDBPass = BS.empty + , pgDBParams = [] + , pgDBDebug = False + , pgDBLogMessage = defaultLogMessage + } connDebug :: PGConnection -> Bool connDebug = pgDBDebug . connDatabase @@ -326,6 +335,7 @@ pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do (t, b) = second (BSL.toStrict . B.toLazyByteString) $ messageBody msg state _ StateClosed = StateClosed state Sync _ = StatePending + state SimpleQuery{} _ = StatePending state Terminate _ = StateClosed state _ _ = StateUnsync @@ -423,12 +433,8 @@ pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = 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) = do - s' <- atomicModifyIORef' sr ((,) s) - if s == s' - then go d - else done d m - got d m@(ErrorResponse _) = writeIORef sr StateUnsync >> done d m + got d m@(ReadyForQuery s) = writeIORef sr s >> done d m + got d m@AuthenticationOk = writeIORef sr StatePending >> done d m got d m = done d m done d m = Just m <$ next d @@ -531,28 +537,26 @@ pgSync c@PGConnection{ connState = sr } = do s <- readIORef sr case s of StateClosed -> fail "pgSync: operation on closed connection" - StatePending -> wait True - StateUnsync -> wait False + StatePending -> wait + StateUnsync -> do + pgSend c Sync + pgFlush c + wait _ -> return () where - wait s = do - r <- pgRecv s c + wait = do + r <- pgRecv True c case r of - Nothing - | s -> do - writeIORef sr StateClosed - fail $ "pgReceive: connection closed" - | otherwise -> do - pgSend c Sync - pgFlush c - wait True + Nothing -> do + writeIORef sr StateClosed + fail $ "pgReceive: connection closed" (Just (ErrorResponse{ messageFields = m })) -> do connLogMessage c m - wait s + wait (Just (ReadyForQuery _)) -> return () (Just m) -> do connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) $ BSC.pack "Each statement should only contain a single query" - wait s + wait rowDescription :: PGBackendMessage -> PGRowDescription rowDescription (RowDescription d) = d @@ -642,7 +646,7 @@ pgSimpleQueries_ h sql = do res EmptyQueryResponse = go res (DataRow _) = go res (ParameterStatus _ _) = go - res (ReadyForQuery _) = return () + res (ReadyForQuery _) = return () -- theoretically we don't have to wait for this res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m pgPreparedBind :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> IO (IO ()) diff --git a/test/Main.hs b/test/Main.hs index 5e2ea3f..9fc26f8 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,7 @@ --{-# OPTIONS_GHC -ddump-splices #-} module Main (main) where +import Control.Exception (try) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.Char (isDigit, toUpper) @@ -14,13 +15,15 @@ import qualified Test.QuickCheck as Q import Test.QuickCheck.Test (isSuccess) import Database.PostgreSQL.Typed -import Database.PostgreSQL.Typed.Types (OID) +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Protocol import Database.PostgreSQL.Typed.Array () import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum import Database.PostgreSQL.Typed.Inet import Database.PostgreSQL.Typed.SQLToken import Database.PostgreSQL.Typed.Relation +import qualified Database.PostgreSQL.Typed.ErrCodes as PGErr import Connect @@ -156,5 +159,12 @@ main = do [Just "line"] <- prepared c 628 "line" ["line"] <- preparedApply c 628 + pgTransaction c $ do + (1, [[PGTextValue "1"]]) <- pgSimpleQuery c "SELECT 1" + Left e1 <- try $ pgSimpleQuery c "SYNTAX_ERROR" + assert $ pgErrorCode e1 == PGErr.syntax_error + Left e2 <- try $ pgSimpleQuery c "SELECT 1" + assert $ pgErrorCode e2 == PGErr.in_failed_sql_transaction + pgDisconnect c exitSuccess From fe5852be3bee08aff4b004f4715f48adbf316370 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Jan 2018 14:31:00 -0500 Subject: [PATCH 234/306] Update and test with stack lts-10 --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 2cced8d..e5f0220 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.11 +resolver: lts-10.2 packages: - '.' extra-deps: From 31faebb65aff03ae37d73e4e20298ece03de5547 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Jan 2018 16:52:39 -0500 Subject: [PATCH 235/306] Cleanup, improve handling of asynchronous messages --- Database/PostgreSQL/Typed/HDBC.hs | 2 +- Database/PostgreSQL/Typed/Protocol.hs | 100 +++++++++++++------------- Database/PostgreSQL/Typed/Types.hs | 2 + test/Connect.hs | 2 +- 4 files changed, 56 insertions(+), 50 deletions(-) diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index a6bc385..afbb01c 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -89,7 +89,7 @@ fromPGConnection pg = do pgv <- takePGConnection pg reloadTypes Connection { connectionPG = pgv - , connectionServerVer = maybe "" BSC.unpack $ pgServerVersion pg + , connectionServerVer = maybe "" BSC.unpack $ pgServerVersion $ pgTypeEnv pg , connectionTypes = mempty , connectionFetchSize = 1 } diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 37ba230..edfab5f 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards, DataKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno --- Copyright 2014-2015 Dylan Simon +-- Copyright 2014-2018 Dylan Simon -- |The Protocol module allows for direct, low-level communication with a -- PostgreSQL server over TCP/IP. You probably don't want to use this module @@ -14,7 +18,6 @@ module Database.PostgreSQL.Typed.Protocol ( , pgErrorCode , pgConnectionDatabase , pgTypeEnv - , pgServerVersion , pgConnect , pgDisconnect , pgReconnect @@ -45,11 +48,11 @@ module Database.PostgreSQL.Typed.Protocol ( ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<$)) +import Control.Applicative ((<$>), (<$)) #endif -import Control.Arrow ((&&&), first, second) -import Control.Exception (Exception, throwIO, onException) -import Control.Monad (void, liftM2, replicateM, when, unless) +import Control.Arrow ((&&&), first, second) +import Control.Exception (Exception, throwIO, onException) +import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef VERSION_cryptonite import qualified Crypto.Hash as Hash import qualified Data.ByteArray.Encoding as BA @@ -58,29 +61,29 @@ 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 Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.ByteString.Lazy.Internal (smallChunkSize) +import Data.ByteString.Lazy.Internal (smallChunkSize) import qualified Data.Foldable as Fold -import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef, modifyIORef') -import Data.Int (Int32, Int16) +import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef') +import Data.Int (Int32, Int16) import qualified Data.Map.Lazy as Map -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mempty) +import Data.Monoid (mempty) #endif -import Data.Tuple (swap) -import Data.Typeable (Typeable) +import Data.Tuple (swap) +import Data.Typeable (Typeable) #if !MIN_VERSION_base(4,8,0) -import Data.Word (Word) +import Data.Word (Word) #endif -import Data.Word (Word32) -import Network (HostName, PortID(..), connectTo) -import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) -import System.IO.Unsafe (unsafeInterleaveIO) -import Text.Read (readMaybe) +import Data.Word (Word32) +import Network (HostName, PortID(..), connectTo) +import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) +import System.IO.Unsafe (unsafeInterleaveIO) +import Text.Read (readMaybe) import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic @@ -124,8 +127,8 @@ data PGConnection = PGConnection , connDatabase :: !PGDatabase , connPid :: !Word32 -- unused , connKey :: !Word32 -- unused - , connParameters :: Map.Map BS.ByteString BS.ByteString , connTypeEnv :: PGTypeEnv + , connParameters :: IORef (Map.Map BS.ByteString BS.ByteString) , connPreparedStatementCount :: IORef Integer , connPreparedStatementMap :: IORef (Map.Map (BS.ByteString, [OID]) PGPreparedStatement) , connState :: IORef PGState @@ -240,8 +243,8 @@ defaultPGDatabase :: PGDatabase defaultPGDatabase = PGDatabase { pgDBHost = "localhost" , pgDBPort = PortNumber 5432 - , pgDBName = BSC.pack "postgres" - , pgDBUser = BSC.pack "postgres" + , pgDBName = "postgres" + , pgDBUser = "postgres" , pgDBPass = BS.empty , pgDBParams = [] , pgDBDebug = False @@ -262,10 +265,6 @@ pgConnectionDatabase = connDatabase pgTypeEnv :: PGConnection -> PGTypeEnv pgTypeEnv = connTypeEnv --- |Retrieve the \"server_version\" parameter from the connection, if any. -pgServerVersion :: PGConnection -> Maybe BS.ByteString -pgServerVersion PGConnection{ connParameters = p } = Map.lookup (BSC.pack "server_version") p - #ifdef VERSION_cryptonite md5 :: BS.ByteString -> BS.ByteString md5 = BA.convertToBase BA.Base16 . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) @@ -281,7 +280,7 @@ byteStringNul s = B.byteString s <> nul lazyByteStringNul :: BSL.ByteString -> B.Builder lazyByteStringNul s = B.lazyByteString s <> nul --- |Given a message, determin the (optional) type ID and the body +-- |Given a message, determine the (optional) type ID and the body messageBody :: PGFrontendMessage -> (Maybe Char, B.Builder) messageBody (StartupMessage kv) = (Nothing, B.word32BE 0x30000 <> Fold.foldMap (\(k, v) -> byteStringNul k <> byteStringNul v) kv <> nul) @@ -434,6 +433,9 @@ pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = got :: G.Decoder PGBackendMessage -> PGBackendMessage -> IO (Maybe PGBackendMessage) got d (NoticeResponse m) = connLogMessage c m >> go d got d m@(ReadyForQuery s) = writeIORef sr s >> done d m + got d (ParameterStatus k v) = do + modifyIORef' (connParameters c) $ Map.insert k v + go d got d m@AuthenticationOk = writeIORef sr StatePending >> done d m got d m = done d m done d m = Just m <$ next d @@ -458,6 +460,7 @@ pgConnect db = do prepm <- newIORef Map.empty input <- newIORef getMessage tr <- newIORef 0 + param <- newIORef Map.empty h <- connectTo (pgDBHost db) (pgDBPort db) hSetBuffering h (BlockBuffering Nothing) let c = PGConnection @@ -465,7 +468,7 @@ pgConnect db = do , connDatabase = db , connPid = 0 , connKey = 0 - , connParameters = Map.empty + , connParameters = param , connPreparedStatementCount = prepc , connPreparedStatementMap = prepm , connState = state @@ -474,25 +477,27 @@ pgConnect db = do , connTransaction = tr } pgSend c $ StartupMessage $ - [ (BSC.pack "user", pgDBUser db) - , (BSC.pack "database", pgDBName db) - , (BSC.pack "client_encoding", BSC.pack "UTF8") - , (BSC.pack "standard_conforming_strings", BSC.pack "on") - , (BSC.pack "bytea_output", BSC.pack "hex") - , (BSC.pack "DateStyle", BSC.pack "ISO, YMD") - , (BSC.pack "IntervalStyle", BSC.pack "iso_8601") + [ ("user", pgDBUser db) + , ("database", pgDBName db) + , ("client_encoding", "UTF8") + , ("standard_conforming_strings", "on") + , ("bytea_output", "hex") + , ("DateStyle", "ISO, YMD") + , ("IntervalStyle", "iso_8601") ] ++ pgDBParams db pgFlush c conn c where conn c = pgReceive c >>= msg c - msg c (ReadyForQuery _) = return c - { connTypeEnv = PGTypeEnv - { pgIntegerDatetimes = fmap (BSC.pack "on" ==) $ Map.lookup (BSC.pack "integer_datetimes") (connParameters c) + msg c (ReadyForQuery _) = do + cp <- readIORef (connParameters c) + return c + { connTypeEnv = PGTypeEnv + { pgIntegerDatetimes = fmap ("on" ==) $ Map.lookup "integer_datetimes" cp + , pgServerVersion = Map.lookup "server_version" cp + } } - } msg c (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 $ pgDBPass db @@ -500,7 +505,7 @@ pgConnect db = do conn c #ifdef VERSION_cryptonite msg c (AuthenticationMD5Password salt) = do - pgSend c $ PasswordMessage $ BSC.pack "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) + pgSend c $ PasswordMessage $ "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) pgFlush c conn c #endif @@ -555,7 +560,7 @@ pgSync c@PGConnection{ connState = sr } = do wait (Just (ReadyForQuery _)) -> return () (Just m) -> do - connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) $ BSC.pack "Each statement should only contain a single query" + connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query" wait rowDescription :: PGBackendMessage -> PGRowDescription @@ -591,7 +596,7 @@ pgDescribe h sql types nulls = do | nulls && oid /= 0 = do -- In cases where the resulting field is tracable to the column of a -- table, we can check there. - (_, r) <- pgPreparedQuery h (BSC.pack "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2") [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] + (_, r) <- pgPreparedQuery h "SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [26, 21] [pgEncodeRep (oid :: OID), pgEncodeRep (col :: Int16)] [] case r of [[s]] -> return $ not $ pgDecodeRep s [] -> return True @@ -645,7 +650,6 @@ pgSimpleQueries_ h sql = do res (CommandComplete _) = go res EmptyQueryResponse = go res (DataRow _) = go - res (ParameterStatus _ _) = go res (ReadyForQuery _) = return () -- theoretically we don't have to wait for this res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m @@ -662,7 +666,7 @@ pgPreparedBind c sql types bind bc = do let go = pgReceive c >>= start start ParseComplete = do - modifyIORef (connPreparedStatementMap c) $ + modifyIORef' (connPreparedStatementMap c) $ Map.insert key n go start BindComplete = return () diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 4256695..537b090 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -119,11 +119,13 @@ type PGValues = [PGValue] -- Nothing values represent unknown. data PGTypeEnv = PGTypeEnv { pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding. + , pgServerVersion :: Maybe BS.ByteString -- ^ The @server_version@ parameter } deriving (Show) unknownPGTypeEnv :: PGTypeEnv unknownPGTypeEnv = PGTypeEnv { pgIntegerDatetimes = Nothing + , pgServerVersion = Nothing } -- |A PostgreSQL literal identifier, generally corresponding to the \"name\" type (63-byte strings), but as it would be entered in a query, so may include double-quoting for special characters or schema-qualification. diff --git a/test/Connect.hs b/test/Connect.hs index dc9ade7..7c57a5f 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -11,7 +11,7 @@ db = defaultPGDatabase , pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432" #endif , pgDBUser = "templatepg" - , pgDBDebug = True + -- , pgDBDebug = True , pgDBParams = [("TimeZone", "UTC")] } From 05f2106d7f1835c71e79eb0077fc5ba22cb98c81 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Jan 2018 19:04:28 -0500 Subject: [PATCH 236/306] cleanups; rename PGColDescription fields; eof error --- Database/PostgreSQL/Typed/HDBC.hs | 22 ++++---- Database/PostgreSQL/Typed/Protocol.hs | 81 ++++++++++++--------------- 2 files changed, 48 insertions(+), 55 deletions(-) diff --git a/Database/PostgreSQL/Typed/HDBC.hs b/Database/PostgreSQL/Typed/HDBC.hs index afbb01c..3e60fc7 100644 --- a/Database/PostgreSQL/Typed/HDBC.hs +++ b/Database/PostgreSQL/Typed/HDBC.hs @@ -139,16 +139,16 @@ noCursor = Cursor [] [] False getType :: Connection -> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc getType c pg nul PGColDescription{..} = ColDesc - { colDescName = BSC.unpack colName + { colDescName = BSC.unpack pgColName , colDesc = HDBC.SqlColDesc { HDBC.colType = sqlTypeId t - , HDBC.colSize = fromIntegral colModifier <$ guard (colModifier >= 0) - , HDBC.colOctetLength = fromIntegral colSize <$ guard (colSize >= 0) + , HDBC.colSize = fromIntegral pgColModifier <$ guard (pgColModifier >= 0) + , HDBC.colOctetLength = fromIntegral pgColSize <$ guard (pgColSize >= 0) , HDBC.colDecDigits = Nothing , HDBC.colNullable = nul } , colDescDecode = sqlTypeDecode t - } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show colType) (fromIntegral colType) (connectionTypes c) + } where t = IntMap.findWithDefault (sqlType (pgTypeEnv pg) $ show pgColType) (fromIntegral pgColType) (connectionTypes c) instance HDBC.IConnection Connection where disconnect c = withPGConnection c @@ -232,13 +232,13 @@ instance HDBC.IConnection Connection where describeTable c t = withPGConnection c $ \pg -> map (\[attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull] -> colDescName &&& colDesc $ getType c pg (Just $ not $ pgDecodeRep attnotnull) PGColDescription - { colName = pgDecodeRep attname - , colTable = pgDecodeRep attrelid - , colNumber = pgDecodeRep attnum - , colType = pgDecodeRep atttypid - , colSize = pgDecodeRep attlen - , colModifier = pgDecodeRep atttypmod - , colBinary = False + { pgColName = pgDecodeRep attname + , pgColTable = pgDecodeRep attrelid + , pgColNumber = pgDecodeRep attnum + , pgColType = pgDecodeRep atttypid + , pgColSize = pgDecodeRep attlen + , pgColModifier = pgDecodeRep atttypmod + , pgColBinary = False }) . snd <$> pgSimpleQuery pg (BSLC.fromChunks [ "SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull" diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index edfab5f..2f45ae2 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -82,6 +82,7 @@ import Data.Word (Word) import Data.Word (Word32) import Network (HostName, PortID(..), connectTo) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) +import System.IO.Error (mkIOError, eofErrorType, ioError) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) @@ -137,13 +138,13 @@ data PGConnection = PGConnection } data PGColDescription = PGColDescription - { colName :: BS.ByteString - , colTable :: !OID - , colNumber :: !Int16 - , colType :: !OID - , colSize :: !Int16 - , colModifier :: !Int32 - , colBinary :: !Bool + { pgColName :: BS.ByteString + , pgColTable :: !OID + , pgColNumber :: !Int16 + , pgColType :: !OID + , pgColSize :: !Int16 + , pgColModifier :: !Int32 + , pgColBinary :: !Bool } deriving (Show) type PGRowDescription = [PGColDescription] @@ -372,13 +373,13 @@ getMessageBody 'T' = do tmod <- G.getWord32be -- type modifier fmt <- G.getWord16be -- format code return $ PGColDescription - { colName = name - , colTable = oid - , colNumber = fromIntegral col - , colType = typ' - , colSize = fromIntegral siz - , colModifier = fromIntegral tmod - , colBinary = toEnum (fromIntegral fmt) + { pgColName = name + , pgColTable = oid + , pgColNumber = fromIntegral col + , pgColType = typ' + , pgColSize = fromIntegral siz + , pgColModifier = fromIntegral tmod + , pgColBinary = toEnum (fromIntegral fmt) } getMessageBody 'Z' = ReadyForQuery <$> (rs . w2c =<< G.getWord8) where rs 'I' = return StateIdle @@ -407,17 +408,11 @@ 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, connState = sr } = + G.isolate (fromIntegral len - 4) $ getMessageBody (w2c typ) + +pgRecv :: PGConnection -> IO PGBackendMessage +pgRecv c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = go =<< readIORef dr where next = writeIORef dr new = G.pushChunk getMessage @@ -426,11 +421,15 @@ pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = 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 + b <- BS.hGetSome {- BS.hGetNonBlocking -} h smallChunkSize if BS.null b - then Nothing <$ next d + then do + next d + writeIORef sr StateClosed + -- Should this instead be a special PGError? + ioError $ mkIOError eofErrorType "PGConnection" (Just h) Nothing else go $ r (Just b) - got :: G.Decoder PGBackendMessage -> PGBackendMessage -> IO (Maybe PGBackendMessage) + got :: G.Decoder PGBackendMessage -> PGBackendMessage -> IO PGBackendMessage got d (NoticeResponse m) = connLogMessage c m >> go d got d m@(ReadyForQuery s) = writeIORef sr s >> done d m got d (ParameterStatus k v) = do @@ -438,29 +437,26 @@ pgRecv block c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = go d got d m@AuthenticationOk = writeIORef sr StatePending >> done d m got d m = done d m - done d m = Just m <$ next d + done d m = 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 + r <- pgRecv 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 + ErrorResponse{ messageFields = m } -> throwIO (PGError m) + m -> return m -- |Connect to a PostgreSQL server. pgConnect :: PGDatabase -> IO PGConnection pgConnect db = do + param <- newIORef Map.empty state <- newIORef StateUnsync prepc <- newIORef 0 prepm <- newIORef Map.empty input <- newIORef getMessage tr <- newIORef 0 - param <- newIORef Map.empty h <- connectTo (pgDBHost db) (pgDBPort db) hSetBuffering h (BlockBuffering Nothing) let c = PGConnection @@ -550,16 +546,13 @@ pgSync c@PGConnection{ connState = sr } = do _ -> return () where wait = do - r <- pgRecv True c + r <- pgRecv c case r of - Nothing -> do - writeIORef sr StateClosed - fail $ "pgReceive: connection closed" - (Just (ErrorResponse{ messageFields = m })) -> do + ErrorResponse{ messageFields = m } -> do connLogMessage c m wait - (Just (ReadyForQuery _)) -> return () - (Just m) -> do + ReadyForQuery _ -> return () + m -> do connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query" wait @@ -586,7 +579,7 @@ pgDescribe h sql types nulls = do ParameterDescription ps <- pgReceive h (,) ps <$> (mapM desc . rowDescription =<< pgReceive h) where - desc (PGColDescription{ colName = name, colTable = tab, colNumber = col, colType = typ }) = do + desc (PGColDescription{ pgColName = name, pgColTable = tab, pgColNumber = col, pgColType = typ }) = do n <- nullable tab col return (name, typ, n) -- We don't get nullability indication from PostgreSQL, at least not directly. @@ -627,7 +620,7 @@ pgSimpleQuery h sql = do pgFlush h go start where go = (pgReceive h >>=) - start (RowDescription rd) = go $ row (map colBinary rd) id + start (RowDescription rd) = go $ row (map pgColBinary rd) id start (CommandComplete c) = got c [] start EmptyQueryResponse = return (0, []) start m = fail $ "pgSimpleQuery: unexpected response: " ++ show m From 38779856ee794fbb27ecec0fcfcced0fc753d3b1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 6 Jan 2018 22:26:32 -0500 Subject: [PATCH 237/306] Refactor pgRecv for notifications; stub gotNotifications --- Database/PostgreSQL/Typed/Protocol.hs | 241 ++++++++++++++++++-------- 1 file changed, 166 insertions(+), 75 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 2f45ae2..5414855 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- Copyright 2014-2018 Dylan Simon @@ -45,13 +48,16 @@ module Database.PostgreSQL.Typed.Protocol ( , PGRowDescription , pgBind , pgFetch + -- * Notifications + , PGNotification(..) + , pgGetNotifications ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) #endif import Control.Arrow ((&&&), first, second) -import Control.Exception (Exception, throwIO, onException) +import Control.Exception (Exception, throwIO, onException, finally) import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef VERSION_cryptonite import qualified Crypto.Hash as Hash @@ -135,6 +141,7 @@ data PGConnection = PGConnection , connState :: IORef PGState , connInput :: IORef (G.Decoder PGBackendMessage) , connTransaction :: IORef Word + , connNotifications :: IORef (Queue PGNotification) } data PGColDescription = PGColDescription @@ -150,6 +157,29 @@ type PGRowDescription = [PGColDescription] type MessageFields = Map.Map Char BS.ByteString +data PGNotification = PGNotification + { pgNotificationPid :: !Word32 + , pgNotificationChannel :: !BS.ByteString + , pgNotificationPayload :: BSL.ByteString + } deriving (Show) + +-- |Simple amortized fifo +data Queue a = Queue [a] [a] + +emptyQueue :: Queue a +emptyQueue = Queue [] [] + +enQueue :: a -> Queue a -> Queue a +enQueue a (Queue e d) = Queue (a:e) d + +deQueue :: Queue a -> (Queue a, Maybe a) +deQueue (Queue e (x:d)) = (Queue e d, Just x) +deQueue (Queue (reverse -> x:d) []) = (Queue [] d, Just x) +deQueue q = (q, Nothing) + +queueToList :: Queue a -> [a] +queueToList (Queue e d) = d ++ reverse e + -- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. -- See . data PGFrontendMessage @@ -194,6 +224,7 @@ data PGBackendMessage | ErrorResponse { messageFields :: MessageFields } | NoData | NoticeResponse { messageFields :: MessageFields } + | NotificationResponse PGNotification -- |A ParameterDescription describes the type of a given SQL -- query/statement parameter ($1, $2, etc.). Unfortunately, -- PostgreSQL does not give us nullability information for the @@ -403,6 +434,13 @@ getMessageBody 'I' = return EmptyQueryResponse getMessageBody 'n' = return NoData getMessageBody 's' = return PortalSuspended getMessageBody 'N' = NoticeResponse <$> getMessageFields +getMessageBody 'A' = NotificationResponse <$> do + len <- G.getWord32be + G.isolate (fromIntegral len - 4) $ + PGNotification + <$> G.getWord32be + <*> getByteStringNul + <*> G.getLazyByteStringNul getMessageBody t = fail $ "pgGetMessage: unknown message type: " ++ show t getMessage :: G.Decoder PGBackendMessage @@ -411,42 +449,95 @@ getMessage = G.runGetIncremental $ do len <- G.getWord32be G.isolate (fromIntegral len - 4) $ getMessageBody (w2c typ) -pgRecv :: PGConnection -> IO PGBackendMessage -pgRecv c@PGConnection{ connHandle = h, connInput = dr, connState = sr } = - go =<< readIORef dr where +class Show m => RecvMsg m where + -- |Read from connection, returning immediate value or non-empty data + recvMsgData :: PGConnection -> IO (Either m BS.ByteString) + recvMsgData c = do + r <- BS.hGetSome (connHandle c) smallChunkSize + if BS.null r + then do + writeIORef (connState c) StateClosed + hClose (connHandle c) + -- Should this instead be a special PGError? + ioError $ mkIOError eofErrorType "PGConnection" (Just (connHandle c)) Nothing + else + return (Right r) + -- |Expected ReadyForQuery message + recvMsgSync :: Maybe m + recvMsgSync = Nothing + -- |NotificationResponse message + recvMsgNotif :: Maybe m + recvMsgNotif = Nothing + -- |Any other unhandled message + recvMsg :: PGConnection -> PGBackendMessage -> IO (Maybe m) + recvMsg c (ErrorResponse m) = Nothing <$ + connLogMessage c m + recvMsg c m = Nothing <$ + connLogMessage c (makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query") + +-- |Process all pending messages +data RecvNonBlock = RecvNonBlock deriving (Show) +instance RecvMsg RecvNonBlock where + recvMsgData c = do + r <- BS.hGetNonBlocking (connHandle c) smallChunkSize + if BS.null r + then return (Left RecvNonBlock) + else return (Right r) + +-- |Wait for ReadyForQuery +data RecvSync = RecvSync deriving (Show) +instance RecvMsg RecvSync where + recvMsgSync = Just RecvSync + +-- |Wait for NotificationResponse +data RecvNotif = RecvNotif deriving (Show) +instance RecvMsg RecvNotif where + recvMsgNotif = Just RecvNotif + +-- |Return any message (throwing errors) +instance RecvMsg PGBackendMessage where + recvMsg _ (ErrorResponse m) = throwIO (PGError m) + recvMsg _ m = return $ Just m + +-- |Return any message or ReadyForQuery +instance RecvMsg (Either PGBackendMessage RecvSync) where + recvMsgSync = Just $ Right RecvSync + recvMsg _ (ErrorResponse m) = throwIO (PGError m) + recvMsg _ m = return $ Just $ Left m + +-- |Receive the next message from PostgreSQL (low-level). +pgRecv :: RecvMsg m => PGConnection -> IO m +pgRecv c@PGConnection{ connInput = dr, connState = sr } = + rcv =<< readIORef dr where next = writeIORef dr new = G.pushChunk getMessage - go (G.Done b _ m) = do + + -- read and parse + rcv (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 <- BS.hGetSome {- BS.hGetNonBlocking -} h smallChunkSize - if BS.null b - then do - next d - writeIORef sr StateClosed - -- Should this instead be a special PGError? - ioError $ mkIOError eofErrorType "PGConnection" (Just h) Nothing - else go $ r (Just b) - got :: G.Decoder PGBackendMessage -> PGBackendMessage -> IO PGBackendMessage - got d (NoticeResponse m) = connLogMessage c m >> go d - got d m@(ReadyForQuery s) = writeIORef sr s >> done d m - got d (ParameterStatus k v) = do - modifyIORef' (connParameters c) $ Map.insert k v - go d - got d m@AuthenticationOk = writeIORef sr StatePending >> done d m - got d m = done d m - done d m = 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 c - case r of - ErrorResponse{ messageFields = m } -> throwIO (PGError m) - m -> return m + rcv (G.Fail _ _ r) = next (new BS.empty) >> fail r -- not clear how can recover + rcv d@(G.Partial r) = recvMsgData c `onException` next d >>= + either (<$ next d) (rcv . r . Just) + + -- process message + msg (NoticeResponse m) = Nothing <$ + connLogMessage c m + msg (ParameterStatus k v) = Nothing <$ + modifyIORef' (connParameters c) (Map.insert k v) + msg m@(ReadyForQuery s) = do + s' <- atomicModifyIORef' sr (s, ) + if s' == StatePending + then return recvMsgSync -- expected + else recvMsg c m -- unexpected + msg (NotificationResponse n) = recvMsgNotif <$ + modifyIORef' (connNotifications c) (enQueue n) + msg m@AuthenticationOk = do + writeIORef sr StatePending + recvMsg c m + msg m = recvMsg c m + got d m = msg m `onException` next d >>= + maybe (rcv d) (<$ next d) -- |Connect to a PostgreSQL server. pgConnect :: PGDatabase -> IO PGConnection @@ -457,6 +548,7 @@ pgConnect db = do prepm <- newIORef Map.empty input <- newIORef getMessage tr <- newIORef 0 + notif <- newIORef emptyQueue h <- connectTo (pgDBHost db) (pgDBPort db) hSetBuffering h (BlockBuffering Nothing) let c = PGConnection @@ -471,6 +563,7 @@ pgConnect db = do , connTypeEnv = unknownPGTypeEnv , connInput = input , connTransaction = tr + , connNotifications = notif } pgSend c $ StartupMessage $ [ ("user", pgDBUser db) @@ -484,8 +577,8 @@ pgConnect db = do pgFlush c conn c where - conn c = pgReceive c >>= msg c - msg c (ReadyForQuery _) = do + conn c = pgRecv c >>= msg c + msg c (Right RecvSync) = do cp <- readIORef (connParameters c) return c { connTypeEnv = PGTypeEnv @@ -493,26 +586,25 @@ pgConnect db = do , pgServerVersion = Map.lookup "server_version" cp } } - msg c (BackendKeyData p k) = conn c{ connPid = p, connKey = k } - msg c AuthenticationOk = conn c - msg c AuthenticationCleartextPassword = do + msg c (Left (BackendKeyData p k)) = conn c{ connPid = p, connKey = k } + msg c (Left AuthenticationOk) = conn c + msg c (Left AuthenticationCleartextPassword) = do pgSend c $ PasswordMessage $ pgDBPass db pgFlush c conn c #ifdef VERSION_cryptonite - msg c (AuthenticationMD5Password salt) = do + msg c (Left (AuthenticationMD5Password salt)) = do pgSend c $ PasswordMessage $ "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) pgFlush c conn c #endif - msg _ m = fail $ "pgConnect: unexpected response: " ++ show m + msg _ (Left 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 } = do - pgSend c Terminate - hClose h +pgDisconnect c@PGConnection{ connHandle = h } = + pgSend c Terminate `finally` hClose h -- |Disconnect cleanly from the PostgreSQL server, but only if it's still connected. pgDisconnectOnce :: PGConnection -- ^ a handle from 'pgConnect' @@ -530,7 +622,7 @@ pgReconnect c@PGConnection{ connDatabase = cd, connState = cs } d = do if cd == d && s /= StateClosed then return c{ connDatabase = d } else do - when (s /= StateClosed) $ pgDisconnect c + pgDisconnectOnce c pgConnect d pgSync :: PGConnection -> IO () @@ -546,15 +638,8 @@ pgSync c@PGConnection{ connState = sr } = do _ -> return () where wait = do - r <- pgRecv c - case r of - ErrorResponse{ messageFields = m } -> do - connLogMessage c m - wait - ReadyForQuery _ -> return () - m -> do - connLogMessage c $ makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query" - wait + RecvSync <- pgRecv c + return () rowDescription :: PGBackendMessage -> PGRowDescription rowDescription (RowDescription d) = d @@ -575,9 +660,9 @@ pgDescribe h sql types nulls = do pgSend h DescribeStatement{ statementName = BS.empty } pgSend h Sync pgFlush h - ParseComplete <- pgReceive h - ParameterDescription ps <- pgReceive h - (,) ps <$> (mapM desc . rowDescription =<< pgReceive h) + ParseComplete <- pgRecv h + ParameterDescription ps <- pgRecv h + (,) ps <$> (mapM desc . rowDescription =<< pgRecv h) where desc (PGColDescription{ pgColName = name, pgColTable = tab, pgColNumber = col, pgColType = typ }) = do n <- nullable tab col @@ -619,7 +704,7 @@ pgSimpleQuery h sql = do pgSend h $ SimpleQuery sql pgFlush h go start where - go = (pgReceive h >>=) + go = (pgRecv h >>=) start (RowDescription rd) = go $ row (map pgColBinary rd) id start (CommandComplete c) = got c [] start EmptyQueryResponse = return (0, []) @@ -638,12 +723,12 @@ pgSimpleQueries_ h sql = do pgSend h $ SimpleQuery sql pgFlush h go where - go = pgReceive h >>= res - res (RowDescription _) = go - res (CommandComplete _) = go - res EmptyQueryResponse = go - res (DataRow _) = go - res (ReadyForQuery _) = return () -- theoretically we don't have to wait for this + go = pgRecv h >>= res + res (Left (RowDescription _)) = go + res (Left (CommandComplete _)) = go + res (Left EmptyQueryResponse) = go + res (Left (DataRow _)) = go + res (Right RecvSync) = return () res m = fail $ "pgSimpleQueries_: unexpected response: " ++ show m pgPreparedBind :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> IO (IO ()) @@ -657,7 +742,7 @@ pgPreparedBind c sql types bind bc = do pgSend c Parse{ queryString = BSL.fromStrict sql, statementName = preparedStatementName n, parseTypes = types } pgSend c Bind{ portalName = BS.empty, statementName = preparedStatementName n, bindParameters = bind, binaryColumns = bc } let - go = pgReceive c >>= start + go = pgRecv c >>= start start ParseComplete = do modifyIORef' (connPreparedStatementMap c) $ Map.insert key n @@ -682,7 +767,7 @@ pgPreparedQuery c sql types bind bc = do start go id where - go r = pgReceive c >>= row r + go r = pgRecv c >>= row r row r (DataRow fs) = go (r . (fixBinary bc fs :)) row r (CommandComplete d) = return (rowsAffected d, r []) row r EmptyQueryResponse = return (0, r []) @@ -703,7 +788,7 @@ pgPreparedLazyQuery c sql types bind bc count = do pgSend c Execute{ portalName = BS.empty, executeRows = count } pgSend c Flush pgFlush c - go r = pgReceive c >>= row r + go r = pgRecv c >>= row r row r (DataRow fs) = go (r . (fixBinary bc fs :)) row r PortalSuspended = r <$> unsafeInterleaveIO (execute >> go id) row r (CommandComplete _) = return (r []) @@ -771,7 +856,7 @@ pgRun c sql types bind = do pgSend c Sync pgFlush c go where - go = pgReceive c >>= res + go = pgRecv c >>= res res ParseComplete = go res BindComplete = go res (DataRow _) = go @@ -788,7 +873,7 @@ pgPrepare c sql types = do pgSend c Parse{ queryString = sql, statementName = preparedStatementName n, parseTypes = types } pgSend c Sync pgFlush c - ParseComplete <- pgReceive c + ParseComplete <- pgRecv c return n -- |Close a previously prepared query. @@ -799,8 +884,8 @@ pgClose c n = do pgSend c CloseStatement{ statementName = preparedStatementName n } pgSend c Sync pgFlush c - CloseComplete <- pgReceive c - CloseComplete <- pgReceive c + CloseComplete <- pgRecv c + CloseComplete <- pgRecv c return () -- |Bind a prepared statement, and return the row description. @@ -813,9 +898,9 @@ pgBind c n bind = do pgSend c DescribePortal{ portalName = sn } pgSend c Sync pgFlush c - CloseComplete <- pgReceive c - BindComplete <- pgReceive c - rowDescription <$> pgReceive c + CloseComplete <- pgRecv c + BindComplete <- pgRecv c + rowDescription <$> pgRecv c where sn = preparedStatementName n -- |Fetch a single row from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete. @@ -827,7 +912,7 @@ pgFetch c n count = do pgSend c Sync pgFlush c go where - go = pgReceive c >>= res + go = pgRecv c >>= res res (DataRow v) = first (v :) <$> go res PortalSuspended = return ([], Nothing) res (CommandComplete d) = do @@ -835,7 +920,13 @@ pgFetch c n count = do pgSend c ClosePortal{ portalName = preparedStatementName n } pgSend c Sync pgFlush c - CloseComplete <- pgReceive c + CloseComplete <- pgRecv c return ([], Just $ rowsAffected d) res EmptyQueryResponse = return ([], Just 0) res m = fail $ "pgFetch: unexpected response: " ++ show m + +-- |Retrieve any pending notifications. Non-blocking. +pgGetNotifications :: PGConnection -> IO [PGNotification] +pgGetNotifications c = do + -- pgRecv + return [] From 83af3bc24aecb02671f4e686e1add461a54571d5 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sun, 7 Jan 2018 10:12:27 -0500 Subject: [PATCH 238/306] Add PGNotification interface and basic tests #12 --- Database/PostgreSQL/Typed/Protocol.hs | 57 ++++++++++++++++----------- test/Main.hs | 8 ++++ 2 files changed, 41 insertions(+), 24 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 5414855..06bc7fa 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -51,6 +51,7 @@ module Database.PostgreSQL.Typed.Protocol ( -- * Notifications , PGNotification(..) , pgGetNotifications + , pgGetNotification ) where #if !MIN_VERSION_base(4,8,0) @@ -242,7 +243,7 @@ data PGBackendMessage -- |PGException is thrown upon encountering an 'ErrorResponse' with severity of -- ERROR, FATAL, or PANIC. It holds the message of the error. -data PGError = PGError { pgErrorFields :: MessageFields } +newtype PGError = PGError { pgErrorFields :: MessageFields } deriving (Typeable) instance Show PGError where @@ -435,12 +436,10 @@ getMessageBody 'n' = return NoData getMessageBody 's' = return PortalSuspended getMessageBody 'N' = NoticeResponse <$> getMessageFields getMessageBody 'A' = NotificationResponse <$> do - len <- G.getWord32be - G.isolate (fromIntegral len - 4) $ - PGNotification - <$> G.getWord32be - <*> getByteStringNul - <*> G.getLazyByteStringNul + PGNotification + <$> G.getWord32be + <*> getByteStringNul + <*> G.getLazyByteStringNul getMessageBody t = fail $ "pgGetMessage: unknown message type: " ++ show t getMessage :: G.Decoder PGBackendMessage @@ -466,12 +465,15 @@ class Show m => RecvMsg m where recvMsgSync :: Maybe m recvMsgSync = Nothing -- |NotificationResponse message - recvMsgNotif :: Maybe m - recvMsgNotif = Nothing + recvMsgNotif :: PGConnection -> PGNotification -> IO (Maybe m) + recvMsgNotif c n = Nothing <$ + modifyIORef' (connNotifications c) (enQueue n) + -- |ErrorResponse message + recvMsgErr :: PGConnection -> MessageFields -> IO (Maybe m) + recvMsgErr c m = Nothing <$ + connLogMessage c m -- |Any other unhandled message recvMsg :: PGConnection -> PGBackendMessage -> IO (Maybe m) - recvMsg c (ErrorResponse m) = Nothing <$ - connLogMessage c m recvMsg c m = Nothing <$ connLogMessage c (makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query") @@ -490,20 +492,19 @@ instance RecvMsg RecvSync where recvMsgSync = Just RecvSync -- |Wait for NotificationResponse -data RecvNotif = RecvNotif deriving (Show) -instance RecvMsg RecvNotif where - recvMsgNotif = Just RecvNotif +instance RecvMsg PGNotification where + recvMsgNotif _ = return . Just -- |Return any message (throwing errors) instance RecvMsg PGBackendMessage where - recvMsg _ (ErrorResponse m) = throwIO (PGError m) - recvMsg _ m = return $ Just m + recvMsgErr _ = throwIO . PGError + recvMsg _ = return . Just -- |Return any message or ReadyForQuery instance RecvMsg (Either PGBackendMessage RecvSync) where recvMsgSync = Just $ Right RecvSync - recvMsg _ (ErrorResponse m) = throwIO (PGError m) - recvMsg _ m = return $ Just $ Left m + recvMsgErr _ = throwIO . PGError + recvMsg _ = return . Just . Left -- |Receive the next message from PostgreSQL (low-level). pgRecv :: RecvMsg m => PGConnection -> IO m @@ -521,17 +522,19 @@ pgRecv c@PGConnection{ connInput = dr, connState = sr } = either (<$ next d) (rcv . r . Just) -- process message - msg (NoticeResponse m) = Nothing <$ - connLogMessage c m msg (ParameterStatus k v) = Nothing <$ modifyIORef' (connParameters c) (Map.insert k v) + msg (NoticeResponse m) = Nothing <$ + connLogMessage c m + msg (ErrorResponse m) = + recvMsgErr c m msg m@(ReadyForQuery s) = do s' <- atomicModifyIORef' sr (s, ) if s' == StatePending then return recvMsgSync -- expected else recvMsg c m -- unexpected - msg (NotificationResponse n) = recvMsgNotif <$ - modifyIORef' (connNotifications c) (enQueue n) + msg (NotificationResponse n) = + recvMsgNotif c n msg m@AuthenticationOk = do writeIORef sr StatePending recvMsg c m @@ -928,5 +931,11 @@ pgFetch c n count = do -- |Retrieve any pending notifications. Non-blocking. pgGetNotifications :: PGConnection -> IO [PGNotification] pgGetNotifications c = do - -- pgRecv - return [] + RecvNonBlock <- pgRecv c + queueToList <$> atomicModifyIORef' (connNotifications c) (emptyQueue, ) + +-- |Retrieve a notifications, blocking if necessary. +pgGetNotification :: PGConnection -> IO PGNotification +pgGetNotification c = + maybe (pgRecv c) return + =<< atomicModifyIORef' (connNotifications c) deQueue diff --git a/test/Main.hs b/test/Main.hs index 9fc26f8..f98930c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -159,12 +159,20 @@ main = do [Just "line"] <- prepared c 628 "line" ["line"] <- preparedApply c 628 + pgSimpleQueries_ c "LISTEN channame; NOTIFY channame, 'oh hello'; SELECT pg_notify('channame', 'there')" + PGNotification _ "channame" "oh hello" <- pgGetNotification c + (-1, []) <- pgSimpleQuery c "NOTIFY channame" + pgTransaction c $ do (1, [[PGTextValue "1"]]) <- pgSimpleQuery c "SELECT 1" + (-1, []) <- pgSimpleQuery c "NOTIFY channame, 'nope'" Left e1 <- try $ pgSimpleQuery c "SYNTAX_ERROR" assert $ pgErrorCode e1 == PGErr.syntax_error Left e2 <- try $ pgSimpleQuery c "SELECT 1" assert $ pgErrorCode e2 == PGErr.in_failed_sql_transaction + [PGNotification _ "channame" "there", PGNotification _ "channame" ""] <- pgGetNotifications c + [] <- pgGetNotifications c + pgDisconnect c exitSuccess From 1db819648e4bbe2f3e5ada7c040fd8cd1c91d52d Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 19 Mar 2018 13:25:03 -0400 Subject: [PATCH 239/306] Add pgDQuote' to always double-quote --- Database/PostgreSQL/Typed/Types.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 537b090..a491613 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -37,6 +37,7 @@ module Database.PostgreSQL.Typed.Types -- * Conversion utilities , pgQuote + , pgDQuote' , pgDQuote , parsePGDQuote , buildPGValue @@ -237,16 +238,19 @@ pgQuote = pgQuoteUnsafe . BSC.intercalate (BSC.pack "''") . BSC.split '\'' buildPGValue :: BSB.Builder -> BS.ByteString buildPGValue = BSL.toStrict . BSB.toLazyByteString +-- |Double-quote a value. +pgDQuote' :: BS.ByteString -> BSB.Builder +pgDQuote' s = dq <> BSBP.primMapByteStringBounded ec s <> dq where + dq = BSB.char7 '"' + ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8) + bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) + -- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument. -- Checking all these things may not be worth it. We could just double-quote everything. pgDQuote :: [Char] -> BS.ByteString -> BSB.Builder pgDQuote 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) + | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" = pgDQuote' s + | otherwise = BSB.byteString s -- |Parse double-quoted values ala 'pgDQuote'. parsePGDQuote :: Bool -> [Char] -> (BS.ByteString -> Bool) -> P.Parser (Maybe BS.ByteString) From dd661a34d353b72b80a1a6741e69fd6cbd0d3577 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 19 Mar 2018 20:01:36 -0400 Subject: [PATCH 240/306] Actually, let's make pgDQuote the reasonable one and rename old to pgDQuoteFrom --- Database/PostgreSQL/Typed/Array.hs | 2 +- Database/PostgreSQL/Typed/Range.hs | 2 +- Database/PostgreSQL/Typed/Types.hs | 18 +++++++++--------- stack.yaml | 2 +- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/Database/PostgreSQL/Typed/Array.hs b/Database/PostgreSQL/Typed/Array.hs index 78f7980..2c39c3b 100644 --- a/Database/PostgreSQL/Typed/Array.hs +++ b/Database/PostgreSQL/Typed/Array.hs @@ -54,7 +54,7 @@ instance (PGArrayType t, PGParameter (PGElemType t) a) => PGParameter t (PGArray a) where pgEncode ta l = buildPGValue $ BSB.char7 '{' <> mconcat (intersperse (BSB.char7 $ pgArrayDelim ta) $ map el l) <> BSB.char7 '}' where el Nothing = BSB.string7 "null" - el (Just e) = pgDQuote (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e + el (Just e) = pgDQuoteFrom (pgArrayDelim ta : "{}") $ pgEncode (pgArrayElementType ta) e #if __GLASGOW_HASKELL__ >= 710 -- |Allow entirely non-null arrays as parameter inputs only. -- (Only supported on ghc >= 7.10 due to instance overlap.) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index 0c7fb9a..d7d5532 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -235,7 +235,7 @@ instance (PGRangeType t, PGParameter (PGSubType t) a) => PGParameter t (Range a) <> pc ']' ')' u where pb Nothing = mempty - pb (Just b) = pgDQuote "(),[]" $ pgEncode (pgRangeElementType tr) b + pb (Just b) = pgDQuoteFrom "(),[]" $ pgEncode (pgRangeElementType tr) b pc c o b = BSB.char7 $ if boundClosed b then c else o instance (PGRangeType t, PGColumn (PGSubType t) a) => PGColumn t (Range a) where pgDecode tr a = either (error . ("pgDecode range (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly per a where diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index a491613..7c15296 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -37,8 +37,8 @@ module Database.PostgreSQL.Typed.Types -- * Conversion utilities , pgQuote - , pgDQuote' , pgDQuote + , pgDQuoteFrom , parsePGDQuote , buildPGValue ) where @@ -238,18 +238,18 @@ pgQuote = pgQuoteUnsafe . BSC.intercalate (BSC.pack "''") . BSC.split '\'' buildPGValue :: BSB.Builder -> BS.ByteString buildPGValue = BSL.toStrict . BSB.toLazyByteString --- |Double-quote a value. -pgDQuote' :: BS.ByteString -> BSB.Builder -pgDQuote' s = dq <> BSBP.primMapByteStringBounded ec s <> dq where +-- |Double-quote a value (e.g., as an identifier). +-- Does not properly handle unicode escaping (yet). +pgDQuote :: BS.ByteString -> BSB.Builder +pgDQuote s = dq <> BSBP.primMapByteStringBounded ec s <> dq where dq = BSB.char7 '"' ec = BSBP.condB (\c -> c == c2w '"' || c == c2w '\\') bs (BSBP.liftFixedToBounded BSBP.word8) bs = BSBP.liftFixedToBounded $ ((,) '\\') BSBP.>$< (BSBP.char7 BSBP.>*< BSBP.word8) -- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument. --- Checking all these things may not be worth it. We could just double-quote everything. -pgDQuote :: [Char] -> BS.ByteString -> BSB.Builder -pgDQuote unsafe s - | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" = pgDQuote' s +pgDQuoteFrom :: [Char] -> BS.ByteString -> BSB.Builder +pgDQuoteFrom unsafe s + | BS.null s || BSC.any (\c -> isSpace c || c == '"' || c == '\\' || c `elem` unsafe) s || BSC.map toLower s == BSC.pack "null" = pgDQuote s | otherwise = BSB.byteString s -- |Parse double-quoted values ala 'pgDQuote'. @@ -776,7 +776,7 @@ newtype PGRecord = PGRecord [Maybe PGTextValue] class PGType t => PGRecordType t instance PGRecordType t => PGParameter t PGRecord where pgEncode _ (PGRecord l) = - buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuote "(),")) l) <> BSB.char7 ')' + buildPGValue $ BSB.char7 '(' <> mconcat (intersperse (BSB.char7 ',') $ map (maybe mempty (pgDQuoteFrom "(),")) l) <> BSB.char7 ')' pgLiteral _ (PGRecord l) = BSC.pack "ROW(" <> BS.intercalate (BSC.singleton ',') (map (maybe (BSC.pack "NULL") pgQuote) l) `BSC.snoc` ')' instance PGRecordType t => PGColumn t PGRecord where diff --git a/stack.yaml b/stack.yaml index e5f0220..fec8eb0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-10.2 +resolver: lts-11.1 packages: - '.' extra-deps: From 60c2b328dcccfd03d0b0d57eb9c480fd154e7eed Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 20 Mar 2018 09:56:58 -0400 Subject: [PATCH 241/306] Correct pgFetch documentation. --- Database/PostgreSQL/Typed/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 06bc7fa..bff8fea 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -906,7 +906,7 @@ pgBind c n bind = do rowDescription <$> pgRecv c where sn = preparedStatementName n --- |Fetch a single row from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete. +-- |Fetch some rows from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete. pgFetch :: PGConnection -> PGPreparedStatement -> Word32 -- ^Maximum number of rows to return, or 0 for all -> IO ([PGValues], Maybe Integer) pgFetch c n count = do From 13ba1683989b439aa58adf6baea921d6158c9960 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 26 Mar 2018 21:24:46 -0400 Subject: [PATCH 242/306] Monoid/Semigroup updates for base 4.10 --- Database/PostgreSQL/Typed/Range.hs | 41 +++++++++++++++++++----------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/Database/PostgreSQL/Typed/Range.hs b/Database/PostgreSQL/Typed/Range.hs index d7d5532..3a36e7d 100644 --- a/Database/PostgreSQL/Typed/Range.hs +++ b/Database/PostgreSQL/Typed/Range.hs @@ -14,17 +14,21 @@ module Database.PostgreSQL.Typed.Range where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<$)) +import Control.Applicative ((<$>), (<$)) #endif -import Control.Monad (guard) +import Control.Monad (guard) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC -import Data.Monoid ((<>)) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..)) +#else +import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) +import Data.Monoid (Monoid(..)) #endif -import GHC.TypeLits (Symbol) +#endif +import GHC.TypeLits (Symbol) import Database.PostgreSQL.Typed.Types @@ -205,18 +209,25 @@ intersect :: Ord a => Range a -> Range a -> Range a intersect (Range la ua) (Range lb ub) = normalize $ Range (max la lb) (min ua ub) intersect _ _ = Empty +-- |Union ranges. Fails if ranges are disjoint. +union :: Ord a => Range a -> Range a -> Range a +union Empty r = r +union r Empty = r +union _ra@(Range la ua) _rb@(Range lb ub) + -- isEmpty _ra = _rb + -- isEmpty _rb = _ra + | Bounded False False <- compareBounds lb ua = error "union: disjoint Ranges" + | Bounded False False <- compareBounds la ub = error "union: disjoint Ranges" + | otherwise = Range (min la lb) (max ua ub) + +#if MIN_VERSION_base(4,9,0) +instance Ord a => Semigroup (Range a) where + (<>) = union +#endif + instance Ord a => Monoid (Range a) where mempty = Empty - -- |Union ranges. Fails if ranges are disjoint. - mappend Empty r = r - mappend r Empty = r - mappend _ra@(Range la ua) _rb@(Range lb ub) - -- isEmpty _ra = _rb - -- isEmpty _rb = _ra - | Bounded False False <- compareBounds lb ua = error "mappend: disjoint Ranges" - | Bounded False False <- compareBounds la ub = error "mappend: disjoint Ranges" - | otherwise = Range (min la lb) (max ua ub) - + mappend = union -- |Class indicating that the first PostgreSQL type is a range of the second. -- This implies 'PGParameter' and 'PGColumn' instances that will work for any type. From 7a1d0897a32c98cbcaab6ed6bcb4c344a8a78a57 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 26 Mar 2018 21:27:33 -0400 Subject: [PATCH 243/306] Bump version to 0.5.3.0 Hopefully ghc 8.4 compatible now --- postgresql-typed.cabal | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 9215b79..58ce56e 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.5.2 +Version: 0.5.3.0 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING diff --git a/stack.yaml b/stack.yaml index fec8eb0..0240598 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.1 +resolver: lts-11.2 packages: - '.' extra-deps: From 049b7d8a3dbc81144e8bdb081171956224fbd830 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 5 Apr 2018 20:15:29 -0400 Subject: [PATCH 244/306] Add README to extra-source-files --- postgresql-typed.cabal | 1 + stack.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 58ce56e..6c73201 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -21,6 +21,7 @@ Description: Automatically type-check SQL statements at compile time. Originally based on Chris Forno's templatepg library. Tested-With: GHC == 7.10.3, GHC == 8.0.1 Build-Type: Simple +extra-source-files: README source-repository head type: git diff --git a/stack.yaml b/stack.yaml index 0240598..28a2df0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.2 +resolver: lts-11.3 packages: - '.' extra-deps: From 734f8742f387bc8cc29d287fae72d8362d872007 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 13 Apr 2018 17:07:06 -0400 Subject: [PATCH 245/306] Make result list pattern matching for pgSQL irrefutable Fixes #13 --- Database/PostgreSQL/Typed/Query.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 156c917..e13e6c6 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -213,7 +213,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do #endif ) prep) - `TH.AppE` TH.LamE [TH.VarP e, TH.ListP pats] (TH.TupE conv)) + `TH.AppE` TH.LamE [TH.VarP e, TH.TildeP (TH.ListP pats)] (TH.TupE conv)) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle From 964c7ec8dfb781a1607ef4a230ebfda39fdd2295 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 18 Apr 2018 13:53:01 -0400 Subject: [PATCH 246/306] Switch lambda pattern match to case with explicit error For unpacking database results. Fix #13 --- Database/PostgreSQL/Typed/Query.hs | 6 +++++- stack.yaml | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index e13e6c6..fb403e6 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -184,6 +184,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL" e <- TH.newName "_tenv" + l <- TH.newName "l" (vars, vals) <- mapAndUnzipM (\t -> do v <- newName 'p' $ tpgValueName t return @@ -213,7 +214,10 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do #endif ) prep) - `TH.AppE` TH.LamE [TH.VarP e, TH.TildeP (TH.ListP pats)] (TH.TupE conv)) + `TH.AppE` TH.LamE [TH.VarP e, TH.VarP l] (TH.CaseE (TH.VarE l) + [ TH.Match (TH.ListP pats) (TH.NormalB $ TH.TupE conv) [] + , TH.Match TH.WildP (TH.NormalB $ TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL "pgSQL: result arity mismatch")) [] + ])) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle diff --git a/stack.yaml b/stack.yaml index 28a2df0..8ee6196 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.3 +resolver: lts-11.5 packages: - '.' extra-deps: From bb87ac551a64588863f81965dc6ad302a6414c26 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 19 Jan 2019 00:25:32 -0500 Subject: [PATCH 247/306] Update db conn config to Network.Socket addrs Network package is now deprecated -- used only by TemplatePG for backwards compatibility. --- Database/PostgreSQL/Typed/Inet.hs | 23 ++++++++--------- Database/PostgreSQL/Typed/Protocol.hs | 27 +++++++++++++------- Database/PostgreSQL/Typed/TH.hs | 33 +++++++++++-------------- Database/PostgreSQL/Typed/TemplatePG.hs | 20 +++++++++------ stack.yaml | 5 +--- test/Connect.hs | 4 +-- test/Main.hs | 2 +- 7 files changed, 60 insertions(+), 54 deletions(-) diff --git a/Database/PostgreSQL/Typed/Inet.hs b/Database/PostgreSQL/Typed/Inet.hs index 8631797..30a2752 100644 --- a/Database/PostgreSQL/Typed/Inet.hs +++ b/Database/PostgreSQL/Typed/Inet.hs @@ -9,20 +9,20 @@ module Database.PostgreSQL.Typed.Inet where -import Control.Monad (void, guard, liftM2) +import Control.Monad (void, guard, liftM2) import qualified Data.ByteString.Char8 as BSC -import Data.Bits (shiftL, (.|.)) -import Data.Maybe (fromJust) -import Data.Word (Word8, Word16, Word32) -import Foreign.Marshal.Array (withArray) -import Foreign.Ptr (castPtr) -import Foreign.Storable (peek) +import Data.Bits (shiftL, (.|.)) +import Data.Maybe (fromJust) +import Data.Word (Word8, Word16, Word32) +import Foreign.Marshal.Array (withArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek) import qualified Network.Socket as Net -import Numeric (readDec, readHex) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Numeric (readDec, readHex) +import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Text.ParserCombinators.ReadP as RP import qualified Text.ParserCombinators.ReadPrec as RP (lift) -import Text.Read (Read(readPrec)) +import Text.Read (Read(readPrec)) import Database.PostgreSQL.Typed.Types @@ -50,7 +50,8 @@ bton32 (b1, b2, b3, b4) = unsafeDupablePerformIO $ instance Show PGInet where -- This is how Network.Socket's Show SockAddr does it: - show (PGInet a 32) = unsafeDupablePerformIO $ Net.inet_ntoa a + show (PGInet a 32) = fromJust $ fst $ unsafeDupablePerformIO $ + Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet 0 a) show (PGInet a m) = show (PGInet a 32) ++ '/' : show m show (PGInet6 a 128) = fromJust $ fst $ unsafeDupablePerformIO $ Net.getNameInfo [Net.NI_NUMERICHOST] True False (Net.SockAddrInet6 0 0 a 0) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index bff8fea..684ce40 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -87,8 +87,8 @@ import Data.Typeable (Typeable) import Data.Word (Word) #endif import Data.Word (Word32) -import Network (HostName, PortID(..), connectTo) -import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering)) +import qualified Network.Socket as Net +import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering), IOMode(ReadWriteMode)) import System.IO.Error (mkIOError, eofErrorType, ioError) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) @@ -109,8 +109,7 @@ data PGState -- |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\"@ + { pgDBAddr :: Either (Net.HostName, Net.ServiceName) Net.SockAddr -- ^ The address to connect to the server , pgDBName :: BS.ByteString -- ^ The name of the database , pgDBUser, pgDBPass :: BS.ByteString , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) @@ -119,8 +118,8 @@ data PGDatabase = PGDatabase } instance Eq PGDatabase where - PGDatabase h1 s1 n1 u1 p1 l1 _ _ == PGDatabase h2 s2 n2 u2 p2 l2 _ _ = - h1 == h2 && s1 == s2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 + PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ = + a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 newtype PGPreparedStatement = PGPreparedStatement Integer deriving (Eq, Show) @@ -274,8 +273,7 @@ defaultLogMessage = hPutStrLn stderr . displayMessage -- localhost:5432:postgres defaultPGDatabase :: PGDatabase defaultPGDatabase = PGDatabase - { pgDBHost = "localhost" - , pgDBPort = PortNumber 5432 + { pgDBAddr = Right $ Net.SockAddrInet 5432 (Net.tupleToHostAddress (127,0,0,1)) , pgDBName = "postgres" , pgDBUser = "postgres" , pgDBPass = BS.empty @@ -552,7 +550,17 @@ pgConnect db = do input <- newIORef getMessage tr <- newIORef 0 notif <- newIORef emptyQueue - h <- connectTo (pgDBHost db) (pgDBPort db) + addr <- either + (\(h,p) -> head <$> Net.getAddrInfo (Just defai) (Just h) (Just p)) + (\a -> return defai{ Net.addrAddress = a, Net.addrFamily = case a of + Net.SockAddrInet{} -> Net.AF_INET + Net.SockAddrInet6{} -> Net.AF_INET6 + Net.SockAddrUnix{} -> Net.AF_UNIX + _ -> Net.AF_UNSPEC }) + $ pgDBAddr db + sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) + Net.connect sock $ Net.addrAddress addr + h <- Net.socketToHandle sock ReadWriteMode hSetBuffering h (BlockBuffering Nothing) let c = PGConnection { connHandle = h @@ -580,6 +588,7 @@ pgConnect db = do pgFlush c conn c where + defai = Net.defaultHints{ Net.addrSocketType = Net.Stream } conn c = pgRecv c >>= msg c msg c (Right RecvSync) = do cp <- readIORef (connParameters c) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 116029c..6f23a5f 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -20,27 +20,23 @@ module Database.PostgreSQL.Typed.TH ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<$)) +import Control.Applicative ((<$>), (<$)) #endif -import Control.Applicative ((<|>)) -import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) -import Control.Exception (onException, finally) -import Control.Monad (liftM2) +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) +import Control.Exception (onException, finally) +import Control.Monad (liftM2) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold -import Data.Maybe (isJust, fromMaybe) -import Data.String (fromString) +import Data.Maybe (isJust, fromMaybe) +import Data.String (fromString) import qualified Data.Traversable as Tv import qualified Language.Haskell.TH as TH -import Network (PortID(PortNumber -#ifndef mingw32_HOST_OS - , UnixSocket -#endif - ), PortNumber) -import System.Environment (lookupEnv) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) +import qualified Network.Socket as Net +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Protocol @@ -53,17 +49,16 @@ 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" + pnum <- fromMaybe "5432" <$> lookupEnv "TPG_PORT" #ifdef mingw32_HOST_OS - let port = PortNumber pnum + let port = Right pnum #else - port <- maybe (PortNumber pnum) UnixSocket <$> lookupEnv "TPG_SOCK" + port <- maybe (Right pnum) Left <$> lookupEnv "TPG_SOCK" #endif pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" debug <- isJust <$> lookupEnv "TPG_DEBUG" return $ defaultPGDatabase - { pgDBHost = host - , pgDBPort = port + { pgDBAddr = either (Right . Net.SockAddrUnix) (Left . (,) host) port , pgDBName = BSU.fromString db , pgDBUser = BSU.fromString user , pgDBPass = BSU.fromString pass diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index 5126644..91a1b39 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- |This module exposes the high-level Template Haskell interface for querying @@ -22,15 +23,16 @@ module Database.PostgreSQL.Typed.TemplatePG , PG.pgDisconnect ) where -import Control.Exception (catchJust) -import Control.Monad (liftM, void, guard) -import Data.ByteString (ByteString) +import Control.Exception (catchJust) +import Control.Monad (liftM, void, guard) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.Maybe (listToMaybe, isJust) +import Data.Maybe (listToMaybe, isJust) import qualified Language.Haskell.TH as TH -import Network (HostName, PortID(..)) -import System.Environment (lookupEnv) +import Network (HostName, PortID(..)) +import qualified Network.Socket as Net +import System.Environment (lookupEnv) import qualified Database.PostgreSQL.Typed.Protocol as PG import Database.PostgreSQL.Typed.Query @@ -98,8 +100,10 @@ pgConnect :: HostName -- ^ the host to connect to pgConnect h n d u p = do debug <- isJust `liftM` lookupEnv "TPG_DEBUG" PG.pgConnect $ PG.defaultPGDatabase - { PG.pgDBHost = h - , PG.pgDBPort = n + { PG.pgDBAddr = case n of + PortNumber s -> Left (h, show s) + Service s -> Left (h, s) + UnixSocket s -> Right (Net.SockAddrUnix s) , PG.pgDBName = d , PG.pgDBUser = u , PG.pgDBPass = p diff --git a/stack.yaml b/stack.yaml index 8ee6196..03be2df 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,3 @@ -resolver: lts-11.5 +resolver: lts-13.3 packages: - '.' -extra-deps: -flags: {} -extra-package-dbs: [] diff --git a/test/Connect.hs b/test/Connect.hs index 7c57a5f..b70fc0a 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -2,13 +2,13 @@ module Connect where import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase) -import Network (PortID(UnixSocket)) +import Network.Socket (SockAddr(SockAddrUnix)) db :: PGDatabase db = defaultPGDatabase { pgDBName = "templatepg" #ifndef mingw32_HOST_OS - , pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432" + , pgDBAddr = Right (SockAddrUnix "/tmp/.s.PGSQL.5432") #endif , pgDBUser = "templatepg" -- , pgDBDebug = True diff --git a/test/Main.hs b/test/Main.hs index f98930c..e36b76b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DataKinds, DeriveDataTypeable, TypeFamilies, PatternGuards, StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -Wincomplete-uni-patterns #-} --{-# OPTIONS_GHC -ddump-splices #-} module Main (main) where From 115fabffceb2f07e6bc2d1957ce2c0cae417ad25 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 19 Jan 2019 14:11:28 -0500 Subject: [PATCH 248/306] Add some benchmarks --- postgresql-typed.cabal | 13 +++++++++++++ test/Bench.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+) create mode 100644 test/Bench.hs diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 6c73201..10e0627 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -131,3 +131,16 @@ test-suite hdbc build-depends: base, network, time, containers, convertible, postgresql-typed, HDBC, HUnit else buildable: False + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Bench.hs + other-modules: Connect + build-depends: + base, + bytestring, + time, + network, + criterion, + postgresql-typed diff --git a/test/Bench.hs b/test/Bench.hs new file mode 100644 index 0000000..a95314e --- /dev/null +++ b/test/Bench.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-} +module Main (main) where + +import qualified Data.ByteString as BS +import Data.Int (Int16, Int32, Int64) +import qualified Data.Time as Time +import qualified Criterion.Main as C +import System.Exit (exitSuccess, exitFailure) + +import Database.PostgreSQL.Typed +import Database.PostgreSQL.Typed.Types +import Database.PostgreSQL.Typed.Query + +import Connect + +useTPGDatabase db + +selectTypes :: PGConnection -> IO [(String, OID, Int16, Bool, Maybe BS.ByteString)] +selectTypes c = pgQuery c [pgSQL|SELECT typname, typnamespace, typlen, typbyval, typdefault FROM pg_catalog.pg_type|] + +selectTypesLazy :: PGConnection -> IO [(String, OID, Int16, Bool, Maybe BS.ByteString)] +selectTypesLazy c = pgLazyQuery c [pgSQL|$SELECT typname, typnamespace, typlen, typbyval, typdefault FROM pg_catalog.pg_type|] 1 + +selectParams :: PGConnection -> IO [(Maybe String, Maybe Int64, Maybe Double, Maybe BS.ByteString, Maybe Bool)] +selectParams c = pgQuery c [pgSQL|$SELECT ${"hello"}::text, ${123::Int64}::bigint, ${123.4::Double}::float, ${BS.pack [120..220]}::bytea, ${Nothing::Maybe Bool}::boolean|] + +selectValues :: PGConnection -> IO [(Int32, Time.UTCTime)] +selectValues c = pgQuery c [pgSQL|!SELECT generate_series, now() FROM generate_series(8,256)|] + +selectValuesLazy :: PGConnection -> IO [(Int32, Time.UTCTime)] +selectValuesLazy c = pgLazyQuery c [pgSQL|$!SELECT generate_series, now() FROM generate_series(8,256)|] 5 + +main :: IO () +main = do + c <- pgConnect db + C.defaultMain + [ C.bench "types" $ C.nfIO $ selectTypes c + , C.bench "types lazy" $ C.nfIO $ selectTypesLazy c + , C.bench "params" $ C.nfIO $ selectParams c + , C.bench "values" $ C.nfIO $ selectValues c + , C.bench "values lazy" $ C.nfIO $ selectValuesLazy c + ] From 5d3b72a9a33f29672746a3eb2f4d110b7fc00a53 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Tue, 14 May 2019 16:58:00 +0200 Subject: [PATCH 249/306] Refactored to use Socket instead of Handle Had to drop pgGetNotifications since there's no way to (easily) implement non-blocking receives over a socket --- Database/PostgreSQL/Typed/Protocol.hs | 62 +++++++++++++-------------- test/Main.hs | 3 -- 2 files changed, 29 insertions(+), 36 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 684ce40..e5dd653 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -50,7 +50,6 @@ module Database.PostgreSQL.Typed.Protocol ( , pgFetch -- * Notifications , PGNotification(..) - , pgGetNotifications , pgGetNotification ) where @@ -88,7 +87,9 @@ import Data.Word (Word) #endif import Data.Word (Word32) import qualified Network.Socket as Net -import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering), IOMode(ReadWriteMode)) +import qualified Network.Socket.ByteString as NetBS +import qualified Network.Socket.ByteString.Lazy as NetBSL +import System.IO (stderr, hPutStrLn) import System.IO.Error (mkIOError, eofErrorType, ioError) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) @@ -127,10 +128,28 @@ newtype PGPreparedStatement = PGPreparedStatement Integer preparedStatementName :: PGPreparedStatement -> BS.ByteString preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n +data PGHandle + = PGSocket Net.Socket + +pgPutBuilder :: PGHandle -> B.Builder -> IO () +pgPutBuilder (PGSocket s) b = NetBSL.sendAll s (B.toLazyByteString b) + +pgPut:: PGHandle -> BS.ByteString -> IO () +pgPut (PGSocket s) = NetBS.sendAll s + +pgGetSome :: PGHandle -> Int -> IO BSC.ByteString +pgGetSome (PGSocket s) = NetBS.recv s + +pgCloseHandle :: PGHandle -> IO () +pgCloseHandle (PGSocket s) = Net.close s + +pgFlush :: PGConnection -> IO () +pgFlush PGConnection{connHandle=PGSocket _} = pure () + -- |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 + { connHandle :: PGHandle , connDatabase :: !PGDatabase , connPid :: !Word32 -- unused , connKey :: !Word32 -- unused @@ -177,9 +196,6 @@ deQueue (Queue e (x:d)) = (Queue e d, Just x) deQueue (Queue (reverse -> x:d) []) = (Queue [] d, Just x) deQueue q = (q, Nothing) -queueToList :: Queue a -> [a] -queueToList (Queue e d) = d ++ reverse e - -- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send. -- See . data PGFrontendMessage @@ -359,8 +375,8 @@ pgSend :: PGConnection -> PGFrontendMessage -> IO () pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do modifyIORef' sr $ state msg 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 + pgPutBuilder h $ Fold.foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + BS.length b) + pgPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length where (t, b) = second (BSL.toStrict . B.toLazyByteString) $ messageBody msg state _ StateClosed = StateClosed @@ -369,9 +385,6 @@ pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do state Terminate _ = StateClosed state _ _ = StateUnsync -pgFlush :: PGConnection -> IO () -pgFlush = hFlush . connHandle - getByteStringNul :: G.Get BS.ByteString getByteStringNul = fmap BSL.toStrict G.getLazyByteStringNul @@ -450,13 +463,13 @@ class Show m => RecvMsg m where -- |Read from connection, returning immediate value or non-empty data recvMsgData :: PGConnection -> IO (Either m BS.ByteString) recvMsgData c = do - r <- BS.hGetSome (connHandle c) smallChunkSize + r <- pgGetSome (connHandle c) smallChunkSize if BS.null r then do writeIORef (connState c) StateClosed - hClose (connHandle c) + pgCloseHandle (connHandle c) -- Should this instead be a special PGError? - ioError $ mkIOError eofErrorType "PGConnection" (Just (connHandle c)) Nothing + ioError $ mkIOError eofErrorType "PGConnection" Nothing Nothing else return (Right r) -- |Expected ReadyForQuery message @@ -475,15 +488,6 @@ class Show m => RecvMsg m where recvMsg c m = Nothing <$ connLogMessage c (makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query") --- |Process all pending messages -data RecvNonBlock = RecvNonBlock deriving (Show) -instance RecvMsg RecvNonBlock where - recvMsgData c = do - r <- BS.hGetNonBlocking (connHandle c) smallChunkSize - if BS.null r - then return (Left RecvNonBlock) - else return (Right r) - -- |Wait for ReadyForQuery data RecvSync = RecvSync deriving (Show) instance RecvMsg RecvSync where @@ -560,10 +564,8 @@ pgConnect db = do $ pgDBAddr db sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) Net.connect sock $ Net.addrAddress addr - h <- Net.socketToHandle sock ReadWriteMode - hSetBuffering h (BlockBuffering Nothing) let c = PGConnection - { connHandle = h + { connHandle = PGSocket sock , connDatabase = db , connPid = 0 , connKey = 0 @@ -616,7 +618,7 @@ pgConnect db = do pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () pgDisconnect c@PGConnection{ connHandle = h } = - pgSend c Terminate `finally` hClose h + pgSend c Terminate `finally` pgCloseHandle h -- |Disconnect cleanly from the PostgreSQL server, but only if it's still connected. pgDisconnectOnce :: PGConnection -- ^ a handle from 'pgConnect' @@ -937,12 +939,6 @@ pgFetch c n count = do res EmptyQueryResponse = return ([], Just 0) res m = fail $ "pgFetch: unexpected response: " ++ show m --- |Retrieve any pending notifications. Non-blocking. -pgGetNotifications :: PGConnection -> IO [PGNotification] -pgGetNotifications c = do - RecvNonBlock <- pgRecv c - queueToList <$> atomicModifyIORef' (connNotifications c) (emptyQueue, ) - -- |Retrieve a notifications, blocking if necessary. pgGetNotification :: PGConnection -> IO PGNotification pgGetNotification c = diff --git a/test/Main.hs b/test/Main.hs index e36b76b..33ee9d8 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -171,8 +171,5 @@ main = do Left e2 <- try $ pgSimpleQuery c "SELECT 1" assert $ pgErrorCode e2 == PGErr.in_failed_sql_transaction - [PGNotification _ "channame" "there", PGNotification _ "channame" ""] <- pgGetNotifications c - [] <- pgGetNotifications c - pgDisconnect c exitSuccess From 9a464b7a7ad26934b09ca442e78d6852d142f626 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Tue, 14 May 2019 17:51:43 +0200 Subject: [PATCH 250/306] preliminary TLS support --- Database/PostgreSQL/Typed/Protocol.hs | 59 +++++++++++++++++++++++---- postgresql-typed.cabal | 2 + 2 files changed, 53 insertions(+), 8 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index e5dd653..4f312ef 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno @@ -57,7 +57,7 @@ module Database.PostgreSQL.Typed.Protocol ( import Control.Applicative ((<$>), (<$)) #endif import Control.Arrow ((&&&), first, second) -import Control.Exception (Exception, throwIO, onException, finally) +import Control.Exception (Exception, throwIO, onException, finally, catch) import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef VERSION_cryptonite import qualified Crypto.Hash as Hash @@ -71,6 +71,7 @@ import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.ByteString.Lazy.Internal (smallChunkSize) +import Data.Default (def) import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef') import Data.Int (Int32, Int16) @@ -89,8 +90,10 @@ import Data.Word (Word32) import qualified Network.Socket as Net import qualified Network.Socket.ByteString as NetBS import qualified Network.Socket.ByteString.Lazy as NetBSL +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS import System.IO (stderr, hPutStrLn) -import System.IO.Error (mkIOError, eofErrorType, ioError) +import System.IO.Error (IOError, mkIOError, eofErrorType, ioError) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) @@ -116,11 +119,12 @@ data PGDatabase = PGDatabase , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) + , pgDBTLS :: Bool -- ^ Use TLS } instance Eq PGDatabase where - PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ = - a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 + PGDatabase a1 n1 u1 p1 l1 _ _ s1 == PGDatabase a2 n2 u2 p2 l2 _ _ s2 = + a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 && s2 newtype PGPreparedStatement = PGPreparedStatement Integer deriving (Eq, Show) @@ -130,21 +134,29 @@ preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n data PGHandle = PGSocket Net.Socket + | PGTlsContext TLS.Context pgPutBuilder :: PGHandle -> B.Builder -> IO () pgPutBuilder (PGSocket s) b = NetBSL.sendAll s (B.toLazyByteString b) +pgPutBuilder (PGTlsContext c) b = TLS.sendData c (B.toLazyByteString b) pgPut:: PGHandle -> BS.ByteString -> IO () -pgPut (PGSocket s) = NetBS.sendAll s +pgPut (PGSocket s) bs = NetBS.sendAll s bs +pgPut (PGTlsContext c) bs = TLS.sendData c (BSL.fromChunks [bs]) pgGetSome :: PGHandle -> Int -> IO BSC.ByteString -pgGetSome (PGSocket s) = NetBS.recv s +pgGetSome (PGSocket s) count = NetBS.recv s count +pgGetSome (PGTlsContext c) _ = TLS.recvData c pgCloseHandle :: PGHandle -> IO () pgCloseHandle (PGSocket s) = Net.close s +pgCloseHandle (PGTlsContext c) = do + TLS.bye c `catch` \(_ :: IOError) -> pure () + TLS.contextClose c pgFlush :: PGConnection -> IO () pgFlush PGConnection{connHandle=PGSocket _} = pure () +pgFlush PGConnection{connHandle=PGTlsContext c} = TLS.contextFlush c -- |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. @@ -296,6 +308,7 @@ defaultPGDatabase = PGDatabase , pgDBParams = [] , pgDBDebug = False , pgDBLogMessage = defaultLogMessage + , pgDBTLS = False } connDebug :: PGConnection -> Bool @@ -564,8 +577,38 @@ pgConnect db = do $ pgDBAddr db sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) Net.connect sock $ Net.addrAddress addr + pgHandle <- if pgDBTLS db + then do + let + params = (TLS.defaultParamsClient tlsHost tlsPort) + { TLS.clientSupported = + def { TLS.supportedCiphers = TLS.ciphersuite_strong } + , TLS.clientShared = + def { TLS.sharedValidationCache = noValidate } --FIXME: Validate server certificate + } + tlsHost = case pgDBAddr db of + Left (h,_) -> h + Right (Net.SockAddrUnix s) -> s + Right _ -> "some-socket" + tlsPort = case pgDBAddr db of + Left (_,p) -> BSC.pack p + Right _ -> "socket" + noValidate = TLS.ValidationCache + (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + sslRequest = B.toLazyByteString (B.word32BE 8 <> B.word32BE 80877103) + NetBSL.sendAll sock sslRequest + resp <- NetBS.recv sock 1 + case resp of + "S" -> do + ctx <- TLS.contextNew sock params + void $ TLS.handshake ctx + pure $ PGTlsContext ctx + "N" -> throwIO (userError "Server does not support TLS") + _ -> throwIO (userError "Unexpected response from server when issuing SSLRequest") + else pure (PGSocket sock) let c = PGConnection - { connHandle = PGSocket sock + { connHandle = pgHandle , connDatabase = db , connPid = 0 , connKey = 0 diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 10e0627..0448044 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -60,8 +60,10 @@ Library array, binary, containers, + data-default, old-locale, time, + tls, bytestring >= 0.10.2, template-haskell, haskell-src-meta, From b40bea3eb4c795bf89dac3cf9bb42b79cb1f7831 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Tue, 14 May 2019 17:51:57 +0200 Subject: [PATCH 251/306] allow overriding socket path in tests --- test/Connect.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/Connect.hs b/test/Connect.hs index b70fc0a..326ce0f 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -1,14 +1,17 @@ {-# LANGUAGE CPP, OverloadedStrings #-} module Connect where +import Data.Maybe (fromMaybe) import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase) import Network.Socket (SockAddr(SockAddrUnix)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) db :: PGDatabase db = defaultPGDatabase { pgDBName = "templatepg" #ifndef mingw32_HOST_OS - , pgDBAddr = Right (SockAddrUnix "/tmp/.s.PGSQL.5432") + , pgDBAddr = Right (SockAddrUnix (fromMaybe "/tmp/.s.PGSQL.5432" (unsafePerformIO (lookupEnv "PGSOCK")))) #endif , pgDBUser = "templatepg" -- , pgDBDebug = True From b45d379a983fccef8c5fba42df3f2aa3d163f616 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 15 May 2019 21:30:05 +0200 Subject: [PATCH 252/306] resurrected pgGetNotifications --- Database/PostgreSQL/Typed/Protocol.hs | 64 +++++++++++++++++++++++++-- test/Main.hs | 3 ++ 2 files changed, 64 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 4f312ef..125b0c1 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -51,6 +52,7 @@ module Database.PostgreSQL.Typed.Protocol ( -- * Notifications , PGNotification(..) , pgGetNotification + , pgGetNotifications ) where #if !MIN_VERSION_base(4,8,0) @@ -67,7 +69,7 @@ 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 Data.ByteString.Internal (w2c, createAndTrim) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.ByteString.Lazy.Internal (smallChunkSize) @@ -86,14 +88,18 @@ import Data.Typeable (Typeable) #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif -import Data.Word (Word32) +import Data.Word (Word32, Word8) +import Foreign.C.Error (eWOULDBLOCK, getErrno, throwErrno) +import Foreign.C.Types (CChar(..), CInt(..), CSize(..)) +import Foreign.Ptr (Ptr, castPtr) +import GHC.IO.Exception (IOErrorType(InvalidArgument)) import qualified Network.Socket as Net import qualified Network.Socket.ByteString as NetBS import qualified Network.Socket.ByteString.Lazy as NetBSL import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import System.IO (stderr, hPutStrLn) -import System.IO.Error (IOError, mkIOError, eofErrorType, ioError) +import System.IO.Error (IOError, mkIOError, eofErrorType, ioError, ioeSetErrorString) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) @@ -501,6 +507,17 @@ class Show m => RecvMsg m where recvMsg c m = Nothing <$ connLogMessage c (makeMessage (BSC.pack $ "Unexpected server message: " ++ show m) "Each statement should only contain a single query") +-- |Process all pending messages +data RecvNonBlock = RecvNonBlock deriving (Show) +instance RecvMsg RecvNonBlock where + recvMsgData PGConnection{connHandle=PGSocket s} = do + r <- recvNoBlock s smallChunkSize + if BS.null r + then return (Left RecvNonBlock) + else return (Right r) + recvMsgData PGConnection{connHandle=PGTlsContext _} = + throwIO (userError "Non-blocking receive is not supported on TLS connections") + -- |Wait for ReadyForQuery data RecvSync = RecvSync deriving (Show) instance RecvMsg RecvSync where @@ -987,3 +1004,44 @@ pgGetNotification :: PGConnection -> IO PGNotification pgGetNotification c = maybe (pgRecv c) return =<< atomicModifyIORef' (connNotifications c) deQueue + +-- |Retrieve any pending notifications. Non-blocking. +pgGetNotifications :: PGConnection -> IO [PGNotification] +pgGetNotifications c = do + RecvNonBlock <- pgRecv c + queueToList <$> atomicModifyIORef' (connNotifications c) (emptyQueue, ) + where + queueToList :: Queue a -> [a] + queueToList (Queue e d) = d ++ reverse e + + +recvNoBlock + :: Net.Socket -- ^ Connected socket + -> Int -- ^ Maximum number of bytes to receive + -> IO BS.ByteString -- ^ Data received +recvNoBlock s nbytes + | nbytes < 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.Protocol.recvNoBlock") + | otherwise = createAndTrim nbytes $ \ptr -> recvBufNoBlock s ptr nbytes + +recvBufNoBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int +recvBufNoBlock s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNoBlock") + | otherwise = do + len <- c_recv (Net.fdSocket s) (castPtr ptr) (fromIntegral nbytes) 0 + if (len == -1) + then do + errno <- getErrno + if errno == eWOULDBLOCK + then return 0 + else throwErrno "Database.PostgreSQL.Typed.recvBufNoBlock" + else + return $ fromIntegral len + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError + InvalidArgument + loc Nothing Nothing) "non-positive length" + + +foreign import ccall unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt diff --git a/test/Main.hs b/test/Main.hs index 33ee9d8..e36b76b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -171,5 +171,8 @@ main = do Left e2 <- try $ pgSimpleQuery c "SELECT 1" assert $ pgErrorCode e2 == PGErr.in_failed_sql_transaction + [PGNotification _ "channame" "there", PGNotification _ "channame" ""] <- pgGetNotifications c + [] <- pgGetNotifications c + pgDisconnect c exitSuccess From b4e9ded10230698ead9153a3cc8321e066afd28f Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 15 May 2019 21:31:39 +0200 Subject: [PATCH 253/306] fixed Eq PGDatabase instance --- Database/PostgreSQL/Typed/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 125b0c1..ae8ec69 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -130,7 +130,7 @@ data PGDatabase = PGDatabase instance Eq PGDatabase where PGDatabase a1 n1 u1 p1 l1 _ _ s1 == PGDatabase a2 n2 u2 p2 l2 _ _ s2 = - a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 && s2 + a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 == s2 newtype PGPreparedStatement = PGPreparedStatement Integer deriving (Eq, Show) From fd9af1e799c50ea91abacaa7df8fa882acf45463 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Fri, 17 May 2019 11:57:41 +0200 Subject: [PATCH 254/306] TLS certificate validation and some cleanup --- Database/PostgreSQL/Typed/Protocol.hs | 136 ++++++++++++++++++-------- Database/PostgreSQL/Typed/TH.hs | 19 +++- postgresql-typed.cabal | 5 +- 3 files changed, 115 insertions(+), 45 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index ae8ec69..05756bb 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -19,6 +19,8 @@ module Database.PostgreSQL.Typed.Protocol ( , defaultPGDatabase , PGConnection , PGError(..) + , PGTlsMode(..) + , PGTlsValidateMode (..) , pgErrorCode , pgConnectionDatabase , pgTypeEnv @@ -53,6 +55,8 @@ module Database.PostgreSQL.Typed.Protocol ( , PGNotification(..) , pgGetNotification , pgGetNotifications + -- * Helpers + , pgTlsValidate ) where #if !MIN_VERSION_base(4,8,0) @@ -89,7 +93,11 @@ import Data.Typeable (Typeable) import Data.Word (Word) #endif import Data.Word (Word32, Word8) -import Foreign.C.Error (eWOULDBLOCK, getErrno, throwErrno) +import Data.X509 (SignedCertificate, HashALG(HashSHA256)) +import Data.X509.Memory (readSignedObjectFromMemory) +import Data.X509.CertificateStore (makeCertificateStore) +import qualified Data.X509.Validation +import Foreign.C.Error (eWOULDBLOCK, getErrno, errnoToIOError) import Foreign.C.Types (CChar(..), CInt(..), CSize(..)) import Foreign.Ptr (Ptr, castPtr) import GHC.IO.Exception (IOErrorType(InvalidArgument)) @@ -117,6 +125,31 @@ data PGState | StateClosed deriving (Show, Eq) +data PGTlsValidateMode + = TlsValidateFull + -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQDN against the + -- certicate's CN + | TlsValidateCA + -- ^ Equivalent to sslmode=verify-ca. Ie: Only check that the certificate has + -- been signed by the root certificate we provide + deriving (Show, Eq) + +data PGTlsMode + = TlsDisabled + -- ^ TLS is disabled + | TlsNoValidate + | TlsValidate PGTlsValidateMode SignedCertificate + deriving (Eq, Show) + +-- | Constructs a 'PGTlsMode' to validate the server certificate with given root +-- certificate (in PEM format) +pgTlsValidate :: PGTlsValidateMode -> BSC.ByteString -> Either String PGTlsMode +pgTlsValidate mode certPem = + case readSignedObjectFromMemory certPem of + [x] -> Right (TlsValidate mode x) + [] -> Left "Could not parse any certificate in PEM" + _ -> Left "Many certificates in PEM" + -- |Information for how to connect to a database, to be passed to 'pgConnect'. data PGDatabase = PGDatabase { pgDBAddr :: Either (Net.HostName, Net.ServiceName) Net.SockAddr -- ^ The address to connect to the server @@ -125,7 +158,7 @@ data PGDatabase = PGDatabase , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) - , pgDBTLS :: Bool -- ^ Use TLS + , pgDBTLS :: PGTlsMode -- ^ TLS mode } instance Eq PGDatabase where @@ -314,7 +347,7 @@ defaultPGDatabase = PGDatabase , pgDBParams = [] , pgDBDebug = False , pgDBLogMessage = defaultLogMessage - , pgDBTLS = False + , pgDBTLS = TlsDisabled } connDebug :: PGConnection -> Bool @@ -511,12 +544,12 @@ class Show m => RecvMsg m where data RecvNonBlock = RecvNonBlock deriving (Show) instance RecvMsg RecvNonBlock where recvMsgData PGConnection{connHandle=PGSocket s} = do - r <- recvNoBlock s smallChunkSize + r <- recvNonBlock s smallChunkSize if BS.null r then return (Left RecvNonBlock) else return (Right r) recvMsgData PGConnection{connHandle=PGTlsContext _} = - throwIO (userError "Non-blocking receive is not supported on TLS connections") + throwIO (userError "Non-blocking recvMsgData is not supported on TLS connections") -- |Wait for ReadyForQuery data RecvSync = RecvSync deriving (Show) @@ -594,36 +627,7 @@ pgConnect db = do $ pgDBAddr db sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) Net.connect sock $ Net.addrAddress addr - pgHandle <- if pgDBTLS db - then do - let - params = (TLS.defaultParamsClient tlsHost tlsPort) - { TLS.clientSupported = - def { TLS.supportedCiphers = TLS.ciphersuite_strong } - , TLS.clientShared = - def { TLS.sharedValidationCache = noValidate } --FIXME: Validate server certificate - } - tlsHost = case pgDBAddr db of - Left (h,_) -> h - Right (Net.SockAddrUnix s) -> s - Right _ -> "some-socket" - tlsPort = case pgDBAddr db of - Left (_,p) -> BSC.pack p - Right _ -> "socket" - noValidate = TLS.ValidationCache - (\_ _ _ -> return TLS.ValidationCachePass) - (\_ _ _ -> return ()) - sslRequest = B.toLazyByteString (B.word32BE 8 <> B.word32BE 80877103) - NetBSL.sendAll sock sslRequest - resp <- NetBS.recv sock 1 - case resp of - "S" -> do - ctx <- TLS.contextNew sock params - void $ TLS.handshake ctx - pure $ PGTlsContext ctx - "N" -> throwIO (userError "Server does not support TLS") - _ -> throwIO (userError "Unexpected response from server when issuing SSLRequest") - else pure (PGSocket sock) + pgHandle <- mkPGHandle db sock let c = PGConnection { connHandle = pgHandle , connDatabase = db @@ -674,6 +678,52 @@ pgConnect db = do #endif msg _ (Left m) = fail $ "pgConnect: unexpected response: " ++ show m +mkPGHandle :: PGDatabase -> Net.Socket -> IO PGHandle +mkPGHandle db sock = + case pgDBTLS db of + TlsDisabled -> pure (PGSocket sock) + TlsNoValidate -> mkTlsContext + TlsValidate _ _ -> mkTlsContext + where + mkTlsContext = do + NetBSL.sendAll sock sslRequest + resp <- NetBS.recv sock 1 + case resp of + "S" -> do + ctx <- TLS.contextNew sock params + void $ TLS.handshake ctx + pure $ PGTlsContext ctx + "N" -> throwIO (userError "Server does not support TLS") + _ -> throwIO (userError "Unexpected response from server when issuing SSLRequest") + params = (TLS.defaultParamsClient tlsHost tlsPort) + { TLS.clientSupported = + def { TLS.supportedCiphers = TLS.ciphersuite_strong } + , TLS.clientShared = clientShared + , TLS.clientHooks = clientHooks + } + tlsHost = case pgDBAddr db of + Left (h,_) -> h + Right (Net.SockAddrUnix s) -> s + Right _ -> "some-socket" + tlsPort = case pgDBAddr db of + Left (_,p) -> BSC.pack p + Right _ -> "socket" + clientShared = + case pgDBTLS db of + TlsDisabled -> def { TLS.sharedValidationCache = noValidate } + TlsNoValidate -> def { TLS.sharedValidationCache = noValidate } + TlsValidate _ sc -> def { TLS.sharedCAStore = makeCertificateStore [sc] } + clientHooks = + case pgDBTLS db of + TlsValidate TlsValidateCA _ -> def { TLS.onServerCertificate = validateNoCheckFQHN } + _ -> def + validateNoCheckFQHN = Data.X509.Validation.validate HashSHA256 def (def { TLS.checkFQHN = False }) + + noValidate = TLS.ValidationCache + (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + sslRequest = B.toLazyByteString (B.word32BE 8 <> B.word32BE 80877103) + -- |Disconnect cleanly from the PostgreSQL server. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () @@ -1015,17 +1065,17 @@ pgGetNotifications c = do queueToList (Queue e d) = d ++ reverse e -recvNoBlock +recvNonBlock :: Net.Socket -- ^ Connected socket -> Int -- ^ Maximum number of bytes to receive -> IO BS.ByteString -- ^ Data received -recvNoBlock s nbytes - | nbytes < 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.Protocol.recvNoBlock") - | otherwise = createAndTrim nbytes $ \ptr -> recvBufNoBlock s ptr nbytes +recvNonBlock s nbytes + | nbytes < 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.Protocol.recvNonBlock") + | otherwise = createAndTrim nbytes $ \ptr -> recvBufNonBlock s ptr nbytes -recvBufNoBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int -recvBufNoBlock s ptr nbytes - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNoBlock") +recvBufNonBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int +recvBufNonBlock s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNonBlock") | otherwise = do len <- c_recv (Net.fdSocket s) (castPtr ptr) (fromIntegral nbytes) 0 if (len == -1) @@ -1033,7 +1083,7 @@ recvBufNoBlock s ptr nbytes errno <- getErrno if errno == eWOULDBLOCK then return 0 - else throwErrno "Database.PostgreSQL.Typed.recvBufNoBlock" + else throwIO (errnoToIOError "recvBufNonBlock" errno Nothing (Just "Database.PostgreSQL.Typed")) else return $ fromIntegral len diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 6f23a5f..dba3b8e 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -24,9 +24,10 @@ import Control.Applicative ((<$>), (<$)) #endif import Control.Applicative ((<|>)) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) -import Control.Exception (onException, finally) +import Control.Exception (onException, finally, throwIO) import Control.Monad (liftM2) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold @@ -57,12 +58,28 @@ getTPGDatabase = do #endif pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" debug <- isJust <$> lookupEnv "TPG_DEBUG" + tlsVerify <- isJust <$> lookupEnv "TPG_TLS" + tlsVerifyMode <- lookupEnv "TPG_TLS_MODE" >>= \modeStr -> + case modeStr of + Just "full" -> pure TlsValidateFull + Just "ca" -> pure TlsValidateCA + Just other -> throwIO (userError ("Unknown verify mode: " ++ other)) + Nothing -> pure TlsValidateCA + mTlsCertPem <- lookupEnv "TPG_TLS_ROOT_CERT" + dbTls <- case mTlsCertPem of + Just certPem -> + case pgTlsValidate tlsVerifyMode (BSC.pack certPem) of + Right x -> pure x + Left err -> throwIO (userError err) + Nothing | tlsVerify -> pure TlsNoValidate + Nothing -> pure TlsDisabled return $ defaultPGDatabase { pgDBAddr = either (Right . Net.SockAddrUnix) (Left . (,) host) port , pgDBName = BSU.fromString db , pgDBUser = BSU.fromString user , pgDBPass = BSU.fromString pass , pgDBDebug = debug + , pgDBTLS = dbTls } {-# NOINLINE tpgState #-} diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0448044..99387d8 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -69,7 +69,10 @@ Library haskell-src-meta, network, attoparsec >= 0.12 && < 0.14, - utf8-string + utf8-string, + x509, + x509-store, + x509-validation Exposed-Modules: Database.PostgreSQL.Typed Database.PostgreSQL.Typed.Protocol From 6667faa43b16421c770b4ab2bcbb2c744d5320a9 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Mon, 20 May 2019 11:14:29 +0200 Subject: [PATCH 255/306] Build test db connection from env vars to allow enabling TLS --- Database/PostgreSQL/Typed/Protocol.hs | 11 ++++-- test/Connect.hs | 54 ++++++++++++++++++++------- test/Main.hs | 7 +++- 3 files changed, 53 insertions(+), 19 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 05756bb..caed847 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -57,6 +57,7 @@ module Database.PostgreSQL.Typed.Protocol ( , pgGetNotifications -- * Helpers , pgTlsValidate + , pgSupportsTls ) where #if !MIN_VERSION_base(4,8,0) @@ -127,7 +128,7 @@ data PGState data PGTlsValidateMode = TlsValidateFull - -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQDN against the + -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQHN against the -- certicate's CN | TlsValidateCA -- ^ Equivalent to sslmode=verify-ca. Ie: Only check that the certificate has @@ -214,6 +215,10 @@ data PGConnection = PGConnection , connNotifications :: IORef (Queue PGNotification) } +pgSupportsTls :: PGConnection -> Bool +pgSupportsTls PGConnection{connHandle=PGTlsContext _} = True +pgSupportsTls _ = False + data PGColDescription = PGColDescription { pgColName :: BS.ByteString , pgColTable :: !OID @@ -1078,14 +1083,14 @@ recvBufNonBlock s ptr nbytes | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNonBlock") | otherwise = do len <- c_recv (Net.fdSocket s) (castPtr ptr) (fromIntegral nbytes) 0 - if (len == -1) + if len == -1 then do errno <- getErrno if errno == eWOULDBLOCK then return 0 else throwIO (errnoToIOError "recvBufNonBlock" errno Nothing (Just "Database.PostgreSQL.Typed")) else - return $ fromIntegral len + return $ fromIntegral len mkInvalidRecvArgError :: String -> IOError mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError diff --git a/test/Connect.hs b/test/Connect.hs index 326ce0f..241fb82 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -1,20 +1,46 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Connect where -import Data.Maybe (fromMaybe) -import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase) -import Network.Socket (SockAddr(SockAddrUnix)) -import System.Environment (lookupEnv) -import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (throwIO) +import qualified Data.ByteString.Char8 as BSC +import Data.Maybe (fromMaybe, isJust) +import Database.PostgreSQL.Typed (PGDatabase (..), + defaultPGDatabase) +import Database.PostgreSQL.Typed.Protocol (PGTlsMode (..), + PGTlsValidateMode (..), + pgTlsValidate) +import Network.Socket (SockAddr (SockAddrUnix)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) db :: PGDatabase -db = defaultPGDatabase - { pgDBName = "templatepg" +db = unsafePerformIO $ do + mPort <- lookupEnv "PGPORT" + pgDBAddr <- case mPort of + Nothing -> + Right . SockAddrUnix . fromMaybe "/tmp/.s.PGSQL.5432" <$> lookupEnv "PGSOCK" + Just port -> pure $ Left ("localhost", port) + pgDBTLS <- do + enabled <- isJust <$> lookupEnv "PGTLS" + validateFull <- isJust <$> lookupEnv "PGTLS_VALIDATEFULL" + rootcert <- fmap BSC.pack <$> lookupEnv "PGTLS_ROOTCERT" + case (enabled,validateFull,rootcert) of + (False,_,_) -> pure TlsDisabled + (True,False,Nothing) -> pure TlsNoValidate + (True,True,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateFull cert + (True,True,Nothing) -> throwIO $ userError "Need to pass the root certificate on the PGTLS_ROOTCERT environment variable to validate FQHN" + (True,False,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateCA cert + pgDBDebug <- isJust <$> lookupEnv "PG_DEBUG" + pure $ defaultPGDatabase + { pgDBName = "templatepg" + , pgDBUser = "templatepg" + , pgDBParams = [("TimeZone", "UTC")] + , pgDBDebug + , pgDBTLS #ifndef mingw32_HOST_OS - , pgDBAddr = Right (SockAddrUnix (fromMaybe "/tmp/.s.PGSQL.5432" (unsafePerformIO (lookupEnv "PGSOCK")))) + , pgDBAddr #endif - , pgDBUser = "templatepg" - -- , pgDBDebug = True - , pgDBParams = [("TimeZone", "UTC")] - } - + } +{-# NOINLINE db #-} diff --git a/test/Main.hs b/test/Main.hs index e36b76b..42ccf0b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ module Main (main) where import Control.Exception (try) +import Control.Monad (unless) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.Char (isDigit, toUpper) @@ -171,8 +172,10 @@ main = do Left e2 <- try $ pgSimpleQuery c "SELECT 1" assert $ pgErrorCode e2 == PGErr.in_failed_sql_transaction - [PGNotification _ "channame" "there", PGNotification _ "channame" ""] <- pgGetNotifications c - [] <- pgGetNotifications c + unless (pgSupportsTls c) $ do + [PGNotification _ "channame" "there", PGNotification _ "channame" ""] <- pgGetNotifications c + [] <- pgGetNotifications c + pure () pgDisconnect c exitSuccess From 8bff4b407b7914dac5ee41ef84edf2154571e328 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 22 May 2019 10:07:21 +0200 Subject: [PATCH 256/306] add bytestring dependency to hdbc test suite --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 99387d8..8086e67 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -133,7 +133,7 @@ test-suite hdbc Testbasics Tests if flag(HDBC) - build-depends: base, network, time, containers, convertible, postgresql-typed, HDBC, HUnit + build-depends: base, bytestring, network, time, containers, convertible, postgresql-typed, HDBC, HUnit else buildable: False From 83703384ffde8af4c3804ab172280093fa4ff564 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 22 May 2019 10:08:06 +0200 Subject: [PATCH 257/306] add nix expressions to build and test postgresql-typed (without TLS support ATM) --- .gitignore | 3 + nix/default.nix | 46 ++++++++++++ nix/fetch-nixpkgs.nix | 64 ++++++++++++++++ nix/utilities.nix | 165 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 278 insertions(+) create mode 100644 nix/default.nix create mode 100644 nix/fetch-nixpkgs.nix create mode 100644 nix/utilities.nix diff --git a/.gitignore b/.gitignore index 1b740bd..093c952 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,6 @@ /errcodes /errcodes.hi /errcodes.o +.ghc.environment.* +result* +dist* diff --git a/nix/default.nix b/nix/default.nix new file mode 100644 index 0000000..0e8fce8 --- /dev/null +++ b/nix/default.nix @@ -0,0 +1,46 @@ +{ pkgsPath ? null +, compiler ? "ghc864" +, postgresql ? "postgresql" +}: +let + # We pin the nixpkgs version here to ensure build reproducibility + pinnedNixpkgs = + import ./fetch-nixpkgs.nix + { # Latest HEAD of the release-19.03 branch as of 2019-05-22 + rev = "23a3bda4da71f6f6a7a248c593e14c838b75d40b"; + # This sha256 can be obtained with: + # `$ nix-prefetch-url https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz` + sha256 = "0v2r8xr3nvpc5xfqr4lr6i3mrcn6d5np1dr26q4iks5hj2zlxl97"; + # This one with: + # `$ nix-prefetch-url --unpack https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz` + outputSha256 = "1sgi9zi4h3mhvjq2wkzkvq2zdvh6p9qg19yv7c01sqin23s6yqr1"; + }; + + # Use pkgsPath if provided, else the pinned checkout + realPkgsPath = + if pkgsPath == null then pinnedNixpkgs else pkgsPath; + + # This overlay extends the nixpkgs' package set a custom haskell package set + # which includes postgresql-typed + overlay = self: super: + { + myHaskellPackages = self.haskell.packages."${compiler}".override (_ : { + overrides = haskellOverlay self; + }); + }; + + # This overlay extends a haskell package set with postgresql-typed + haskellOverlay = pkgs: self: super: + { + postgresql-typed = + let + src = pkgs.lib.cleanSource ../.; + drv = self.callCabal2nix "postgresql-typed" src {}; + in pkgs.haskell.lib.withPostgres pkgs.${postgresql} drv; + }; +in import realPkgsPath + { overlays = + [ overlay + (import ./utilities.nix) + ]; + } diff --git a/nix/fetch-nixpkgs.nix b/nix/fetch-nixpkgs.nix new file mode 100644 index 0000000..f9d9c29 --- /dev/null +++ b/nix/fetch-nixpkgs.nix @@ -0,0 +1,64 @@ +# Stolen from https://github.com/awakesecurity/gRPC-haskell/blob/master/fetch-nixpkgs.nix +# +# This function is used to pin nixpkgs to a specific version +# +{ rev # The Git revision of nixpkgs to fetch +, sha256 # The SHA256 of the downloaded data +, outputSha256 ? null # The SHA256 output hash +, system ? builtins.currentSystem # This is overridable if necessary +}: + +with { + ifThenElse = { bool, thenValue, elseValue }: ( + if bool then thenValue else elseValue); +}; + +ifThenElse { + bool = (0 <= builtins.compareVersions builtins.nixVersion "1.12"); + + # In Nix 1.12, we can just give a `sha256` to `builtins.fetchTarball`. + thenValue = ( + builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + + # builtins.fetchTarball does not need the sha256 hash of the + # packed and compressed tarball but it _does_ need the + # fixed-output sha256 hash. + sha256 = outputSha256; + }); + + # This hack should at least work for Nix 1.11 + elseValue = ( + (rec { + tarball = import { + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + inherit sha256; + }; + + builtin-paths = import ; + + script = builtins.toFile "nixpkgs-unpacker" '' + "$coreutils/mkdir" "$out" + cd "$out" + "$gzip" --decompress < "$tarball" | "$tar" -x --strip-components=1 + ''; + + nixpkgs = builtins.derivation ({ + name = "nixpkgs-${builtins.substring 0 6 rev}"; + + builder = builtins.storePath builtin-paths.shell; + + args = [ script ]; + + inherit tarball system; + + tar = builtins.storePath builtin-paths.tar; + gzip = builtins.storePath builtin-paths.gzip; + coreutils = builtins.storePath builtin-paths.coreutils; + } // (if null == outputSha256 then { } else { + outputHashMode = "recursive"; + outputHashAlgo = "sha256"; + outputHash = outputSha256; + })); + }).nixpkgs); +} diff --git a/nix/utilities.nix b/nix/utilities.nix new file mode 100644 index 0000000..5a468e6 --- /dev/null +++ b/nix/utilities.nix @@ -0,0 +1,165 @@ +let + # bash magic so we can set several traps without removin any existing one. + # Brought to you by https://stackoverflow.com/questions/16115144/save-and-restore-trap-state-easy-way-to-manage-multiple-handlers-for-traps/16115145 + trapMagic = '' + trap_stack_name() { + local sig=''${1//[^a-zA-Z0-9]/_} + echo "__trap_stack_$sig" + } + + extract_trap() { + echo ''${@:3:$(($#-3))} + } + + get_trap() { + eval echo $(extract_trap `trap -p $1`) + } + + trap_push() { + local new_trap=$1 + shift + local sigs=$* + for sig in $sigs; do + local stack_name=`trap_stack_name "$sig"` + local old_trap=$(get_trap $sig) + eval "''${stack_name}"'[''${#'"''${stack_name}"'[@]}]=$old_trap' + trap "''${new_trap}" "$sig" + done + } + + trap_prepend() { + local new_trap=$1 + shift + local sigs=$* + for sig in $sigs; do + if [[ -z $(get_trap $sig) ]]; then + trap_push "$new_trap" "$sig" + else + trap_push "$new_trap ; $(get_trap $sig)" "$sig" + fi + done + } + ''; + +in self: super: { + + lib = super.lib // + { + + # This function filters out stuff we don't want to consider part of the source + # when building with nix. Any change in one of these files would cause a + # re-build otherwise + cleanSource = + let + fldSourceFilter = name: type: let baseName = baseNameOf (toString name); in ! ( + # Filter out Subversion and CVS directories. + (type == "directory" && + ( baseName == ".git" || + baseName == ".circleci" || + baseName == ".nix-cache" || + baseName == ".cache" || + baseName == "nix" || + baseName == "dist" || + baseName == "dist-newstyle" + ) + ) || + # Filter out editor backup / swap files. + self.lib.hasSuffix "~" baseName || + builtins.match "^\\.sw[a-z]$" baseName != null || + builtins.match "^\\..*\\.sw[a-z]$" baseName != null || + + # filter out .ghc.environment + builtins.match "^\\.ghc.environment.*" baseName != null || + + # Filter out nix-build result symlinks + (type == "symlink" && self.lib.hasPrefix "result" baseName) || + + # Filter other random crap we have lying around for development + # which we don't need to properly build + (baseName == "develop.sh") || + (baseName == "Setup") || + (baseName == "Setup.o") || + (baseName == "Setup.hi") || + (baseName == ".bash_history") || + (baseName == "README.md") + ); + in builtins.filterSource fldSourceFilter; + }; + + haskell = super.haskell // { + lib = super.haskell.lib // { + # This function provides an ephemeral postgresql instance for development in + # the shellHook and at build/test time of the package it wraps + withPostgres = pg: drv: + let functions = '' + ${trapMagic} + + function initPG() { + ${super.lib.optionalString super.stdenv.isDarwin "export TMPDIR=/tmp"} + ${super.lib.optionalString (!super.stdenv.isDarwin) "export LANG=C.UTF-8"} + ${super.lib.optionalString (!super.stdenv.isDarwin) "export LC_ALL=C.UTF-8"} + ${super.lib.optionalString (!super.stdenv.isDarwin) "export LC_CTYPE=C.UTF-8"} + export TZ='UTC' + export PGHOST=$(mktemp -d) + export PGDATA=$PGHOST/db + export PGSOCK=$PGHOST/.s.PGSQL.5432 + export PGDATABASE=templatepg + export PGUSER=templatepg + # We set these environment variables so postgresql-typed knows how + # to connect to the database at compile-time to make sure all SQL + # queries are well typed and well formed + export TPG_SOCK=$PGSOCK + export TPG_DB=$PGDATABASE + export TPG_USER=$PGUSER + # + ${pg}/bin/initdb -E UTF8 $PGDATA + ${pg}/bin/postgres -D $PGDATA -k $PGHOST -c listen_addresses="" & + export pgpid=$! + echo -n "Waiting for database to start up..." + while [[ ! -e $PGSOCK ]]; do sleep 0.1; done + ${pg}/bin/createuser -h $PGHOST -U $(id -u --name) -s $PGUSER + ${pg}/bin/createdb -h $PGHOST -O $PGUSER $PGDATABASE + + echo "Created database PGDATABASE=$PGDATABASE at PGHOST=$PGHOST." + echo "Call killPG to stop and delete it. Call initPG to re-create it" + } + function killPG() { + echo "Killing postgres database at $PGHOST" + kill $pgpid || true + echo "Waiting for postgres database to die ..." + while [[ -e $PGSOCK ]]; do sleep 0.1; done + echo "Postgres is dead, deleting its data dir" + rm -rf $PGHOST + } + function reinitPG { + killPG && initPG + } + # export the functions so they're available in the development nix-shell + # so the database can be re-created easly + export -f initPG + export -f killPG + export -f reinitPG + + trap_prepend "killPG" EXIT + ''; + + in super.haskell.lib.overrideCabal drv (old: { + buildDepends = (old.buildDepends or []) ++ [ pg ]; + preBuild = '' + ${old.preBuild or ""} + ${functions} + initPG + ''; + shellHook = '' + ${old.shellHook or ""} + ${functions} + initPG + ''; + postInstall = '' + killPG + ${old.postInstall or ""} + ''; + }); + }; + }; +} From 341d933e7e275d81f3989a6622a6474e5860acba Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 22 May 2019 10:56:04 +0200 Subject: [PATCH 258/306] Added TLS configure flag to disable TLS support at build time --- .gitignore | 1 + Database/PostgreSQL/Typed/Protocol.hs | 70 ++++++++++++++++++++++++--- Database/PostgreSQL/Typed/TH.hs | 15 ++++-- nix/default.nix | 12 ++++- nix/release.nix | 11 +++++ postgresql-typed.cabal | 14 +++--- test/Connect.hs | 8 +++ 7 files changed, 112 insertions(+), 19 deletions(-) create mode 100644 nix/release.nix diff --git a/.gitignore b/.gitignore index 093c952..3fe63bb 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ .ghc.environment.* result* dist* +*.sw? diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index caed847..8820417 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -19,8 +19,10 @@ module Database.PostgreSQL.Typed.Protocol ( , defaultPGDatabase , PGConnection , PGError(..) +#ifdef HAVE_TLS , PGTlsMode(..) , PGTlsValidateMode (..) +#endif , pgErrorCode , pgConnectionDatabase , pgTypeEnv @@ -55,8 +57,10 @@ module Database.PostgreSQL.Typed.Protocol ( , PGNotification(..) , pgGetNotification , pgGetNotifications - -- * Helpers +#ifdef HAVE_TLS + -- * TLS Helpers , pgTlsValidate +#endif , pgSupportsTls ) where @@ -64,7 +68,10 @@ module Database.PostgreSQL.Typed.Protocol ( import Control.Applicative ((<$>), (<$)) #endif import Control.Arrow ((&&&), first, second) -import Control.Exception (Exception, throwIO, onException, finally, catch) +import Control.Exception (Exception, onException, finally, throwIO) +#ifdef HAVE_TLS +import Control.Exception (catch) +#endif import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef VERSION_cryptonite import qualified Crypto.Hash as Hash @@ -78,7 +85,9 @@ import Data.ByteString.Internal (w2c, createAndTrim) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.ByteString.Lazy.Internal (smallChunkSize) +#ifdef HAVE_TLS import Data.Default (def) +#endif import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef') import Data.Int (Int32, Int16) @@ -94,19 +103,25 @@ import Data.Typeable (Typeable) import Data.Word (Word) #endif import Data.Word (Word32, Word8) +#ifdef HAVE_TLS import Data.X509 (SignedCertificate, HashALG(HashSHA256)) import Data.X509.Memory (readSignedObjectFromMemory) import Data.X509.CertificateStore (makeCertificateStore) import qualified Data.X509.Validation +#endif +#ifndef mingw32_HOST_OS import Foreign.C.Error (eWOULDBLOCK, getErrno, errnoToIOError) import Foreign.C.Types (CChar(..), CInt(..), CSize(..)) import Foreign.Ptr (Ptr, castPtr) import GHC.IO.Exception (IOErrorType(InvalidArgument)) +#endif import qualified Network.Socket as Net import qualified Network.Socket.ByteString as NetBS import qualified Network.Socket.ByteString.Lazy as NetBSL +#ifdef HAVE_TLS import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS +#endif import System.IO (stderr, hPutStrLn) import System.IO.Error (IOError, mkIOError, eofErrorType, ioError, ioeSetErrorString) import System.IO.Unsafe (unsafeInterleaveIO) @@ -126,6 +141,7 @@ data PGState | StateClosed deriving (Show, Eq) +#ifdef HAVE_TLS data PGTlsValidateMode = TlsValidateFull -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQHN against the @@ -147,9 +163,16 @@ data PGTlsMode pgTlsValidate :: PGTlsValidateMode -> BSC.ByteString -> Either String PGTlsMode pgTlsValidate mode certPem = case readSignedObjectFromMemory certPem of - [x] -> Right (TlsValidate mode x) [] -> Left "Could not parse any certificate in PEM" - _ -> Left "Many certificates in PEM" + (x:_) -> Right (TlsValidate mode x) + +pgSupportsTls :: PGConnection -> Bool +pgSupportsTls PGConnection{connHandle=PGTlsContext _} = True +pgSupportsTls _ = False +#else +pgSupportsTls :: PGConnection -> Bool +pgSupportsTls _ = False +#endif -- |Information for how to connect to a database, to be passed to 'pgConnect'. data PGDatabase = PGDatabase @@ -159,12 +182,19 @@ data PGDatabase = PGDatabase , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) +#ifdef HAVE_TLS , pgDBTLS :: PGTlsMode -- ^ TLS mode +#endif } instance Eq PGDatabase where +#ifdef HAVE_TLS PGDatabase a1 n1 u1 p1 l1 _ _ s1 == PGDatabase a2 n2 u2 p2 l2 _ _ s2 = a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 == s2 +#else + PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ = + a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 +#endif newtype PGPreparedStatement = PGPreparedStatement Integer deriving (Eq, Show) @@ -174,29 +204,41 @@ preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n data PGHandle = PGSocket Net.Socket +#ifdef HAVE_TLS | PGTlsContext TLS.Context +#endif pgPutBuilder :: PGHandle -> B.Builder -> IO () pgPutBuilder (PGSocket s) b = NetBSL.sendAll s (B.toLazyByteString b) +#ifdef HAVE_TLS pgPutBuilder (PGTlsContext c) b = TLS.sendData c (B.toLazyByteString b) +#endif pgPut:: PGHandle -> BS.ByteString -> IO () pgPut (PGSocket s) bs = NetBS.sendAll s bs +#ifdef HAVE_TLS pgPut (PGTlsContext c) bs = TLS.sendData c (BSL.fromChunks [bs]) +#endif pgGetSome :: PGHandle -> Int -> IO BSC.ByteString pgGetSome (PGSocket s) count = NetBS.recv s count +#ifdef HAVE_TLS pgGetSome (PGTlsContext c) _ = TLS.recvData c +#endif pgCloseHandle :: PGHandle -> IO () pgCloseHandle (PGSocket s) = Net.close s +#ifdef HAVE_TLS pgCloseHandle (PGTlsContext c) = do TLS.bye c `catch` \(_ :: IOError) -> pure () TLS.contextClose c +#endif pgFlush :: PGConnection -> IO () pgFlush PGConnection{connHandle=PGSocket _} = pure () +#ifdef HAVE_TLS pgFlush PGConnection{connHandle=PGTlsContext c} = TLS.contextFlush c +#endif -- |An established connection to the PostgreSQL server. -- These objects are not thread-safe and must only be used for a single request at a time. @@ -215,10 +257,6 @@ data PGConnection = PGConnection , connNotifications :: IORef (Queue PGNotification) } -pgSupportsTls :: PGConnection -> Bool -pgSupportsTls PGConnection{connHandle=PGTlsContext _} = True -pgSupportsTls _ = False - data PGColDescription = PGColDescription { pgColName :: BS.ByteString , pgColTable :: !OID @@ -352,7 +390,9 @@ defaultPGDatabase = PGDatabase , pgDBParams = [] , pgDBDebug = False , pgDBLogMessage = defaultLogMessage +#ifdef HAVE_TLS , pgDBTLS = TlsDisabled +#endif } connDebug :: PGConnection -> Bool @@ -548,13 +588,20 @@ class Show m => RecvMsg m where -- |Process all pending messages data RecvNonBlock = RecvNonBlock deriving (Show) instance RecvMsg RecvNonBlock where +#ifndef mingw32_HOST_OS recvMsgData PGConnection{connHandle=PGSocket s} = do r <- recvNonBlock s smallChunkSize if BS.null r then return (Left RecvNonBlock) else return (Right r) +#else + recvMsgData PGConnection{connHandle=PGSocket _} = + throwIO (userError "Non-blocking recvMsgData is not supported on mingw32 ATM") +#endif +#ifdef HAVE_TLS recvMsgData PGConnection{connHandle=PGTlsContext _} = throwIO (userError "Non-blocking recvMsgData is not supported on TLS connections") +#endif -- |Wait for ReadyForQuery data RecvSync = RecvSync deriving (Show) @@ -684,6 +731,7 @@ pgConnect db = do msg _ (Left m) = fail $ "pgConnect: unexpected response: " ++ show m mkPGHandle :: PGDatabase -> Net.Socket -> IO PGHandle +#ifdef HAVE_TLS mkPGHandle db sock = case pgDBTLS db of TlsDisabled -> pure (PGSocket sock) @@ -728,6 +776,9 @@ mkPGHandle db sock = (\_ _ _ -> return TLS.ValidationCachePass) (\_ _ _ -> return ()) sslRequest = B.toLazyByteString (B.word32BE 8 <> B.word32BE 80877103) +#else +mkPGHandle _ sock = pure (PGSocket sock) +#endif -- |Disconnect cleanly from the PostgreSQL server. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' @@ -1070,6 +1121,8 @@ pgGetNotifications c = do queueToList (Queue e d) = d ++ reverse e +--TODO: Implement non-blocking recv on mingw32 +#ifndef mingw32_HOST_OS recvNonBlock :: Net.Socket -- ^ Connected socket -> Int -- ^ Maximum number of bytes to receive @@ -1100,3 +1153,4 @@ mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError foreign import ccall unsafe "recv" c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +#endif diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index dba3b8e..428a35e 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -24,10 +24,15 @@ import Control.Applicative ((<$>), (<$)) #endif import Control.Applicative ((<|>)) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) -import Control.Exception (onException, finally, throwIO) +import Control.Exception (onException, finally) +#ifdef HAVE_TLS +import Control.Exception (throwIO) +#endif import Control.Monad (liftM2) import qualified Data.ByteString as BS +#ifdef HAVE_TLS import qualified Data.ByteString.Char8 as BSC +#endif import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold @@ -58,7 +63,8 @@ getTPGDatabase = do #endif pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" debug <- isJust <$> lookupEnv "TPG_DEBUG" - tlsVerify <- isJust <$> lookupEnv "TPG_TLS" +#ifdef HAVE_TLS + tlsEnabled <- isJust <$> lookupEnv "TPG_TLS" tlsVerifyMode <- lookupEnv "TPG_TLS_MODE" >>= \modeStr -> case modeStr of Just "full" -> pure TlsValidateFull @@ -71,15 +77,18 @@ getTPGDatabase = do case pgTlsValidate tlsVerifyMode (BSC.pack certPem) of Right x -> pure x Left err -> throwIO (userError err) - Nothing | tlsVerify -> pure TlsNoValidate + Nothing | tlsEnabled -> pure TlsNoValidate Nothing -> pure TlsDisabled +#endif return $ defaultPGDatabase { pgDBAddr = either (Right . Net.SockAddrUnix) (Left . (,) host) port , pgDBName = BSU.fromString db , pgDBUser = BSU.fromString user , pgDBPass = BSU.fromString pass , pgDBDebug = debug +#ifdef HAVE_TLS , pgDBTLS = dbTls +#endif } {-# NOINLINE tpgState #-} diff --git a/nix/default.nix b/nix/default.nix index 0e8fce8..0497370 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -30,13 +30,21 @@ let }; # This overlay extends a haskell package set with postgresql-typed - haskellOverlay = pkgs: self: super: + haskellOverlay = pkgs: self: super: with pkgs.haskell.lib; { + # version without TLS postgresql-typed = let src = pkgs.lib.cleanSource ../.; drv = self.callCabal2nix "postgresql-typed" src {}; - in pkgs.haskell.lib.withPostgres pkgs.${postgresql} drv; + drvWithPostgres = withPostgres pkgs.${postgresql} drv; + in appendConfigureFlag drvWithPostgres "-f-TLS"; + + # version with TLS + postgresql-typed-tls = overrideCabal self.postgresql-typed (old: { + configureFlags = old.configureFlags or [] ++ ["-fTLS"]; + #checkPhase = "..."; #TODO + }); }; in import realPkgsPath { overlays = diff --git a/nix/release.nix b/nix/release.nix new file mode 100644 index 0000000..c5646ac --- /dev/null +++ b/nix/release.nix @@ -0,0 +1,11 @@ +{ pkgsPath ? null +, compiler ? "ghc864" +, postgresql ? "postgresql" +}@args: +let pkgs = import ./. args; +in +{ + inherit (pkgs.myHaskellPackages) + postgresql-typed + postgresql-typed-tls; +} diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 8086e67..4c20fb7 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -54,25 +54,24 @@ Flag aeson Flag HDBC Description: Provide an HDBC driver backend using the raw PostgreSQL protocol. +Flag TLS + Description: Enable TLS support + Default: True + Library Build-Depends: base >= 4.8 && < 5, array, binary, containers, - data-default, old-locale, time, - tls, bytestring >= 0.10.2, template-haskell, haskell-src-meta, network, attoparsec >= 0.12 && < 0.14, - utf8-string, - x509, - x509-store, - x509-validation + utf8-string Exposed-Modules: Database.PostgreSQL.Typed Database.PostgreSQL.Typed.Protocol @@ -109,6 +108,9 @@ Library Build-Depends: HDBC >= 2.2 Exposed-Modules: Database.PostgreSQL.Typed.HDBC + if flag(TLS) + Build-Depends: data-default, tls, x509, x509-store, x509-validation + Cpp-options: -DHAVE_TLS test-suite test type: exitcode-stdio-1.0 diff --git a/test/Connect.hs b/test/Connect.hs index 241fb82..0afdb2c 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -3,14 +3,18 @@ {-# LANGUAGE OverloadedStrings #-} module Connect where +#ifdef HAVE_TLS import Control.Exception (throwIO) import qualified Data.ByteString.Char8 as BSC +#endif import Data.Maybe (fromMaybe, isJust) import Database.PostgreSQL.Typed (PGDatabase (..), defaultPGDatabase) +#ifdef HAVE_TLS import Database.PostgreSQL.Typed.Protocol (PGTlsMode (..), PGTlsValidateMode (..), pgTlsValidate) +#endif import Network.Socket (SockAddr (SockAddrUnix)) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) @@ -22,6 +26,7 @@ db = unsafePerformIO $ do Nothing -> Right . SockAddrUnix . fromMaybe "/tmp/.s.PGSQL.5432" <$> lookupEnv "PGSOCK" Just port -> pure $ Left ("localhost", port) +#ifdef HAVE_TLS pgDBTLS <- do enabled <- isJust <$> lookupEnv "PGTLS" validateFull <- isJust <$> lookupEnv "PGTLS_VALIDATEFULL" @@ -32,13 +37,16 @@ db = unsafePerformIO $ do (True,True,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateFull cert (True,True,Nothing) -> throwIO $ userError "Need to pass the root certificate on the PGTLS_ROOTCERT environment variable to validate FQHN" (True,False,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateCA cert +#endif pgDBDebug <- isJust <$> lookupEnv "PG_DEBUG" pure $ defaultPGDatabase { pgDBName = "templatepg" , pgDBUser = "templatepg" , pgDBParams = [("TimeZone", "UTC")] , pgDBDebug +#ifdef HAVE_TLS , pgDBTLS +#endif #ifndef mingw32_HOST_OS , pgDBAddr #endif From 7738310350e1c5c44769a1e1a3b46bbd2cb43c5c Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 22 May 2019 12:34:47 +0200 Subject: [PATCH 259/306] added TLS tests and .travis.yml --- .travis.yml | 3 +++ nix/default.nix | 51 +++++++++++++++++++++++++++++++++++++----- nix/release.nix | 2 +- nix/utilities.nix | 5 ++--- postgresql-typed.cabal | 8 ++++++- 5 files changed, 58 insertions(+), 11 deletions(-) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..9debdb8 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,3 @@ +language: nix +script: + - nix-build nix/release.nix diff --git a/nix/default.nix b/nix/default.nix index 0497370..69361cd 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -32,18 +32,57 @@ let # This overlay extends a haskell package set with postgresql-typed haskellOverlay = pkgs: self: super: with pkgs.haskell.lib; { - # version without TLS + # version with TLS postgresql-typed = let src = pkgs.lib.cleanSource ../.; drv = self.callCabal2nix "postgresql-typed" src {}; drvWithPostgres = withPostgres pkgs.${postgresql} drv; - in appendConfigureFlag drvWithPostgres "-f-TLS"; + in pkgs.lib.overrideDerivation drvWithPostgres (old: { + checkPhase = '' + ${pkgs.openssl}/bin/openssl req -x509 -newkey rsa:2048 \ + -keyout $PGDATA/server.key \ + -out $PGDATA/server.crt \ + -days 1 -nodes \ + -subj "/C=US/ST=Somewhere/L=Earth/O=Test Network/OU=IT Department/CN=localhost" + chmod 0600 $PGDATA/server.key + echo 'ssl = on' >> $PGDATA/postgresql.conf - # version with TLS - postgresql-typed-tls = overrideCabal self.postgresql-typed (old: { - configureFlags = old.configureFlags or [] ++ ["-fTLS"]; - #checkPhase = "..."; #TODO + # disallow non-ssl connections to make sure we're doing TLS + echo 'hostssl templatepg templatepg all trust' > $PGDATA/pg_hba.conf + echo 'hostnossl all all all reject' >> $PGDATA/pg_hba.conf + + pg_ctl restart + + export PGTLS=1 + export PGPORT=5432 + + # First test TlsNoValidate + ./Setup test + + # Test TlsValidateCA + export PGTLS_ROOTCERT=$(cat $PGDATA/server.crt) + ./Setup test + + # Test TlsValidateFull + export PGTLS_VALIDATEFULL=1 + ./Setup test + + # Test that cert validation fails with invalid cert + ${pkgs.openssl}/bin/openssl req -x509 -newkey rsa:2048 \ + -keyout other.key \ + -out other.crt \ + -days 1 -nodes \ + -subj "/C=US/ST=Somewhere/L=Earth/O=Test Network/OU=IT Department/CN=localhost" + export PGTLS_ROOTCERT=$(cat other.crt) + ./Setup test && false || true + ''; + }); + + # version without TLS + postgresql-typed-notls = pkgs.lib.overrideDerivation self.postgresql-typed (old: { + configureFlags = old.configureFlags or [] ++ ["-f-TLS"]; + checkPhase = "./Setup test"; }); }; in import realPkgsPath diff --git a/nix/release.nix b/nix/release.nix index c5646ac..8e4747c 100644 --- a/nix/release.nix +++ b/nix/release.nix @@ -7,5 +7,5 @@ in { inherit (pkgs.myHaskellPackages) postgresql-typed - postgresql-typed-tls; + postgresql-typed-notls; } diff --git a/nix/utilities.nix b/nix/utilities.nix index 5a468e6..752e42e 100644 --- a/nix/utilities.nix +++ b/nix/utilities.nix @@ -113,8 +113,7 @@ in self: super: { export TPG_USER=$PGUSER # ${pg}/bin/initdb -E UTF8 $PGDATA - ${pg}/bin/postgres -D $PGDATA -k $PGHOST -c listen_addresses="" & - export pgpid=$! + ${pg}/bin/postgres -D $PGDATA -k $PGHOST & echo -n "Waiting for database to start up..." while [[ ! -e $PGSOCK ]]; do sleep 0.1; done ${pg}/bin/createuser -h $PGHOST -U $(id -u --name) -s $PGUSER @@ -125,7 +124,7 @@ in self: super: { } function killPG() { echo "Killing postgres database at $PGHOST" - kill $pgpid || true + pg_ctl stop || true echo "Waiting for postgres database to die ..." while [[ -e $PGSOCK ]]; do sleep 0.1; done echo "Postgres is dead, deleting its data dir" diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 4c20fb7..dfb01e9 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -110,7 +110,7 @@ Library Database.PostgreSQL.Typed.HDBC if flag(TLS) Build-Depends: data-default, tls, x509, x509-store, x509-validation - Cpp-options: -DHAVE_TLS + cpp-options: -DHAVE_TLS test-suite test type: exitcode-stdio-1.0 @@ -120,6 +120,8 @@ test-suite test Extensions: TemplateHaskell, QuasiQuotes build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck GHC-Options: -Wall + if flag(TLS) + cpp-options: -DHAVE_TLS test-suite hdbc type: exitcode-stdio-1.0 @@ -138,6 +140,8 @@ test-suite hdbc build-depends: base, bytestring, network, time, containers, convertible, postgresql-typed, HDBC, HUnit else buildable: False + if flag(TLS) + cpp-options: -DHAVE_TLS benchmark bench type: exitcode-stdio-1.0 @@ -151,3 +155,5 @@ benchmark bench network, criterion, postgresql-typed + if flag(TLS) + cpp-options: -DHAVE_TLS From cd42044df789cab728a5312d34c4e4954e273c98 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 22 May 2019 12:51:14 +0200 Subject: [PATCH 260/306] change port to a avoid conflicts on travis --- nix/default.nix | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/nix/default.nix b/nix/default.nix index 69361cd..f028df6 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -47,6 +47,8 @@ let -subj "/C=US/ST=Somewhere/L=Earth/O=Test Network/OU=IT Department/CN=localhost" chmod 0600 $PGDATA/server.key echo 'ssl = on' >> $PGDATA/postgresql.conf + # avoid conflicts on travis and elsewhere + echo 'port = 5433' >> $PGDATA/postgresql.conf # disallow non-ssl connections to make sure we're doing TLS echo 'hostssl templatepg templatepg all trust' > $PGDATA/pg_hba.conf @@ -55,7 +57,7 @@ let pg_ctl restart export PGTLS=1 - export PGPORT=5432 + export PGPORT=5433 # First test TlsNoValidate ./Setup test From 44bf9390910dedd55561f0fca0b1c742e0df9221 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Wed, 22 May 2019 13:01:03 +0200 Subject: [PATCH 261/306] avoid port conflicts for real --- nix/default.nix | 3 --- nix/utilities.nix | 5 ++++- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/nix/default.nix b/nix/default.nix index f028df6..ea1953c 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -47,8 +47,6 @@ let -subj "/C=US/ST=Somewhere/L=Earth/O=Test Network/OU=IT Department/CN=localhost" chmod 0600 $PGDATA/server.key echo 'ssl = on' >> $PGDATA/postgresql.conf - # avoid conflicts on travis and elsewhere - echo 'port = 5433' >> $PGDATA/postgresql.conf # disallow non-ssl connections to make sure we're doing TLS echo 'hostssl templatepg templatepg all trust' > $PGDATA/pg_hba.conf @@ -57,7 +55,6 @@ let pg_ctl restart export PGTLS=1 - export PGPORT=5433 # First test TlsNoValidate ./Setup test diff --git a/nix/utilities.nix b/nix/utilities.nix index 752e42e..15c2dcb 100644 --- a/nix/utilities.nix +++ b/nix/utilities.nix @@ -102,7 +102,8 @@ in self: super: { export TZ='UTC' export PGHOST=$(mktemp -d) export PGDATA=$PGHOST/db - export PGSOCK=$PGHOST/.s.PGSQL.5432 + export PGPORT=5433 + export PGSOCK=$PGHOST/.s.PGSQL.$PGPORT export PGDATABASE=templatepg export PGUSER=templatepg # We set these environment variables so postgresql-typed knows how @@ -113,6 +114,8 @@ in self: super: { export TPG_USER=$PGUSER # ${pg}/bin/initdb -E UTF8 $PGDATA + # avoid conflicts on travis and elsewhere + echo "port = $PGPORT" >> $PGDATA/postgresql.conf ${pg}/bin/postgres -D $PGDATA -k $PGHOST & echo -n "Waiting for database to start up..." while [[ ! -e $PGSOCK ]]; do sleep 0.1; done From ba59db686d9c4a21f3c2ce5021af8444afebe88e Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 29 May 2019 05:42:13 -0400 Subject: [PATCH 262/306] Set TCP_NODELAY on tcp connections --- Database/PostgreSQL/Typed/Protocol.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 8820417..ba9882f 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -678,6 +678,7 @@ pgConnect db = do _ -> Net.AF_UNSPEC }) $ pgDBAddr db sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) + unless (Net.addrFamily addr == Net.AF_UNIX) $ Net.setSocketOption sock Net.NoDelay 1 Net.connect sock $ Net.addrAddress addr pgHandle <- mkPGHandle db sock let c = PGConnection From da3e7f7fea22c351a76572d65e46e4c4aa6ac577 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 29 May 2019 05:56:26 -0400 Subject: [PATCH 263/306] Add timestamps to debug messages Also bump stackage to latest --- Database/PostgreSQL/Typed/Protocol.hs | 11 +++++++---- stack.yaml | 2 +- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 684ce40..045f7f6 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -81,6 +81,7 @@ import Data.Monoid ((<>)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif +import Data.Time.Clock (getCurrentTime) import Data.Tuple (swap) import Data.Typeable (Typeable) #if !MIN_VERSION_base(4,8,0) @@ -282,8 +283,10 @@ defaultPGDatabase = PGDatabase , pgDBLogMessage = defaultLogMessage } -connDebug :: PGConnection -> Bool -connDebug = pgDBDebug . connDatabase +connDebugMsg :: PGConnection -> String -> IO () +connDebugMsg c msg = when (pgDBDebug $ connDatabase c) $ do + t <- getCurrentTime + hPutStrLn stderr $ show t ++ msg connLogMessage :: PGConnection -> MessageFields -> IO () connLogMessage = pgDBLogMessage . connDatabase @@ -358,7 +361,7 @@ messageBody Terminate = (Just 'X', mempty) pgSend :: PGConnection -> PGFrontendMessage -> IO () pgSend c@PGConnection{ connHandle = h, connState = sr } msg = do modifyIORef' sr $ state msg - when (connDebug c) $ putStrLn $ "> " ++ show msg + connDebugMsg c $ "> " ++ 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 @@ -513,7 +516,7 @@ pgRecv c@PGConnection{ connInput = dr, connState = sr } = -- read and parse rcv (G.Done b _ m) = do - when (connDebug c) $ putStrLn $ "< " ++ show m + connDebugMsg c $ "< " ++ show m got (new b) m rcv (G.Fail _ _ r) = next (new BS.empty) >> fail r -- not clear how can recover rcv d@(G.Partial r) = recvMsgData c `onException` next d >>= diff --git a/stack.yaml b/stack.yaml index 03be2df..413a93e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-13.3 +resolver: lts-13.23 packages: - '.' From 2df7608cd073a127d36ee8169835ec0b299abb12 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 29 May 2019 15:32:04 -0400 Subject: [PATCH 264/306] Autoupdate ErrCodes.hs from postgresqly 11.3 --- Database/PostgreSQL/Typed/ErrCodes.hs | 33 ++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/ErrCodes.hs b/Database/PostgreSQL/Typed/ErrCodes.hs index 675a6de..0f5cf95 100644 --- a/Database/PostgreSQL/Typed/ErrCodes.hs +++ b/Database/PostgreSQL/Typed/ErrCodes.hs @@ -1,4 +1,4 @@ --- Automatically generated from /src/postgresql-9.5.3/src/src/backend/utils/errcodes.txt using errcodes.hs 2016-09-28 20:17:05.706135604 UTC. +-- Automatically generated from /src/postgresql-11.3/src/src/backend/utils/errcodes.txt using errcodes 2019-05-29 19:31:19.442545643 UTC. {-# LANGUAGE OverloadedStrings #-} -- |PostgreSQL error codes. module Database.PostgreSQL.Typed.ErrCodes (names @@ -72,6 +72,7 @@ module Database.PostgreSQL.Typed.ErrCodes (names , nonstandard_use_of_escape_character , invalid_indicator_parameter_value , invalid_parameter_value + , invalid_preceding_or_following_size , invalid_regular_expression , invalid_row_count_in_limit_clause , invalid_row_count_in_result_offset_clause @@ -83,6 +84,7 @@ module Database.PostgreSQL.Typed.ErrCodes (names , null_value_not_allowed , null_value_no_indicator_parameter , numeric_value_out_of_range + , sequence_generator_limit_exceeded , string_data_length_mismatch , string_data_right_truncation , substring_error @@ -121,6 +123,7 @@ module Database.PostgreSQL.Typed.ErrCodes (names , schema_and_data_statement_mixing_not_supported , no_active_sql_transaction , in_failed_sql_transaction + , idle_in_transaction_session_timeout -- * Class 26 - Invalid SQL Statement Name , invalid_sql_statement_name -- * Class 27 - Triggered Data Change Violation @@ -184,6 +187,7 @@ module Database.PostgreSQL.Typed.ErrCodes (names , collation_mismatch , indeterminate_collation , wrong_object_type + , generated_always , undefined_column , _UNDEFINED_CURSOR , _UNDEFINED_DATABASE @@ -245,6 +249,8 @@ module Database.PostgreSQL.Typed.ErrCodes (names , io_error , undefined_file , duplicate_file + -- * Class 72 - Snapshot Failure + , snapshot_too_old -- * Class F0 - Configuration File Error , config_file_error , lock_file_exists @@ -511,6 +517,10 @@ invalid_indicator_parameter_value = "22010" invalid_parameter_value :: ByteString invalid_parameter_value = "22023" +-- |@INVALID_PRECEDING_OR_FOLLOWING_SIZE@: 22013 (Error) +invalid_preceding_or_following_size :: ByteString +invalid_preceding_or_following_size = "22013" + -- |@INVALID_REGULAR_EXPRESSION@: 2201B (Error) invalid_regular_expression :: ByteString invalid_regular_expression = "2201B" @@ -555,6 +565,10 @@ null_value_no_indicator_parameter = "22002" numeric_value_out_of_range :: ByteString numeric_value_out_of_range = "22003" +-- |@SEQUENCE_GENERATOR_LIMIT_EXCEEDED@: 2200H (Error) +sequence_generator_limit_exceeded :: ByteString +sequence_generator_limit_exceeded = "2200H" + -- |@STRING_DATA_LENGTH_MISMATCH@: 22026 (Error) string_data_length_mismatch :: ByteString string_data_length_mismatch = "22026" @@ -695,6 +709,10 @@ no_active_sql_transaction = "25P01" in_failed_sql_transaction :: ByteString in_failed_sql_transaction = "25P02" +-- |@IDLE_IN_TRANSACTION_SESSION_TIMEOUT@: 25P03 (Error) +idle_in_transaction_session_timeout :: ByteString +idle_in_transaction_session_timeout = "25P03" + -- |@INVALID_SQL_STATEMENT_NAME@: 26000 (Error) invalid_sql_statement_name :: ByteString invalid_sql_statement_name = "26000" @@ -891,6 +909,10 @@ indeterminate_collation = "42P22" wrong_object_type :: ByteString wrong_object_type = "42809" +-- |@GENERATED_ALWAYS@: 428C9 (Error) +generated_always :: ByteString +generated_always = "428C9" + -- |@UNDEFINED_COLUMN@: 42703 (Error) undefined_column :: ByteString undefined_column = "42703" @@ -1111,6 +1133,10 @@ undefined_file = "58P01" duplicate_file :: ByteString duplicate_file = "58P02" +-- |@SNAPSHOT_TOO_OLD@: 72000 (Error) +snapshot_too_old :: ByteString +snapshot_too_old = "72000" + -- |@CONFIG_FILE_ERROR@: F0000 (Error) config_file_error :: ByteString config_file_error = "F0000" @@ -1308,6 +1334,7 @@ names = fromDistinctAscList ,(invalid_escape_octet,"invalid_escape_octet") ,(zero_length_character_string,"zero_length_character_string") ,(most_specific_type_mismatch,"most_specific_type_mismatch") + ,(sequence_generator_limit_exceeded,"sequence_generator_limit_exceeded") ,(not_an_xml_document,"not_an_xml_document") ,(invalid_xml_document,"invalid_xml_document") ,(invalid_xml_content,"invalid_xml_content") @@ -1316,6 +1343,7 @@ names = fromDistinctAscList ,(invalid_indicator_parameter_value,"invalid_indicator_parameter_value") ,(substring_error,"substring_error") ,(division_by_zero,"division_by_zero") + ,(invalid_preceding_or_following_size,"invalid_preceding_or_following_size") ,(invalid_argument_for_ntile_function,"invalid_argument_for_ntile_function") ,(interval_field_overflow,"interval_field_overflow") ,(invalid_argument_for_nth_value_function,"invalid_argument_for_nth_value_function") @@ -1363,6 +1391,7 @@ names = fromDistinctAscList ,(held_cursor_requires_same_isolation_level,"held_cursor_requires_same_isolation_level") ,(no_active_sql_transaction,"no_active_sql_transaction") ,(in_failed_sql_transaction,"in_failed_sql_transaction") + ,(idle_in_transaction_session_timeout,"idle_in_transaction_session_timeout") ,(invalid_sql_statement_name,"invalid_sql_statement_name") ,(_UNDEFINED_PSTATEMENT,"UNDEFINED_PSTATEMENT") ,(triggered_data_change_violation,"triggered_data_change_violation") @@ -1420,6 +1449,7 @@ names = fromDistinctAscList ,(invalid_foreign_key,"invalid_foreign_key") ,(cannot_coerce,"cannot_coerce") ,(undefined_function,"undefined_function") + ,(generated_always,"generated_always") ,(reserved_name,"reserved_name") ,(undefined_table,"undefined_table") ,(undefined_parameter,"undefined_parameter") @@ -1467,6 +1497,7 @@ names = fromDistinctAscList ,(io_error,"io_error") ,(undefined_file,"undefined_file") ,(duplicate_file,"duplicate_file") + ,(snapshot_too_old,"snapshot_too_old") ,(config_file_error,"config_file_error") ,(lock_file_exists,"lock_file_exists") ,(fdw_error,"fdw_error") From 209acb70606478d766cf634ce371e14807395937 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 3 Jun 2019 23:12:41 -0400 Subject: [PATCH 265/306] Minor cleanup for windows test connect, gitignore --- .gitignore | 7 +++---- test/Connect.hs | 8 ++++++-- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/.gitignore b/.gitignore index 3fe63bb..9ef9cf4 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,6 @@ /errcodes /errcodes.hi /errcodes.o -.ghc.environment.* -result* -dist* -*.sw? +/.ghc.environment.* +/result* +/dist* diff --git a/test/Connect.hs b/test/Connect.hs index 0afdb2c..d93fe9f 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -24,7 +24,11 @@ db = unsafePerformIO $ do mPort <- lookupEnv "PGPORT" pgDBAddr <- case mPort of Nothing -> +#ifndef mingw32_HOST_OS Right . SockAddrUnix . fromMaybe "/tmp/.s.PGSQL.5432" <$> lookupEnv "PGSOCK" +#else + pure $ pgDBAddr defaultPGDatabase +#endif Just port -> pure $ Left ("localhost", port) #ifdef HAVE_TLS pgDBTLS <- do @@ -37,6 +41,7 @@ db = unsafePerformIO $ do (True,True,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateFull cert (True,True,Nothing) -> throwIO $ userError "Need to pass the root certificate on the PGTLS_ROOTCERT environment variable to validate FQHN" (True,False,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateCA cert + pgDBPass <- maybe BSC.empty BSC.pack <$> lookupEnv "PG_PASS" #endif pgDBDebug <- isJust <$> lookupEnv "PG_DEBUG" pure $ defaultPGDatabase @@ -47,8 +52,7 @@ db = unsafePerformIO $ do #ifdef HAVE_TLS , pgDBTLS #endif -#ifndef mingw32_HOST_OS , pgDBAddr -#endif + , pgDBPass } {-# NOINLINE db #-} From 0ea3aa98f6f4a015d0a4684e7af1c37c6dc4e8bc Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 3 Jun 2019 23:15:07 -0400 Subject: [PATCH 266/306] Bump version to 0.6 --- postgresql-typed.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index dfb01e9..fdb6d70 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,9 +1,9 @@ Name: postgresql-typed -Version: 0.5.3.0 +Version: 0.6 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING -Copyright: 2010-2013 Chris Forno, 2014-2017 Dylan Simon +Copyright: 2010-2013 Chris Forno, 2014-2019 Dylan Simon Author: Dylan Simon Maintainer: Dylan Simon Stability: provisional From 165493b0da2e555bbb929d577ec00348f52ca805 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 3 Jun 2019 23:37:37 -0400 Subject: [PATCH 267/306] Fix pgDBPass setting in non-tls test connect --- test/Connect.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Connect.hs b/test/Connect.hs index d93fe9f..d9494ad 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -41,8 +41,8 @@ db = unsafePerformIO $ do (True,True,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateFull cert (True,True,Nothing) -> throwIO $ userError "Need to pass the root certificate on the PGTLS_ROOTCERT environment variable to validate FQHN" (True,False,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateCA cert - pgDBPass <- maybe BSC.empty BSC.pack <$> lookupEnv "PG_PASS" #endif + pgDBPass <- maybe BSC.empty BSC.pack <$> lookupEnv "PG_PASS" pgDBDebug <- isJust <$> lookupEnv "PG_DEBUG" pure $ defaultPGDatabase { pgDBName = "templatepg" From e0903ae6bdb397e9b2ebffe4a7fa1d5ae11f1141 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 3 Jun 2019 23:47:44 -0400 Subject: [PATCH 268/306] Fix import placement for non-tls test connect --- test/Connect.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Connect.hs b/test/Connect.hs index d9494ad..ca4cada 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -5,8 +5,8 @@ module Connect where #ifdef HAVE_TLS import Control.Exception (throwIO) -import qualified Data.ByteString.Char8 as BSC #endif +import qualified Data.ByteString.Char8 as BSC import Data.Maybe (fromMaybe, isJust) import Database.PostgreSQL.Typed (PGDatabase (..), defaultPGDatabase) From 40c0a2691f92797fdb8f90c4e602008ee07fe033 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 25 Jun 2019 15:47:24 -0400 Subject: [PATCH 269/306] Make TLS flag more like other flags --- Database/PostgreSQL/Typed/Protocol.hs | 36 +++++++++++++-------------- Database/PostgreSQL/Typed/TH.hs | 8 +++--- nix/default.nix | 2 +- postgresql-typed.cabal | 19 +++++++------- stack.yaml | 2 +- test/Connect.hs | 8 +++--- 6 files changed, 37 insertions(+), 38 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 8762ab6..29216b7 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -19,7 +19,7 @@ module Database.PostgreSQL.Typed.Protocol ( , defaultPGDatabase , PGConnection , PGError(..) -#ifdef HAVE_TLS +#ifdef VERSION_tls , PGTlsMode(..) , PGTlsValidateMode (..) #endif @@ -57,7 +57,7 @@ module Database.PostgreSQL.Typed.Protocol ( , PGNotification(..) , pgGetNotification , pgGetNotifications -#ifdef HAVE_TLS +#ifdef VERSION_tls -- * TLS Helpers , pgTlsValidate #endif @@ -69,7 +69,7 @@ import Control.Applicative ((<$>), (<$)) #endif import Control.Arrow ((&&&), first, second) import Control.Exception (Exception, onException, finally, throwIO) -#ifdef HAVE_TLS +#ifdef VERSION_tls import Control.Exception (catch) #endif import Control.Monad (void, liftM2, replicateM, when, unless) @@ -85,7 +85,7 @@ import Data.ByteString.Internal (w2c, createAndTrim) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.ByteString.Lazy.Internal (smallChunkSize) -#ifdef HAVE_TLS +#ifdef VERSION_tls import Data.Default (def) #endif import qualified Data.Foldable as Fold @@ -104,7 +104,7 @@ import Data.Typeable (Typeable) import Data.Word (Word) #endif import Data.Word (Word32, Word8) -#ifdef HAVE_TLS +#ifdef VERSION_tls import Data.X509 (SignedCertificate, HashALG(HashSHA256)) import Data.X509.Memory (readSignedObjectFromMemory) import Data.X509.CertificateStore (makeCertificateStore) @@ -119,7 +119,7 @@ import GHC.IO.Exception (IOErrorType(InvalidArgument)) import qualified Network.Socket as Net import qualified Network.Socket.ByteString as NetBS import qualified Network.Socket.ByteString.Lazy as NetBSL -#ifdef HAVE_TLS +#ifdef VERSION_tls import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS #endif @@ -142,7 +142,7 @@ data PGState | StateClosed deriving (Show, Eq) -#ifdef HAVE_TLS +#ifdef VERSION_tls data PGTlsValidateMode = TlsValidateFull -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQHN against the @@ -183,13 +183,13 @@ data PGDatabase = PGDatabase , pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC")) , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) -#ifdef HAVE_TLS +#ifdef VERSION_tls , pgDBTLS :: PGTlsMode -- ^ TLS mode #endif } instance Eq PGDatabase where -#ifdef HAVE_TLS +#ifdef VERSION_tls PGDatabase a1 n1 u1 p1 l1 _ _ s1 == PGDatabase a2 n2 u2 p2 l2 _ _ s2 = a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 == s2 #else @@ -205,31 +205,31 @@ preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n data PGHandle = PGSocket Net.Socket -#ifdef HAVE_TLS +#ifdef VERSION_tls | PGTlsContext TLS.Context #endif pgPutBuilder :: PGHandle -> B.Builder -> IO () pgPutBuilder (PGSocket s) b = NetBSL.sendAll s (B.toLazyByteString b) -#ifdef HAVE_TLS +#ifdef VERSION_tls pgPutBuilder (PGTlsContext c) b = TLS.sendData c (B.toLazyByteString b) #endif pgPut:: PGHandle -> BS.ByteString -> IO () pgPut (PGSocket s) bs = NetBS.sendAll s bs -#ifdef HAVE_TLS +#ifdef VERSION_tls pgPut (PGTlsContext c) bs = TLS.sendData c (BSL.fromChunks [bs]) #endif pgGetSome :: PGHandle -> Int -> IO BSC.ByteString pgGetSome (PGSocket s) count = NetBS.recv s count -#ifdef HAVE_TLS +#ifdef VERSION_tls pgGetSome (PGTlsContext c) _ = TLS.recvData c #endif pgCloseHandle :: PGHandle -> IO () pgCloseHandle (PGSocket s) = Net.close s -#ifdef HAVE_TLS +#ifdef VERSION_tls pgCloseHandle (PGTlsContext c) = do TLS.bye c `catch` \(_ :: IOError) -> pure () TLS.contextClose c @@ -237,7 +237,7 @@ pgCloseHandle (PGTlsContext c) = do pgFlush :: PGConnection -> IO () pgFlush PGConnection{connHandle=PGSocket _} = pure () -#ifdef HAVE_TLS +#ifdef VERSION_tls pgFlush PGConnection{connHandle=PGTlsContext c} = TLS.contextFlush c #endif @@ -391,7 +391,7 @@ defaultPGDatabase = PGDatabase , pgDBParams = [] , pgDBDebug = False , pgDBLogMessage = defaultLogMessage -#ifdef HAVE_TLS +#ifdef VERSION_tls , pgDBTLS = TlsDisabled #endif } @@ -601,7 +601,7 @@ instance RecvMsg RecvNonBlock where recvMsgData PGConnection{connHandle=PGSocket _} = throwIO (userError "Non-blocking recvMsgData is not supported on mingw32 ATM") #endif -#ifdef HAVE_TLS +#ifdef VERSION_tls recvMsgData PGConnection{connHandle=PGTlsContext _} = throwIO (userError "Non-blocking recvMsgData is not supported on TLS connections") #endif @@ -735,7 +735,7 @@ pgConnect db = do msg _ (Left m) = fail $ "pgConnect: unexpected response: " ++ show m mkPGHandle :: PGDatabase -> Net.Socket -> IO PGHandle -#ifdef HAVE_TLS +#ifdef VERSION_tls mkPGHandle db sock = case pgDBTLS db of TlsDisabled -> pure (PGSocket sock) diff --git a/Database/PostgreSQL/Typed/TH.hs b/Database/PostgreSQL/Typed/TH.hs index 428a35e..8dd9555 100644 --- a/Database/PostgreSQL/Typed/TH.hs +++ b/Database/PostgreSQL/Typed/TH.hs @@ -25,12 +25,12 @@ import Control.Applicative ((<$>), (<$)) import Control.Applicative ((<|>)) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar) import Control.Exception (onException, finally) -#ifdef HAVE_TLS +#ifdef VERSION_tls import Control.Exception (throwIO) #endif import Control.Monad (liftM2) import qualified Data.ByteString as BS -#ifdef HAVE_TLS +#ifdef VERSION_tls import qualified Data.ByteString.Char8 as BSC #endif import qualified Data.ByteString.Lazy as BSL @@ -63,7 +63,7 @@ getTPGDatabase = do #endif pass <- fromMaybe "" <$> lookupEnv "TPG_PASS" debug <- isJust <$> lookupEnv "TPG_DEBUG" -#ifdef HAVE_TLS +#ifdef VERSION_tls tlsEnabled <- isJust <$> lookupEnv "TPG_TLS" tlsVerifyMode <- lookupEnv "TPG_TLS_MODE" >>= \modeStr -> case modeStr of @@ -86,7 +86,7 @@ getTPGDatabase = do , pgDBUser = BSU.fromString user , pgDBPass = BSU.fromString pass , pgDBDebug = debug -#ifdef HAVE_TLS +#ifdef VERSION_tls , pgDBTLS = dbTls #endif } diff --git a/nix/default.nix b/nix/default.nix index ea1953c..466fd6d 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -80,7 +80,7 @@ let # version without TLS postgresql-typed-notls = pkgs.lib.overrideDerivation self.postgresql-typed (old: { - configureFlags = old.configureFlags or [] ++ ["-f-TLS"]; + configureFlags = old.configureFlags or [] ++ ["-f-tls"]; checkPhase = "./Setup test"; }); }; diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index fdb6d70..7a5fd39 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -54,8 +54,8 @@ Flag aeson Flag HDBC Description: Provide an HDBC driver backend using the raw PostgreSQL protocol. -Flag TLS - Description: Enable TLS support +Flag tls + Description: Enable TLS (SSL) support in PostgreSQL server connections. Default: True Library @@ -108,9 +108,8 @@ Library Build-Depends: HDBC >= 2.2 Exposed-Modules: Database.PostgreSQL.Typed.HDBC - if flag(TLS) + if flag(tls) Build-Depends: data-default, tls, x509, x509-store, x509-validation - cpp-options: -DHAVE_TLS test-suite test type: exitcode-stdio-1.0 @@ -120,8 +119,8 @@ test-suite test Extensions: TemplateHaskell, QuasiQuotes build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck GHC-Options: -Wall - if flag(TLS) - cpp-options: -DHAVE_TLS + if flag(tls) + Build-Depends: tls test-suite hdbc type: exitcode-stdio-1.0 @@ -140,8 +139,8 @@ test-suite hdbc build-depends: base, bytestring, network, time, containers, convertible, postgresql-typed, HDBC, HUnit else buildable: False - if flag(TLS) - cpp-options: -DHAVE_TLS + if flag(tls) + Build-Depends: tls benchmark bench type: exitcode-stdio-1.0 @@ -155,5 +154,5 @@ benchmark bench network, criterion, postgresql-typed - if flag(TLS) - cpp-options: -DHAVE_TLS + if flag(tls) + Build-Depends: tls diff --git a/stack.yaml b/stack.yaml index 413a93e..f1f8287 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-13.23 +resolver: lts-13.26 packages: - '.' diff --git a/test/Connect.hs b/test/Connect.hs index ca4cada..c93d095 100644 --- a/test/Connect.hs +++ b/test/Connect.hs @@ -3,14 +3,14 @@ {-# LANGUAGE OverloadedStrings #-} module Connect where -#ifdef HAVE_TLS +#ifdef VERSION_tls import Control.Exception (throwIO) #endif import qualified Data.ByteString.Char8 as BSC import Data.Maybe (fromMaybe, isJust) import Database.PostgreSQL.Typed (PGDatabase (..), defaultPGDatabase) -#ifdef HAVE_TLS +#ifdef VERSION_tls import Database.PostgreSQL.Typed.Protocol (PGTlsMode (..), PGTlsValidateMode (..), pgTlsValidate) @@ -30,7 +30,7 @@ db = unsafePerformIO $ do pure $ pgDBAddr defaultPGDatabase #endif Just port -> pure $ Left ("localhost", port) -#ifdef HAVE_TLS +#ifdef VERSION_tls pgDBTLS <- do enabled <- isJust <$> lookupEnv "PGTLS" validateFull <- isJust <$> lookupEnv "PGTLS_VALIDATEFULL" @@ -49,7 +49,7 @@ db = unsafePerformIO $ do , pgDBUser = "templatepg" , pgDBParams = [("TimeZone", "UTC")] , pgDBDebug -#ifdef HAVE_TLS +#ifdef VERSION_tls , pgDBTLS #endif , pgDBAddr From 39c02adb68e7bc9d1a550b1e6f2f770b62a9430a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 25 Jun 2019 15:51:24 -0400 Subject: [PATCH 270/306] Update README as markdown and add travis image --- README | 3 --- README.md | 6 ++++++ 2 files changed, 6 insertions(+), 3 deletions(-) delete mode 100644 README create mode 100644 README.md diff --git a/README b/README deleted file mode 100644 index a9ab781..0000000 --- a/README +++ /dev/null @@ -1,3 +0,0 @@ -A PostgreSQL interface that provides type-safety through compile-time database -access. See the Haddock documentation in Database.PostgreSQL.Typed or the test -cases for simple examples. diff --git a/README.md b/README.md new file mode 100644 index 0000000..5c12911 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# Haskell PostgreSQL-typed + +A Haskell PostgreSQL interface that provides type-safety through compile-time (template Haskell) database access. +See the [Haddock](http://hackage.haskell.org/package/postgresql-typed) documentation in [Database.PostgreSQL.Typed](http://hackage.haskell.org/package/postgresql-typed/docs/Database-PostgreSQL-Typed.html) or the [test cases](test/Main.hs) for simple examples. + +[![Build Status](https://travis-ci.org/dylex/postgresql-typed.svg?branch=master)](https://travis-ci.org/dylex/postgresql-typed) From 682cbf45a4a193e03a5e8f76a24da2c82c35d34b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 25 Jun 2019 16:05:50 -0400 Subject: [PATCH 271/306] Update reference to README --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 7a5fd39..a565570 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -21,7 +21,7 @@ Description: Automatically type-check SQL statements at compile time. Originally based on Chris Forno's templatepg library. Tested-With: GHC == 7.10.3, GHC == 8.0.1 Build-Type: Simple -extra-source-files: README +extra-source-files: README.md source-repository head type: git From d7c16af2f9eb499d8366feffaeb03995e0d9b363 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 26 Jun 2019 11:31:50 -0400 Subject: [PATCH 272/306] Add a Show PGDatabase instance --- Database/PostgreSQL/Typed/Protocol.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 29216b7..ba6d6af 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -127,6 +127,7 @@ import System.IO (stderr, hPutStrLn) import System.IO.Error (IOError, mkIOError, eofErrorType, ioError, ioeSetErrorString) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe) +import Text.Show.Functions () import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic @@ -186,7 +187,7 @@ data PGDatabase = PGDatabase #ifdef VERSION_tls , pgDBTLS :: PGTlsMode -- ^ TLS mode #endif - } + } deriving (Show) instance Eq PGDatabase where #ifdef VERSION_tls From 83b863d4140a26a04228be7ca44fbdf1f5542c10 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 27 Jun 2019 16:41:07 -0400 Subject: [PATCH 273/306] Fixes for network 3: Network is gone; fdSocket --- Database/PostgreSQL/Typed/Protocol.hs | 10 +++++++++- Database/PostgreSQL/Typed/TemplatePG.hs | 17 +++++++++++++++-- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index ba6d6af..8a49031 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -1140,7 +1140,15 @@ recvBufNonBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int recvBufNonBlock s ptr nbytes | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNonBlock") | otherwise = do - len <- c_recv (Net.fdSocket s) (castPtr ptr) (fromIntegral nbytes) 0 + len <- +#if MIN_VERSION_network(3,1,0) + Net.withFdSocket s $ \fd -> +#elif MIN_VERSION_network(3,0,0) + Net.fdSocket s >>= \fd -> +#else + let fd = Net.fdSocket s in +#endif + c_recv fd (castPtr ptr) (fromIntegral nbytes) 0 if len == -1 then do errno <- getErrno diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index 91a1b39..a56bb44 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-deprecations #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno @@ -20,6 +21,9 @@ module Database.PostgreSQL.Typed.TemplatePG , rollback , PGException , pgConnect +#if !MIN_VERSION_network(3,0,0) + , PortID(..) +#endif , PG.pgDisconnect ) where @@ -30,7 +34,11 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe (listToMaybe, isJust) import qualified Language.Haskell.TH as TH -import Network (HostName, PortID(..)) +#if MIN_VERSION_network(3,0,0) +import Data.Word (Word16) +#else +import Network (PortID(..)) +#endif import qualified Network.Socket as Net import System.Environment (lookupEnv) @@ -91,7 +99,12 @@ insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where type PGException = PG.PGError -pgConnect :: HostName -- ^ the host to connect to +#if MIN_VERSION_network(3,0,0) +-- |For backwards compatibility with old network package. +data PortID = Service String | PortNumber Word16 | UnixSocket String +#endif + +pgConnect :: String -- ^ the host to connect to -> PortID -- ^ the port to connect on -> ByteString -- ^ the database to connect to -> ByteString -- ^ the username to connect as From cbd714f24f079392ddd3a41346e3babd70ccf0fc Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 27 Jun 2019 16:42:38 -0400 Subject: [PATCH 274/306] Bugfix release 0.6.0.1 for network 3 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index a565570..f94c0a3 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6 +Version: 0.6.0.1 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From 94c31249c20d2d495a69d83586a95523e7246dfb Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 5 Oct 2019 11:47:33 -0400 Subject: [PATCH 275/306] Add PGQuery.getQueryString for #19 --- Database/PostgreSQL/Typed/Query.hs | 5 +++++ stack.yaml | 2 +- test/Main.hs | 2 ++ 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index fb403e6..438535d 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -52,6 +52,7 @@ class PGQuery q a | q -> a where -- -- > [pgSQL|SELECT a FROM t|] `unsafeModifyQuery` (<> (" WHERE a = " <> pgSafeLiteral x)) unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q + getQueryString :: PGConnection -> q -> BS.ByteString class PGQuery q PGValues => PGRawQuery q -- |Execute a query that does not return results. @@ -66,12 +67,14 @@ pgQuery c q = snd <$> pgRunQuery c q instance PGQuery BS.ByteString PGValues where pgRunQuery c sql = pgSimpleQuery c (BSL.fromStrict sql) unsafeModifyQuery q f = f q + getQueryString _ = id newtype SimpleQuery = SimpleQuery BS.ByteString deriving (Show) instance PGQuery SimpleQuery PGValues where pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c (BSL.fromStrict sql) unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql + getQueryString _ (SimpleQuery q) = q instance PGRawQuery SimpleQuery data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool] @@ -79,6 +82,7 @@ data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool] instance PGQuery PreparedQuery PGValues where pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc + getQueryString _ (PreparedQuery q _ _ _) = q instance PGRawQuery PreparedQuery @@ -86,6 +90,7 @@ data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a) instance PGRawQuery q => PGQuery (QueryParser q a) a where pgRunQuery c (QueryParser q p) = second (fmap $ p e) <$> pgRunQuery c (q e) where e = pgTypeEnv c unsafeModifyQuery (QueryParser q p) f = QueryParser (\e -> unsafeModifyQuery (q e) f) p + getQueryString c (QueryParser q _) = getQueryString c $ q $ pgTypeEnv c instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) diff --git a/stack.yaml b/stack.yaml index f1f8287..119dfd4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-13.26 +resolver: lts-14.7 packages: - '.' diff --git a/test/Main.hs b/test/Main.hs index 42ccf0b..77f5da1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -18,6 +18,7 @@ import Test.QuickCheck.Test (isSuccess) import Database.PostgreSQL.Typed import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Protocol +import Database.PostgreSQL.Typed.Query (PGSimpleQuery, getQueryString) import Database.PostgreSQL.Typed.Array () import qualified Database.PostgreSQL.Typed.Range as Range import Database.PostgreSQL.Typed.Enum @@ -136,6 +137,7 @@ main = do $ selectProp c Q..&&. tokenProp Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" + Q..&&. getQueryString c ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" Q..&&. pgEnumValues Q.=== [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] Q..&&. Q.conjoin (map (\(s, t) -> sqlTokens s Q.=== t) [ ("", From f3194c407db1449220e9547c94759ca81cd6f504 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 5 Oct 2019 12:39:15 -0400 Subject: [PATCH 276/306] Update ErrCodes from postgresql 12.0 --- Database/PostgreSQL/Typed/ErrCodes.hs | 98 ++++++++++++++++++++++++++- 1 file changed, 97 insertions(+), 1 deletion(-) diff --git a/Database/PostgreSQL/Typed/ErrCodes.hs b/Database/PostgreSQL/Typed/ErrCodes.hs index 0f5cf95..b047922 100644 --- a/Database/PostgreSQL/Typed/ErrCodes.hs +++ b/Database/PostgreSQL/Typed/ErrCodes.hs @@ -1,4 +1,4 @@ --- Automatically generated from /src/postgresql-11.3/src/src/backend/utils/errcodes.txt using errcodes 2019-05-29 19:31:19.442545643 UTC. +-- Automatically generated from /src/postgresql-12.0/src/src/backend/utils/errcodes.txt using errcodes 2019-10-05 16:38:46.694932074 UTC. {-# LANGUAGE OverloadedStrings #-} -- |PostgreSQL error codes. module Database.PostgreSQL.Typed.ErrCodes (names @@ -101,6 +101,21 @@ module Database.PostgreSQL.Typed.ErrCodes (names , invalid_xml_content , invalid_xml_comment , invalid_xml_processing_instruction + , duplicate_json_object_key_value + , invalid_json_text + , invalid_sql_json_subscript + , more_than_one_sql_json_item + , no_sql_json_item + , non_numeric_sql_json_item + , non_unique_keys_in_a_json_object + , singleton_sql_json_item_required + , sql_json_array_not_found + , sql_json_member_not_found + , sql_json_number_not_found + , sql_json_object_not_found + , too_many_json_array_elements + , too_many_json_object_members + , sql_json_scalar_required -- * Class 23 - Integrity Constraint Violation , integrity_constraint_violation , restrict_violation @@ -237,6 +252,7 @@ module Database.PostgreSQL.Typed.ErrCodes (names , object_in_use , cant_change_runtime_param , lock_not_available + , unsafe_new_enum_value_usage -- * Class 57 - Operator Intervention , operator_intervention , query_canceled @@ -633,6 +649,66 @@ invalid_xml_comment = "2200S" invalid_xml_processing_instruction :: ByteString invalid_xml_processing_instruction = "2200T" +-- |@DUPLICATE_JSON_OBJECT_KEY_VALUE@: 22030 (Error) +duplicate_json_object_key_value :: ByteString +duplicate_json_object_key_value = "22030" + +-- |@INVALID_JSON_TEXT@: 22032 (Error) +invalid_json_text :: ByteString +invalid_json_text = "22032" + +-- |@INVALID_SQL_JSON_SUBSCRIPT@: 22033 (Error) +invalid_sql_json_subscript :: ByteString +invalid_sql_json_subscript = "22033" + +-- |@MORE_THAN_ONE_SQL_JSON_ITEM@: 22034 (Error) +more_than_one_sql_json_item :: ByteString +more_than_one_sql_json_item = "22034" + +-- |@NO_SQL_JSON_ITEM@: 22035 (Error) +no_sql_json_item :: ByteString +no_sql_json_item = "22035" + +-- |@NON_NUMERIC_SQL_JSON_ITEM@: 22036 (Error) +non_numeric_sql_json_item :: ByteString +non_numeric_sql_json_item = "22036" + +-- |@NON_UNIQUE_KEYS_IN_A_JSON_OBJECT@: 22037 (Error) +non_unique_keys_in_a_json_object :: ByteString +non_unique_keys_in_a_json_object = "22037" + +-- |@SINGLETON_SQL_JSON_ITEM_REQUIRED@: 22038 (Error) +singleton_sql_json_item_required :: ByteString +singleton_sql_json_item_required = "22038" + +-- |@SQL_JSON_ARRAY_NOT_FOUND@: 22039 (Error) +sql_json_array_not_found :: ByteString +sql_json_array_not_found = "22039" + +-- |@SQL_JSON_MEMBER_NOT_FOUND@: 2203A (Error) +sql_json_member_not_found :: ByteString +sql_json_member_not_found = "2203A" + +-- |@SQL_JSON_NUMBER_NOT_FOUND@: 2203B (Error) +sql_json_number_not_found :: ByteString +sql_json_number_not_found = "2203B" + +-- |@SQL_JSON_OBJECT_NOT_FOUND@: 2203C (Error) +sql_json_object_not_found :: ByteString +sql_json_object_not_found = "2203C" + +-- |@TOO_MANY_JSON_ARRAY_ELEMENTS@: 2203D (Error) +too_many_json_array_elements :: ByteString +too_many_json_array_elements = "2203D" + +-- |@TOO_MANY_JSON_OBJECT_MEMBERS@: 2203E (Error) +too_many_json_object_members :: ByteString +too_many_json_object_members = "2203E" + +-- |@SQL_JSON_SCALAR_REQUIRED@: 2203F (Error) +sql_json_scalar_required :: ByteString +sql_json_scalar_required = "2203F" + -- |@INTEGRITY_CONSTRAINT_VIOLATION@: 23000 (Error) integrity_constraint_violation :: ByteString integrity_constraint_violation = "23000" @@ -1093,6 +1169,10 @@ cant_change_runtime_param = "55P02" lock_not_available :: ByteString lock_not_available = "55P03" +-- |@UNSAFE_NEW_ENUM_VALUE_USAGE@: 55P04 (Error) +unsafe_new_enum_value_usage :: ByteString +unsafe_new_enum_value_usage = "55P04" + -- |@OPERATOR_INTERVENTION@: 57000 (Error) operator_intervention :: ByteString operator_intervention = "57000" @@ -1366,6 +1446,21 @@ names = fromDistinctAscList ,(array_subscript_error,"array_subscript_error") ,(invalid_tablesample_repeat,"invalid_tablesample_repeat") ,(invalid_tablesample_argument,"invalid_tablesample_argument") + ,(duplicate_json_object_key_value,"duplicate_json_object_key_value") + ,(invalid_json_text,"invalid_json_text") + ,(invalid_sql_json_subscript,"invalid_sql_json_subscript") + ,(more_than_one_sql_json_item,"more_than_one_sql_json_item") + ,(no_sql_json_item,"no_sql_json_item") + ,(non_numeric_sql_json_item,"non_numeric_sql_json_item") + ,(non_unique_keys_in_a_json_object,"non_unique_keys_in_a_json_object") + ,(singleton_sql_json_item_required,"singleton_sql_json_item_required") + ,(sql_json_array_not_found,"sql_json_array_not_found") + ,(sql_json_member_not_found,"sql_json_member_not_found") + ,(sql_json_number_not_found,"sql_json_number_not_found") + ,(sql_json_object_not_found,"sql_json_object_not_found") + ,(too_many_json_array_elements,"too_many_json_array_elements") + ,(too_many_json_object_members,"too_many_json_object_members") + ,(sql_json_scalar_required,"sql_json_scalar_required") ,(floating_point_exception,"floating_point_exception") ,(invalid_text_representation,"invalid_text_representation") ,(invalid_binary_representation,"invalid_binary_representation") @@ -1487,6 +1582,7 @@ names = fromDistinctAscList ,(object_in_use,"object_in_use") ,(cant_change_runtime_param,"cant_change_runtime_param") ,(lock_not_available,"lock_not_available") + ,(unsafe_new_enum_value_usage,"unsafe_new_enum_value_usage") ,(operator_intervention,"operator_intervention") ,(query_canceled,"query_canceled") ,(admin_shutdown,"admin_shutdown") From 70102c8ce0b2ee5f3b572b40a414f7606758ff42 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 5 Oct 2019 12:44:17 -0400 Subject: [PATCH 277/306] Bump version to 0.6.1.0 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index f94c0a3..ef8e198 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.0.1 +Version: 0.6.1.0 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING From 33663f7f56a99824d628627565da488159aeb8e3 Mon Sep 17 00:00:00 2001 From: Stoeffel Date: Wed, 16 Oct 2019 16:04:55 +0200 Subject: [PATCH 278/306] change getQueryString to take PGTypeEnv instead of PGConnection --- Database/PostgreSQL/Typed/Query.hs | 4 ++-- test/Main.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 438535d..bab84be 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -52,7 +52,7 @@ class PGQuery q a | q -> a where -- -- > [pgSQL|SELECT a FROM t|] `unsafeModifyQuery` (<> (" WHERE a = " <> pgSafeLiteral x)) unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q - getQueryString :: PGConnection -> q -> BS.ByteString + getQueryString :: PGTypeEnv -> q -> BS.ByteString class PGQuery q PGValues => PGRawQuery q -- |Execute a query that does not return results. @@ -90,7 +90,7 @@ data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a) instance PGRawQuery q => PGQuery (QueryParser q a) a where pgRunQuery c (QueryParser q p) = second (fmap $ p e) <$> pgRunQuery c (q e) where e = pgTypeEnv c unsafeModifyQuery (QueryParser q p) f = QueryParser (\e -> unsafeModifyQuery (q e) f) p - getQueryString c (QueryParser q _) = getQueryString c $ q $ pgTypeEnv c + getQueryString e (QueryParser q _) = getQueryString e $ q e instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) diff --git a/test/Main.hs b/test/Main.hs index 77f5da1..1b72644 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -137,7 +137,7 @@ main = do $ selectProp c Q..&&. tokenProp Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" - Q..&&. getQueryString c ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" + Q..&&. getQueryString (pgTypeEnv c) ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" Q..&&. pgEnumValues Q.=== [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] Q..&&. Q.conjoin (map (\(s, t) -> sqlTokens s Q.=== t) [ ("", From 4e4857afbb038eb93652a6645b6345b9895b76c1 Mon Sep 17 00:00:00 2001 From: Kazuki Okamoto Date: Thu, 17 Oct 2019 18:20:27 +0900 Subject: [PATCH 279/306] condition whether network before 2.7.0 or not and whether MinGW or not --- Database/PostgreSQL/Typed/TemplatePG.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/Database/PostgreSQL/Typed/TemplatePG.hs b/Database/PostgreSQL/Typed/TemplatePG.hs index a56bb44..88b116b 100644 --- a/Database/PostgreSQL/Typed/TemplatePG.hs +++ b/Database/PostgreSQL/Typed/TemplatePG.hs @@ -21,7 +21,7 @@ module Database.PostgreSQL.Typed.TemplatePG , rollback , PGException , pgConnect -#if !MIN_VERSION_network(3,0,0) +#if !MIN_VERSION_network(2,7,0) , PortID(..) #endif , PG.pgDisconnect @@ -34,12 +34,14 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe (listToMaybe, isJust) import qualified Language.Haskell.TH as TH -#if MIN_VERSION_network(3,0,0) +#if MIN_VERSION_network(2,7,0) import Data.Word (Word16) #else import Network (PortID(..)) #endif +#if !defined(mingw32_HOST_OS) import qualified Network.Socket as Net +#endif import System.Environment (lookupEnv) import qualified Database.PostgreSQL.Typed.Protocol as PG @@ -99,9 +101,14 @@ insertIgnore q = catchJust uniquenessError q (\ _ -> return ()) where type PGException = PG.PGError -#if MIN_VERSION_network(3,0,0) +#if MIN_VERSION_network(2,7,0) -- |For backwards compatibility with old network package. -data PortID = Service String | PortNumber Word16 | UnixSocket String +data PortID + = Service String + | PortNumber Word16 +#if !defined(mingw32_HOST_OS) + | UnixSocket String +#endif #endif pgConnect :: String -- ^ the host to connect to @@ -116,7 +123,9 @@ pgConnect h n d u p = do { PG.pgDBAddr = case n of PortNumber s -> Left (h, show s) Service s -> Left (h, s) +#if !defined(mingw32_HOST_OS) UnixSocket s -> Right (Net.SockAddrUnix s) +#endif , PG.pgDBName = d , PG.pgDBUser = u , PG.pgDBPass = p From 59a07c2f905b745149da68727ac1ef7e774786a7 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Jun 2020 21:03:38 -0400 Subject: [PATCH 280/306] Fixes for ghc 8.8, template-haskell 2.15 --- Database/PostgreSQL/Typed/Enum.hs | 11 +++++++++-- Database/PostgreSQL/Typed/Relation.hs | 11 +++++++++-- postgresql-typed.cabal | 2 +- stack.yaml | 2 +- 4 files changed, 20 insertions(+), 6 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 82ca3ad..9881fa9 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -91,7 +91,7 @@ dataPGEnum typs pgenum valnf = do #endif [''Eq, ''Ord, ''Enum, ''Ix, ''Bounded, ''Typeable] , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) - [ TH.TySynInstD ''PGVal $ TH.TySynEqn [typl] typt + [ tySynInstD ''PGVal typl typt ] , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) [ TH.FunD 'pgEncode [TH.Clause [TH.WildP, TH.VarP dv] @@ -108,7 +108,7 @@ dataPGEnum typs pgenum valnf = do []] ] , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) - [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl + [ tySynInstD ''PGRepType typt typl ] , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) [ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [TH.ConP n []] @@ -135,4 +135,11 @@ dataPGEnum typs pgenum valnf = do #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif + tySynInstD c l t = TH.TySynInstD +#if MIN_VERSION_template_haskell(2,15,0) + $ TH.TySynEqn Nothing (TH.AppT (TH.ConT c) l) +#else + c $ TH.TySynEqn [l] +#endif + t namelit l = TH.ConE 'PGName `TH.AppE` TH.ListE (map TH.LitE l) diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index 276e1ab..1f98205 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -114,7 +114,7 @@ dataPGRelation typs pgtab colf = do ] [] , instanceD [] (TH.ConT ''PGType `TH.AppT` typl) - [ TH.TySynInstD ''PGVal $ TH.TySynEqn [typl] typt + [ tySynInstD ''PGVal typl typt ] , instanceD [] (TH.ConT ''PGParameter `TH.AppT` typl `TH.AppT` typt) [ encfun 'pgEncode @@ -158,7 +158,7 @@ dataPGRelation typs pgtab colf = do ] #endif , instanceD [] (TH.ConT ''PGRep `TH.AppT` typt) - [ TH.TySynInstD ''PGRepType $ TH.TySynEqn [typt] typl + [ tySynInstD ''PGRepType typt typl ] , instanceD [] (TH.ConT ''PGRecordType `TH.AppT` typl) [] , instanceD [] (TH.ConT ''PGRelation `TH.AppT` typt) @@ -191,6 +191,13 @@ dataPGRelation typs pgtab colf = do #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif + tySynInstD c l t = TH.TySynInstD +#if MIN_VERSION_template_haskell(2,15,0) + $ TH.TySynEqn Nothing (TH.AppT (TH.ConT c) l) +#else + c $ TH.TySynEqn [l] +#endif + t pgcall f t = TH.VarE f `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeID `TH.AppT` t)) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index ef8e198..6efdc95 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.1.0 +Version: 0.6.1.1 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING diff --git a/stack.yaml b/stack.yaml index 119dfd4..e1884c5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-14.7 +resolver: lts-16.3 packages: - '.' From 704e6afd41fc5980f2548c260696f30ff4026c3b Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Tue, 30 Jun 2020 21:29:45 -0400 Subject: [PATCH 281/306] update to cabal 1.10 --- postgresql-typed.cabal | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 6efdc95..6181ff3 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,6 +1,6 @@ Name: postgresql-typed Version: 0.6.1.1 -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING Copyright: 2010-2013 Chris Forno, 2014-2019 Dylan Simon @@ -59,6 +59,7 @@ Flag tls Default: True Library + default-language: Haskell2010 Build-Depends: base >= 4.8 && < 5, array, @@ -112,17 +113,19 @@ Library Build-Depends: data-default, tls, x509, x509-store, x509-validation test-suite test + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs Other-Modules: Connect - Extensions: TemplateHaskell, QuasiQuotes + default-Extensions: TemplateHaskell, QuasiQuotes build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck GHC-Options: -Wall if flag(tls) Build-Depends: tls test-suite hdbc + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test/hdbc, test main-is: runtests.hs @@ -143,6 +146,7 @@ test-suite hdbc Build-Depends: tls benchmark bench + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Bench.hs From 20cf9b384772346adedc56ddf5735915cc299a3a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 6 Aug 2020 20:11:22 -0400 Subject: [PATCH 282/306] compatibility for template-haskell-2.16 --- Database/PostgreSQL/Typed/Query.hs | 6 +++++- stack.yaml | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index bab84be..5e1ae98 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -220,7 +220,11 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do ) prep) `TH.AppE` TH.LamE [TH.VarP e, TH.VarP l] (TH.CaseE (TH.VarE l) - [ TH.Match (TH.ListP pats) (TH.NormalB $ TH.TupE conv) [] + [ TH.Match (TH.ListP pats) (TH.NormalB $ TH.TupE +#if MIN_VERSION_template_haskell(2,16,0) + $ map Just +#endif + conv) [] , TH.Match TH.WildP (TH.NormalB $ TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL "pgSQL: result arity mismatch")) [] ])) <$> mapM parse exprs diff --git a/stack.yaml b/stack.yaml index e1884c5..3f36f52 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-16.3 +resolver: lts-16.8 packages: - '.' From 65ef4782b4ee4d58d8fb034a820e5b7707ca8300 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 7 Aug 2020 12:52:53 -0400 Subject: [PATCH 283/306] unwrap singleton results from Unit tuple --- Database/PostgreSQL/Typed/Query.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index 5e1ae98..c7a5ea5 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -220,11 +220,13 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do ) prep) `TH.AppE` TH.LamE [TH.VarP e, TH.VarP l] (TH.CaseE (TH.VarE l) - [ TH.Match (TH.ListP pats) (TH.NormalB $ TH.TupE + [ TH.Match (TH.ListP pats) (TH.NormalB $ case conv of + [x] -> x + _ -> TH.TupE #if MIN_VERSION_template_haskell(2,16,0) - $ map Just + $ map Just #endif - conv) [] + conv) [] , TH.Match TH.WildP (TH.NormalB $ TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL "pgSQL: result arity mismatch")) [] ])) <$> mapM parse exprs From d6fa62426de5a0e1a0c9f69da392ad5218787f0a Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 7 Aug 2020 13:09:44 -0400 Subject: [PATCH 284/306] Bump version 0.6.1.2 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 6181ff3..25dd354 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.1.1 +Version: 0.6.1.2 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING From 33e5e124bfb18eab8c082a3a8208ab18c05b880e Mon Sep 17 00:00:00 2001 From: Chris Forno Date: Sun, 13 Sep 2020 13:29:54 +0800 Subject: [PATCH 285/306] Encode non-ASCII characters in query (i.e. identifiers). --- Database/PostgreSQL/Typed/Query.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/Database/PostgreSQL/Typed/Query.hs b/Database/PostgreSQL/Typed/Query.hs index c7a5ea5..bc38032 100644 --- a/Database/PostgreSQL/Typed/Query.hs +++ b/Database/PostgreSQL/Typed/Query.hs @@ -25,6 +25,8 @@ import Data.Array (listArray, (!), inRange) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.ByteString.UTF8 as BSU import Data.Char (isSpace, isAlphaNum) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) @@ -148,7 +150,7 @@ sqlSubstitute sql exprl = TH.AppE (TH.VarE 'BS.concat) $ TH.ListE $ map sst $ sq | inRange bnds n = exprs ! n | otherwise = error $ "SQL placeholder '$" ++ show n ++ "' out of range (not recognized by PostgreSQL)" sst (SQLParam n) = expr n - sst t = TH.VarE 'fromString `TH.AppE` TH.LitE (TH.StringL $ show t) + sst t = TH.VarE 'BSU.fromString `TH.AppE` TH.LitE (TH.StringL $ show t) splitCommas :: String -> [String] splitCommas = spl where @@ -185,7 +187,7 @@ newName pre = TH.newName . ('_':) . (pre:) . filter (\c -> isAlphaNum c || c == makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do - (pt, rt) <- TH.runIO $ tpgDescribe (fromString sqlp) (fromMaybe [] prep) (isNothing nulls) + (pt, rt) <- TH.runIO $ tpgDescribe (BSU.fromString sqlp) (fromMaybe [] prep) (isNothing nulls) when (length pt < length exprs) $ fail "Not all expression placeholders were recognized by PostgreSQL" e <- TH.newName "_tenv" @@ -208,7 +210,7 @@ makePGQuery QueryFlags{ flagNullable = nulls, flagPrepare = prep } sqle = do (TH.ConE 'SimpleQuery `TH.AppE` sqlSubstitute sqlp vals) (\p -> TH.ConE 'PreparedQuery - `TH.AppE` (TH.VarE 'fromString `TH.AppE` TH.LitE (TH.StringL sqlp)) + `TH.AppE` (TH.VarE 'BSU.fromString `TH.AppE` TH.LitE (TH.StringL sqlp)) `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . toInteger . tpgValueTypeOID . snd) $ zip p pt) `TH.AppE` TH.ListE vals `TH.AppE` TH.ListE @@ -255,7 +257,7 @@ qqTop :: Bool -> String -> TH.DecsQ qqTop True ('!':sql) = qqTop False sql qqTop err sql = do r <- TH.runIO $ try $ withTPGConnection $ \c -> - pgSimpleQuery c (fromString sql) + pgSimpleQuery c (BSLU.fromString sql) either ((if err then TH.reportError else TH.reportWarning) . (show :: PGError -> String)) (const $ return ()) r return [] From dfaaa919209c94f3908b70b39e576e14c45db8a2 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 24 Sep 2020 19:14:12 -0400 Subject: [PATCH 286/306] Add test for literals; set extra_float_digits=3 Check and fail on nulls in literal strings which currently cause parse errors (since server would reject them even if they were encoded correctly anyway). --- Database/PostgreSQL/Typed/Protocol.hs | 1 + Database/PostgreSQL/Typed/Types.hs | 4 +++- stack.yaml | 2 +- test/Main.hs | 24 ++++++++++++++++++++++-- 4 files changed, 27 insertions(+), 4 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index 8a49031..c2d3d8b 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -707,6 +707,7 @@ pgConnect db = do , ("bytea_output", "hex") , ("DateStyle", "ISO, YMD") , ("IntervalStyle", "iso_8601") + , ("extra_float_digits", "3") ] ++ pgDBParams db pgFlush c conn c diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index 7c15296..f5c8edc 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -232,7 +232,9 @@ pgQuoteUnsafe = (`BSC.snoc` '\'') . BSC.cons '\'' -- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes. pgQuote :: BS.ByteString -> BS.ByteString -pgQuote = pgQuoteUnsafe . BSC.intercalate (BSC.pack "''") . BSC.split '\'' +pgQuote s + | '\0' `BSC.elem` s = error "pgQuote: unhandled null in literal" + | otherwise = pgQuoteUnsafe $ BSC.intercalate (BSC.pack "''") $ BSC.split '\'' s -- |Shorthand for @'BSL.toStrict' . 'BSB.toLazyByteString'@ buildPGValue :: BSB.Builder -> BS.ByteString diff --git a/stack.yaml b/stack.yaml index 3f36f52..e423dca 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-16.8 +resolver: lts-16.15 packages: - '.' diff --git a/test/Main.hs b/test/Main.hs index 1b72644..ea0553a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -84,7 +84,7 @@ instance Q.Arbitrary SQLToken where , SQLExpr <$> Q.arbitrary , SQLQMark <$> Q.arbitrary ] - + newtype Str = Str { strString :: [Char] } deriving (Eq, Show) strByte :: Str -> BS.ByteString strByte = BSC.pack . strString @@ -106,7 +106,7 @@ selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime selectProp pgc b c i f t z d p s l r e a = Q.ioProperty $ do [(Just b', Just c', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] - return $ Q.conjoin + return $ Q.conjoin [ i Q.=== i' , c Q.=== c' , b Q.=== b' @@ -122,6 +122,25 @@ selectProp pgc b c i f t z d p s l r e a = Q.ioProperty $ do , a Q.=== a' ] +selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Str -> [Maybe Str] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp' pgc b i f t z d p s l r e a = Q.ioProperty $ do + [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc + [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + return $ Q.conjoin + [ i Q.=== i' + , b Q.=== b' + , strString s Q.=== s' + , f Q.=== f' + , d Q.=== d' + , t Q.=== t' + , z Q.=== z' + , p Q.=== p' + , l Q.=== map (fmap byteStr) l' + , Range.normalize' r Q.=== r' + , e Q.=== e' + , a Q.=== a' + ] + tokenProp :: String -> Q.Property tokenProp s = not (has0 s) Q.==> s Q.=== show (sqlTokens s) where @@ -135,6 +154,7 @@ main = do r <- Q.quickCheckResult $ selectProp c + Q..&&. selectProp' c Q..&&. tokenProp Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" Q..&&. getQueryString (pgTypeEnv c) ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" From 30f61494740b8936619222c880a7592a9114fe35 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 24 Sep 2020 19:36:37 -0400 Subject: [PATCH 287/306] Add unicode string tests --- test/Main.hs | 26 ++++++++------------------ 1 file changed, 8 insertions(+), 18 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index ea0553a..05fe873 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -5,8 +5,6 @@ module Main (main) where import Control.Exception (try) import Control.Monad (unless) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC import Data.Char (isDigit, toUpper) import Data.Int (Int32) import qualified Data.Time as Time @@ -85,14 +83,6 @@ instance Q.Arbitrary SQLToken where , SQLQMark <$> Q.arbitrary ] -newtype Str = Str { strString :: [Char] } deriving (Eq, Show) -strByte :: Str -> BS.ByteString -strByte = BSC.pack . strString -byteStr :: BS.ByteString -> Str -byteStr = Str . BSC.unpack -instance Q.Arbitrary Str where - arbitrary = Str <$> Q.listOf (Q.choose (' ', '~')) - 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] @@ -102,40 +92,40 @@ prepared c t = pgQuery c . [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE preparedApply :: PGConnection -> Int32 -> IO [String] preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] -selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Str -> [Maybe Str] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Q.UnicodeString -> [Maybe Q.UnicodeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property selectProp pgc b c i f t z d p s l r e a = Q.ioProperty $ do [(Just b', Just c', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc - [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${Q.getUnicodeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap Q.getUnicodeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] return $ Q.conjoin [ i Q.=== i' , c Q.=== c' , b Q.=== b' - , strString s Q.=== s' + , Q.getUnicodeString s Q.=== s' , f Q.=== f' , d Q.=== d' , t Q.=== t' , z Q.=== z' , p Q.=== p' - , l Q.=== map (fmap byteStr) l' + , map (fmap Q.getUnicodeString) l Q.=== l' , Range.normalize' r Q.=== r' , e Q.=== e' , a Q.=== a' ] -selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Str -> [Maybe Str] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Q.UnicodeString -> [Maybe Q.UnicodeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property selectProp' pgc b i f t z d p s l r e a = Q.ioProperty $ do [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc - [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${strString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap strByte) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${Q.getUnicodeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap Q.getUnicodeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] return $ Q.conjoin [ i Q.=== i' , b Q.=== b' - , strString s Q.=== s' + , Q.getUnicodeString s Q.=== s' , f Q.=== f' , d Q.=== d' , t Q.=== t' , z Q.=== z' , p Q.=== p' - , l Q.=== map (fmap byteStr) l' + , map (fmap Q.getUnicodeString) l Q.=== l' , Range.normalize' r Q.=== r' , e Q.=== e' , a Q.=== a' From 95e49a8b5a118b822b0c7b3cdb095ebdd4221987 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 24 Sep 2020 20:18:37 -0400 Subject: [PATCH 288/306] Add unicode column name, table tests --- test/Main.hs | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 05fe873..cf403fa 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -36,7 +36,8 @@ useTPGDatabase db -- This runs at compile-time: [pgSQL|!CREATE TYPE myenum AS enum ('abc', 'DEF', 'XX_ye')|] -[pgSQL|!CREATE TABLE myfoo (id serial primary key, adx myenum, bar char(4))|] +[pgSQL|!DROP TABLE myfoo|] +[pgSQL|!CREATE TABLE myfoo (id serial primary key, adé myenum, bar float)|] dataPGEnum "MyEnum" "myenum" ("MyEnum_" ++) @@ -44,11 +45,13 @@ deriving instance Show MyEnum dataPGRelation "MyFoo" "myfoo" (\(c:s) -> "foo" ++ toUpper c : s) -_fooRow :: MyFoo -_fooRow = MyFoo{ fooId = 1, fooAdx = Just MyEnum_DEF, fooBar = Just "abcd" } - instance Q.Arbitrary MyEnum where arbitrary = Q.arbitraryBoundedEnum +instance Q.Arbitrary MyFoo where + arbitrary = MyFoo 0 <$> Q.arbitrary <*> Q.arbitrary +instance Eq MyFoo where + MyFoo _ a b == MyFoo _ a' b' = a == a' && b == b' +deriving instance Show MyFoo instance Q.Arbitrary Time.Day where arbitrary = Time.ModifiedJulianDay <$> Q.arbitrary @@ -131,6 +134,21 @@ selectProp' pgc b i f t z d p s l r e a = Q.ioProperty $ do , a Q.=== a' ] +selectFoo :: PGConnection -> [MyFoo] -> Q.Property +selectFoo pgc l = Q.ioProperty $ do + _ <- pgExecute pgc [pgSQL|TRUNCATE myfoo|] + let loop [] = return () + loop [x] = do + 1 <- pgExecute pgc [pgSQL|INSERT INTO myfoo (bar, adé) VALUES (${fooBar x}, ${fooAdé x})|] + return () + loop (x:y:r) = do + 1 <- pgExecute pgc [pgSQL|INSERT INTO myfoo (adé, bar) VALUES (${fooAdé x}, ${fooBar x})|] + 1 <- pgExecute pgc [pgSQL|$INSERT INTO myfoo (adé, bar) VALUES (${fooAdé y}, ${fooBar y})|] + loop r + loop l + r <- pgQuery pgc [pgSQL|SELECT * FROM myfoo ORDER BY id|] + return $ l Q.=== map (\(i,a,b) -> MyFoo i a b) r + tokenProp :: String -> Q.Property tokenProp s = not (has0 s) Q.==> s Q.=== show (sqlTokens s) where @@ -145,6 +163,7 @@ main = do r <- Q.quickCheckResult $ selectProp c Q..&&. selectProp' c + Q..&&. selectFoo c Q..&&. tokenProp Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer" Q..&&. getQueryString (pgTypeEnv c) ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" From 02f3d5513855fb21e94df05469303e2a1107a1f4 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 24 Mar 2021 09:32:46 -0400 Subject: [PATCH 289/306] raise attoparsec upper bound --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 25dd354..344c402 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -71,7 +71,7 @@ Library template-haskell, haskell-src-meta, network, - attoparsec >= 0.12 && < 0.14, + attoparsec >= 0.12 && < 0.15, utf8-string Exposed-Modules: Database.PostgreSQL.Typed From ab913bb92a29a1eafc87cd6e76850cf83e2f9225 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 24 Mar 2021 09:51:41 -0400 Subject: [PATCH 290/306] make unicode tests work by avoiding nulls --- postgresql-typed.cabal | 2 +- stack.yaml | 2 +- test/Main.hs | 24 ++++++++++++++++-------- 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 344c402..0b6f8e2 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.1.2 +Version: 0.6.2.0 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING diff --git a/stack.yaml b/stack.yaml index e423dca..7cd1b9d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-16.15 +resolver: lts-17.7 packages: - '.' diff --git a/test/Main.hs b/test/Main.hs index cf403fa..c4873e8 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -86,6 +86,14 @@ instance Q.Arbitrary SQLToken where , SQLQMark <$> Q.arbitrary ] +newtype SafeString = SafeString Q.UnicodeString + deriving (Eq, Ord, Show) +instance Q.Arbitrary SafeString where + arbitrary = SafeString <$> Q.suchThat Q.arbitrary (notElem '\0' . Q.getUnicodeString) + +getSafeString :: SafeString -> String +getSafeString (SafeString s) = Q.getUnicodeString s + simple :: PGConnection -> OID -> IO [String] simple c t = pgQuery c [pgSQL|SELECT typname FROM pg_catalog.pg_type WHERE oid = ${t} AND oid = $1|] simpleApply :: PGConnection -> OID -> IO [Maybe String] @@ -95,40 +103,40 @@ prepared c t = pgQuery c . [pgSQL|?$SELECT typname FROM pg_catalog.pg_type WHERE preparedApply :: PGConnection -> Int32 -> IO [String] preparedApply c = pgQuery c . [pgSQL|$(integer)SELECT typname FROM pg_catalog.pg_type WHERE oid = $1|] -selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Q.UnicodeString -> [Maybe Q.UnicodeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp :: PGConnection -> Bool -> Word8 -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> SafeString -> [Maybe SafeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property selectProp pgc b c i f t z d p s l r e a = Q.ioProperty $ do [(Just b', Just c', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc - [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${Q.getUnicodeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap Q.getUnicodeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + [pgSQL|$SELECT ${b}::bool, ${c}::"char", ${Just i}::int, ${f}::float4, ${getSafeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap getSafeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] return $ Q.conjoin [ i Q.=== i' , c Q.=== c' , b Q.=== b' - , Q.getUnicodeString s Q.=== s' + , getSafeString s Q.=== s' , f Q.=== f' , d Q.=== d' , t Q.=== t' , z Q.=== z' , p Q.=== p' - , map (fmap Q.getUnicodeString) l Q.=== l' + , map (fmap getSafeString) l Q.=== l' , Range.normalize' r Q.=== r' , e Q.=== e' , a Q.=== a' ] -selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> Q.UnicodeString -> [Maybe Q.UnicodeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property +selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> SafeString -> [Maybe SafeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property selectProp' pgc b i f t z d p s l r e a = Q.ioProperty $ do [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc - [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${Q.getUnicodeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap Q.getUnicodeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] + [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${getSafeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap getSafeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|] return $ Q.conjoin [ i Q.=== i' , b Q.=== b' - , Q.getUnicodeString s Q.=== s' + , getSafeString s Q.=== s' , f Q.=== f' , d Q.=== d' , t Q.=== t' , z Q.=== z' , p Q.=== p' - , map (fmap Q.getUnicodeString) l Q.=== l' + , map (fmap getSafeString) l Q.=== l' , Range.normalize' r Q.=== r' , e Q.=== e' , a Q.=== a' From f7a19b925a2877a902527c3a4cb134b6982fe807 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Sat, 19 Mar 2022 19:21:49 -0400 Subject: [PATCH 291/306] fixes for th 2.18 (ghc 9.2) --- Database/PostgreSQL/Typed/Enum.hs | 9 +++++++-- Database/PostgreSQL/Typed/Relation.hs | 21 +++++++++++++-------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/Database/PostgreSQL/Typed/Enum.hs b/Database/PostgreSQL/Typed/Enum.hs index 9881fa9..8bbec8f 100644 --- a/Database/PostgreSQL/Typed/Enum.hs +++ b/Database/PostgreSQL/Typed/Enum.hs @@ -111,11 +111,11 @@ dataPGEnum typs pgenum valnf = do [ tySynInstD ''PGRepType typt typl ] , instanceD [] (TH.ConT ''PGEnum `TH.AppT` typt) - [ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [TH.ConP n []] + [ TH.FunD 'pgEnumName $ map (\(n, l) -> TH.Clause [conP n []] (TH.NormalB $ namelit l) []) valn , TH.FunD 'pgEnumValue $ map (\(n, l) -> - TH.Clause [TH.ConP 'PGName [TH.ListP (map TH.LitP l)]] + TH.Clause [conP 'PGName [TH.ListP (map TH.LitP l)]] (TH.NormalB $ TH.ConE 'Just `TH.AppE` TH.ConE n) []) valn ++ [TH.Clause [TH.WildP] (TH.NormalB $ TH.ConE 'Nothing) []] @@ -143,3 +143,8 @@ dataPGEnum typs pgenum valnf = do #endif t namelit l = TH.ConE 'PGName `TH.AppE` TH.ListE (map TH.LitE l) + conP n p = TH.ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + p diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index 1f98205..932c2ce 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -86,7 +86,7 @@ dataPGRelation typs pgtab colf = do return (v, t, nn)) cold let typl = TH.LitT (TH.StrTyLit $ pgNameString pgid) - encfun f = TH.FunD f [TH.Clause [TH.WildP, TH.ConP typn (map (\(v, _, _) -> TH.VarP v) cols)] + encfun f = TH.FunD f [TH.Clause [TH.WildP, conP typn (map (\(v, _, _) -> TH.VarP v) cols)] (TH.NormalB $ pgcall f rect `TH.AppE` (TH.ConE 'PGRecord `TH.AppE` TH.ListE (map (colenc f) cols))) [] ] @@ -124,7 +124,7 @@ dataPGRelation typs pgtab colf = do [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] (TH.GuardedB [ (TH.PatG [TH.BindS - (TH.ConP 'PGRecord [TH.ListP $ map colpat cols]) + (conP 'PGRecord [TH.ListP $ map colpat cols]) (pgcall 'pgDecode rect `TH.AppE` TH.VarE dv)] , foldl (\f -> TH.AppE f . coldec) (TH.ConE typn) cols) , (TH.NormalG (TH.ConE 'True) @@ -137,7 +137,7 @@ dataPGRelation typs pgtab colf = do [ TH.FunD 'pgDecode [TH.Clause [TH.WildP, TH.VarP dv] (TH.GuardedB [ (TH.PatG [TH.BindS - (TH.ConP 'PGRecord [TH.ListP $ map colpat cols]) + (conP 'PGRecord [TH.ListP $ map colpat cols]) (pgcall 'pgDecode rect `TH.AppE` TH.VarE dv)] , TH.ConE 'Just `TH.AppE` foldl (\f -> TH.AppE f . coldec) (TH.ConE typn) cols) , (TH.NormalG (TH.ConE 'True) @@ -145,13 +145,13 @@ dataPGRelation typs pgtab colf = do ]) [] ] , TH.FunD 'pgDecodeValue - [ TH.Clause [TH.WildP, TH.WildP, TH.ConP 'PGNullValue []] + [ TH.Clause [TH.WildP, TH.WildP, conP 'PGNullValue []] (TH.NormalB $ TH.ConE 'Nothing) [] - , TH.Clause [TH.WildP, TH.VarP tv, TH.ConP 'PGTextValue [TH.VarP dv]] + , TH.Clause [TH.WildP, TH.VarP tv, conP 'PGTextValue [TH.VarP dv]] (TH.NormalB $ TH.VarE 'pgDecode `TH.AppE` TH.VarE tv `TH.AppE` TH.VarE dv) [] - , TH.Clause [TH.VarP ev, TH.VarP tv, TH.ConP 'PGBinaryValue [TH.VarP dv]] + , TH.Clause [TH.VarP ev, TH.VarP tv, conP 'PGBinaryValue [TH.VarP dv]] (TH.NormalB $ TH.VarE 'pgDecodeBinary `TH.AppE` TH.VarE ev `TH.AppE` TH.VarE tv `TH.AppE` TH.VarE dv) [] ] @@ -176,7 +176,7 @@ dataPGRelation typs pgtab colf = do (TH.ConT (TH.tupleTypeName (length cols))) cols `TH.AppT` typt , TH.FunD (TH.mkName ("uncurry" ++ typs)) - [ TH.Clause [TH.ConP (TH.tupleDataName (length cols)) (map (\(v, _, _) -> TH.VarP v) cols)] + [ TH.Clause [conP (TH.tupleDataName (length cols)) (map (\(v, _, _) -> TH.VarP v) cols)] (TH.NormalB $ foldl (\f (v, _, _) -> f `TH.AppE` TH.VarE v) (TH.ConE typn) cols) [] ] @@ -203,10 +203,15 @@ dataPGRelation typs pgtab colf = do (TH.ConT ''PGTypeID `TH.AppT` t)) colenc f (v, t, False) = TH.ConE 'Just `TH.AppE` (pgcall f t `TH.AppE` TH.VarE v) colenc f (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall f t `TH.AppE` TH.VarE v - colpat (v, _, False) = TH.ConP 'Just [TH.VarP v] + colpat (v, _, False) = conP 'Just [TH.VarP v] colpat (v, _, True) = TH.VarP v coldec (v, t, False) = pgcall 'pgDecode t `TH.AppE` TH.VarE v coldec (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall 'pgDecode t `TH.AppE` TH.VarE v rect = TH.LitT $ TH.StrTyLit "record" namelit n = TH.ConE 'PGName `TH.AppE` TH.ListE (map (TH.LitE . TH.IntegerL . fromIntegral) $ pgNameBytes n) + conP n p = TH.ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + p From 67d4a0793b09f76361c938b3ec2ff797290fa148 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 1 Jun 2022 19:42:13 -0400 Subject: [PATCH 292/306] More reading --- README.md | 89 +++++++++++++++++++++++++++++++++++++++++- postgresql-typed.cabal | 2 +- 2 files changed, 89 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 5c12911..ce9078d 100644 --- a/README.md +++ b/README.md @@ -3,4 +3,91 @@ A Haskell PostgreSQL interface that provides type-safety through compile-time (template Haskell) database access. See the [Haddock](http://hackage.haskell.org/package/postgresql-typed) documentation in [Database.PostgreSQL.Typed](http://hackage.haskell.org/package/postgresql-typed/docs/Database-PostgreSQL-Typed.html) or the [test cases](test/Main.hs) for simple examples. -[![Build Status](https://travis-ci.org/dylex/postgresql-typed.svg?branch=master)](https://travis-ci.org/dylex/postgresql-typed) +## Getting started + +### Installation + +Use your preferred package manager to install or add to your package dependencies: + +- `stack install postgresql-typed` or +- `cabal install postgresql-typed` + +### Enable ghc extensions + +Make sure you enable `TemplateHaskell` and `QuasiQuotes` language extensions, either in your cabal `default-extensions` or in a `{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}` pragma in your source. + +### Setup compile-time database connection + +Either set the following environment variables: + +- `TPG_DB` the database name to use (default: same as user) +- `TPG_USER` the username to connect as (default: `$USER` or `postgres`) +- `TPG_PASS` the password to use (default: *empty*) +- `TPG_HOST` the host to connect to (default: `localhost`) +- `TPG_PORT` or `TPG_SOCK` the port number or local socket path to connect on (default port: `5432`) + +*Or* in your code call `Database.PostgreSQL.Typed.useTPGDatabase` with a database config as a top-level quote in each code file where you have SQL queries. +It's often helpful to make your own utility function to do this: + +```haskell +-- |Call this at top-level at the beginning of every file (rather than 'useTPGDatabase') +useMyTPGConfig :: Language.Haskell.TH.DecsQ +useMyTPGConfig = useTPGDatabase PGDatabase{ ... } -- or load config from file +``` + +### Setup your database schema + +Your tables and other schema need to be created in your development (compile-time) database before you compile your code. +No queries will actually be executed, so there does not need to be any data, but it will do query parsing with the database (prepare queries) so any referenced objects must exist. + +### Setup run-time database connection + +Use `pgConnect` to connect to your database using a `PGDatabase` configuration. +The run-time database does not need to be the same as the build-time database (though it can be), but it *must* have the same schema. +It's recommended to use `bracket (pgConnect PGDatabase{..}) pgDisconnect`. +If you need a pool of connections, consider `resource-pool` (while `PGConnection`s are mostly thread-safe, they can't be used for multiple queries simultaneously). + +### Complete example + +DBConfig.hs: +```haskell +module DBConfig where + +import qualified Database.PostgreSQL.Typed as PG +import Network.Socket (SockAddr(SockAddrUnix)) + +myPGDatabase :: PG.PGDatabase +myPGDatabase = PG.defaultPGDatabase + { PG.pgDBAddr = Right (SockAddrUnix "/run/postgresql/.s.PGSQL.5432") + } +``` + +Main.hs: +```haskell +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +import Control.Exception (bracket) +import Control.Monad (unless) +import qualified Database.PostgreSQL.Typed as PG + +import DBConfig + +PG.useTPGDatabase myPGDatabase + +data Thing = Thing Int String + deriving (Eq) + +createThing :: PG.PGConnection -> Thing -> IO () +createThing pg (Thing tid tname) = + void $ PG.pgExecute pg [PG.pgSQL|INSERT INTO thing (id, name) VALUES (${tid}, ${tname})|] + +lookupThing :: PG.PGConnection -> Int -> IO (Maybe Thing) +lookupThing pg tid = fmap (uncurry Thing) . listToMaybe <$> + PG.pgQuery pg [PG.pgSQL|SELECT id, name FROM thing WHERE id = ${tid}|] + +main = bracket (PG.pgConnect myPGDatabase) PG.pgDisconnect $ \pg -> do + let myt = Thing 1 "cat" + createThing pg myt + t <- lookupThing 1 + unless (t == Just myt) $ fail "wrong thing!" +``` diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0b6f8e2..839ef72 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.2.0 +Version: 0.6.2.1 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING From 193e0d8d0fb35fcfc2805082e5c48e2c2fb08f53 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Wed, 1 Jun 2022 19:50:57 -0400 Subject: [PATCH 293/306] make an example that works! --- README.md | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index ce9078d..b1210c8 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ Use your preferred package manager to install or add to your package dependencie ### Enable ghc extensions -Make sure you enable `TemplateHaskell` and `QuasiQuotes` language extensions, either in your cabal `default-extensions` or in a `{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}` pragma in your source. +Make sure you enable `TemplateHaskell`, `QuasiQuotes`, and `DataKinds` language extensions, either in your cabal `default-extensions` or in a `{-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-}` pragma in your source. ### Setup compile-time database connection @@ -49,6 +49,11 @@ If you need a pool of connections, consider `resource-pool` (while `PGConnection ### Complete example +schema.sql: +```sql +CREATE TABLE thing (id SERIAL PRIMARY KEY, name TEXT NOT NULL); +``` + DBConfig.hs: ```haskell module DBConfig where @@ -64,30 +69,34 @@ myPGDatabase = PG.defaultPGDatabase Main.hs: ```haskell -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} import Control.Exception (bracket) -import Control.Monad (unless) +import Control.Monad (void, unless) +import Data.Int (Int32) +import Data.Maybe (listToMaybe) import qualified Database.PostgreSQL.Typed as PG import DBConfig PG.useTPGDatabase myPGDatabase -data Thing = Thing Int String +data Thing = Thing Int32 String deriving (Eq) createThing :: PG.PGConnection -> Thing -> IO () createThing pg (Thing tid tname) = void $ PG.pgExecute pg [PG.pgSQL|INSERT INTO thing (id, name) VALUES (${tid}, ${tname})|] -lookupThing :: PG.PGConnection -> Int -> IO (Maybe Thing) +lookupThing :: PG.PGConnection -> Int32 -> IO (Maybe Thing) lookupThing pg tid = fmap (uncurry Thing) . listToMaybe <$> PG.pgQuery pg [PG.pgSQL|SELECT id, name FROM thing WHERE id = ${tid}|] main = bracket (PG.pgConnect myPGDatabase) PG.pgDisconnect $ \pg -> do let myt = Thing 1 "cat" createThing pg myt - t <- lookupThing 1 + t <- lookupThing pg 1 unless (t == Just myt) $ fail "wrong thing!" ``` From 76755ef5a573fe61fcbd2c74941ca4f6b5789a43 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 2 Jun 2022 12:09:53 -0400 Subject: [PATCH 294/306] README: add tcp example --- README.md | 9 +++++++-- stack.yaml | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index b1210c8..9c17c9d 100644 --- a/README.md +++ b/README.md @@ -12,6 +12,8 @@ Use your preferred package manager to install or add to your package dependencie - `stack install postgresql-typed` or - `cabal install postgresql-typed` +You'll also likely need to add `network` as a dependency. + ### Enable ghc extensions Make sure you enable `TemplateHaskell`, `QuasiQuotes`, and `DataKinds` language extensions, either in your cabal `default-extensions` or in a `{-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-}` pragma in your source. @@ -56,6 +58,7 @@ CREATE TABLE thing (id SERIAL PRIMARY KEY, name TEXT NOT NULL); DBConfig.hs: ```haskell +{-# LANGUAGE OverloadedStrings #-} module DBConfig where import qualified Database.PostgreSQL.Typed as PG @@ -63,8 +66,10 @@ import Network.Socket (SockAddr(SockAddrUnix)) myPGDatabase :: PG.PGDatabase myPGDatabase = PG.defaultPGDatabase - { PG.pgDBAddr = Right (SockAddrUnix "/run/postgresql/.s.PGSQL.5432") - } + { PG.pgDBAddr = if tcp then Left ("localhost", "5432") else Right (SockAddrUnix "/run/postgresql/.s.PGSQL.5432") + , PG.pgDBUser = "user" + , PG.pgDBName = "db" + } where tcp = False ``` Main.hs: diff --git a/stack.yaml b/stack.yaml index 7cd1b9d..49aba77 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-17.7 +resolver: lts-18.28 packages: - '.' From 01edcc6c6c01b5a33e1e0dfe8d4055f006a898d6 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 21 Nov 2022 10:05:21 -0500 Subject: [PATCH 295/306] Relation: add some type annotations to help the compiler ghc-9.4 loops otherwise, though these should be easy... --- Database/PostgreSQL/Typed/Relation.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Relation.hs b/Database/PostgreSQL/Typed/Relation.hs index 932c2ce..41e3928 100644 --- a/Database/PostgreSQL/Typed/Relation.hs +++ b/Database/PostgreSQL/Typed/Relation.hs @@ -61,9 +61,9 @@ dataPGRelation :: String -- ^ Haskell type and constructor to create dataPGRelation typs pgtab colf = do (pgid, cold) <- TH.runIO $ withTPGTypeConnection $ \tpg -> do cl <- mapM (\[to, cn, ct, cnn] -> do - let c = pgDecodeRep cn + let c = pgDecodeRep cn :: PGName n = TH.mkName $ colf $ pgNameString c - o = pgDecodeRep ct + o = pgDecodeRep ct :: OID t <- maybe (fail $ "dataPGRelation " ++ typs ++ " = " ++ show pgtab ++ ": column '" ++ show c ++ "' has unknown type " ++ show o) return =<< lookupPGType tpg o return (pgDecodeRep to, (c, n, TH.LitT (TH.StrTyLit $ pgNameString t), not $ pgDecodeRep cnn))) From 87a1c42797487c75ce2a7c0724a3fa15f67c9dfb Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 21 Nov 2022 10:06:39 -0500 Subject: [PATCH 296/306] bump version 0.6.2.2 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 839ef72..009da78 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.2.1 +Version: 0.6.2.2 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING From 76f48c53c3861a8c4ecac5cdb626edcf04cd75e0 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 9 Jun 2023 11:34:35 -0400 Subject: [PATCH 297/306] add crypton flag to switch from cryptonite --- postgresql-typed.cabal | 16 ++++++++++++++-- stack.yaml | 2 +- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 009da78..a597fe5 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -58,6 +58,10 @@ Flag tls Description: Enable TLS (SSL) support in PostgreSQL server connections. Default: True +Flag crypton + Description: Use crypton rather than cryptonite. + Default: True + Library default-language: Haskell2010 Build-Depends: @@ -93,7 +97,11 @@ Library Database.PostgreSQL.Typed.TypeCache GHC-Options: -Wall if flag(md5) - Build-Depends: cryptonite >= 0.5, memory >= 0.5 + Build-Depends: memory >= 0.5 + if flag(crypton) + Build-Depends: crypton + else + Build-Depends: cryptonite >= 0.5 if flag(binary) Build-Depends: postgresql-binary >= 0.8, text >= 1, uuid >= 1.3, scientific >= 0.3 else @@ -110,7 +118,11 @@ Library Exposed-Modules: Database.PostgreSQL.Typed.HDBC if flag(tls) - Build-Depends: data-default, tls, x509, x509-store, x509-validation + Build-Depends: data-default, tls + if flag(crypton) + Build-Depends: crypton-x509, crypton-x509-store, crypton-x509-validation + else + Build-Depends: x509, x509-store, x509-validation test-suite test default-language: Haskell2010 diff --git a/stack.yaml b/stack.yaml index 49aba77..1df7966 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-18.28 +resolver: lts-19.33 packages: - '.' From 42d1bc6d30e3f1b73505ad490d35146eaf80c5c1 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 9 Jun 2023 11:40:46 -0400 Subject: [PATCH 298/306] set crypton false by default for now --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index a597fe5..793979f 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -60,7 +60,7 @@ Flag tls Flag crypton Description: Use crypton rather than cryptonite. - Default: True + Default: False Library default-language: Haskell2010 From 6e244f66adce40367252564c7b22a6a21aba94e5 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 22 Jun 2023 09:35:48 -0400 Subject: [PATCH 299/306] crypton: be explicit about tls version deps --- postgresql-typed.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 793979f..a1bdc76 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -118,11 +118,11 @@ Library Exposed-Modules: Database.PostgreSQL.Typed.HDBC if flag(tls) - Build-Depends: data-default, tls + Build-Depends: data-default if flag(crypton) - Build-Depends: crypton-x509, crypton-x509-store, crypton-x509-validation + Build-Depends: tls >= 1.7, crypton-x509, crypton-x509-store, crypton-x509-validation else - Build-Depends: x509, x509-store, x509-validation + Build-Depends: tls < 1.7, x509, x509-store, x509-validation test-suite test default-language: Haskell2010 From 5f87301eec9fc0b138f607e9b1fd929e7bd67105 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Fri, 23 Jun 2023 12:15:51 -0400 Subject: [PATCH 300/306] enable crypton by default; bump release --- postgresql-typed.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index a1bdc76..2d5eeb8 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.2.2 +Version: 0.6.2.3 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING @@ -60,7 +60,7 @@ Flag tls Flag crypton Description: Use crypton rather than cryptonite. - Default: False + Default: True Library default-language: Haskell2010 From 396fbacc859a622a3064161a7a7b36a984f5ff17 Mon Sep 17 00:00:00 2001 From: Kamek Date: Mon, 3 Jul 2023 14:31:05 -0400 Subject: [PATCH 301/306] fix CPP for crypton --- Database/PostgreSQL/Typed/Protocol.hs | 6 +++--- postgresql-typed.cabal | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index c2d3d8b..b0277a1 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -73,7 +73,7 @@ import Control.Exception (Exception, onException, finally, throwIO) import Control.Exception (catch) #endif import Control.Monad (void, liftM2, replicateM, when, unless) -#ifdef VERSION_cryptonite +#if defined(VERSION_cryptonite) || defined(VERSION_crypton) import qualified Crypto.Hash as Hash import qualified Data.ByteArray.Encoding as BA #endif @@ -413,7 +413,7 @@ pgConnectionDatabase = connDatabase pgTypeEnv :: PGConnection -> PGTypeEnv pgTypeEnv = connTypeEnv -#ifdef VERSION_cryptonite +#if defined(VERSION_cryptonite) || defined(VERSION_crypton) md5 :: BS.ByteString -> BS.ByteString md5 = BA.convertToBase BA.Base16 . (Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5) #endif @@ -728,7 +728,7 @@ pgConnect db = do pgSend c $ PasswordMessage $ pgDBPass db pgFlush c conn c -#ifdef VERSION_cryptonite +#if defined(VERSION_cryptonite) || defined(VERSION_crypton) msg c (Left (AuthenticationMD5Password salt)) = do pgSend c $ PasswordMessage $ "md5" `BS.append` md5 (md5 (pgDBPass db <> pgDBUser db) `BS.append` salt) pgFlush c diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 2d5eeb8..6a72085 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -112,7 +112,7 @@ Library if flag(scientific) Build-Depends: scientific >= 0.3 if flag(aeson) - Build-Depends: aeson >= 0.7 + Build-Depends: aeson >= 0.7 && < 2.2 if flag(HDBC) Build-Depends: HDBC >= 2.2 Exposed-Modules: From 2dbb9eaa57b104bc1f4213c788e5fd85ac02aa01 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 3 Jul 2023 15:19:50 -0400 Subject: [PATCH 302/306] bump version --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 6a72085..0df27dc 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.2.3 +Version: 0.6.2.4 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING From 0bd320217c645538996641f4674fed3f62f27660 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Mon, 11 Sep 2023 11:28:48 -0400 Subject: [PATCH 303/306] aeson: don't assume attoparsec, just use decode I think it was this way because aeson didn't have appropriate functions back then, but it's possible postgres has trailing data that had to be ignored -- needs better testing. --- Database/PostgreSQL/Typed/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/PostgreSQL/Typed/Types.hs b/Database/PostgreSQL/Typed/Types.hs index f5c8edc..3e738af 100644 --- a/Database/PostgreSQL/Typed/Types.hs +++ b/Database/PostgreSQL/Typed/Types.hs @@ -800,7 +800,7 @@ instance PGParameter "json" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode BIN_ENC(BinE.json_ast) instance PGColumn "json" JSON.Value where - pgDecode _ j = either (error . ("pgDecode json (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j + pgDecode _ j = either (error . ("pgDecode json (" ++) . (++ ("): " ++ BSC.unpack j))) id $ JSON.eitherDecodeStrict j BIN_DEC(BinD.json_ast) instance PGType "jsonb" where @@ -810,7 +810,7 @@ instance PGParameter "jsonb" JSON.Value where pgEncode _ = BSL.toStrict . JSON.encode BIN_ENC(BinE.jsonb_ast) instance PGColumn "jsonb" JSON.Value where - pgDecode _ j = either (error . ("pgDecode jsonb (" ++) . (++ ("): " ++ BSC.unpack j))) id $ P.parseOnly JSON.json j + pgDecode _ j = either (error . ("pgDecode jsonb (" ++) . (++ ("): " ++ BSC.unpack j))) id $ JSON.eitherDecodeStrict j BIN_DEC(BinD.jsonb_ast) #endif From e6489490e304f81fdd1f6ec6d17f8cda04c700e8 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 9 Nov 2023 18:47:00 -0500 Subject: [PATCH 304/306] bump aeson dep upper bound --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index 0df27dc..e4214d9 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -112,7 +112,7 @@ Library if flag(scientific) Build-Depends: scientific >= 0.3 if flag(aeson) - Build-Depends: aeson >= 0.7 && < 2.2 + Build-Depends: aeson >= 0.7 && < 2.3 if flag(HDBC) Build-Depends: HDBC >= 2.2 Exposed-Modules: From 96aab04bc3c207ef606ed9cf0096f5543b519720 Mon Sep 17 00:00:00 2001 From: Dylan Simon Date: Thu, 9 Nov 2023 18:48:28 -0500 Subject: [PATCH 305/306] 0.6.2.5 --- postgresql-typed.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/postgresql-typed.cabal b/postgresql-typed.cabal index e4214d9..07fd076 100644 --- a/postgresql-typed.cabal +++ b/postgresql-typed.cabal @@ -1,5 +1,5 @@ Name: postgresql-typed -Version: 0.6.2.4 +Version: 0.6.2.5 Cabal-Version: >= 1.10 License: BSD3 License-File: COPYING From c3649451b22e324a3ba3a5af161562ee3032610f Mon Sep 17 00:00:00 2001 From: Kamek Date: Fri, 15 Mar 2024 12:36:50 -0400 Subject: [PATCH 306/306] TLS: restore EMS, add client params --- Database/PostgreSQL/Typed/Protocol.hs | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/Database/PostgreSQL/Typed/Protocol.hs b/Database/PostgreSQL/Typed/Protocol.hs index b0277a1..5e548e6 100644 --- a/Database/PostgreSQL/Typed/Protocol.hs +++ b/Database/PostgreSQL/Typed/Protocol.hs @@ -186,12 +186,13 @@ data PGDatabase = PGDatabase , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@) #ifdef VERSION_tls , pgDBTLS :: PGTlsMode -- ^ TLS mode + , pgDBTLSParams :: Maybe TLS.ClientParams -- ^ TLS client params #endif } deriving (Show) instance Eq PGDatabase where #ifdef VERSION_tls - PGDatabase a1 n1 u1 p1 l1 _ _ s1 == PGDatabase a2 n2 u2 p2 l2 _ _ s2 = + PGDatabase a1 n1 u1 p1 l1 _ _ s1 _ == PGDatabase a2 n2 u2 p2 l2 _ _ s2 _ = a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 == s2 #else PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ = @@ -394,6 +395,7 @@ defaultPGDatabase = PGDatabase , pgDBLogMessage = defaultLogMessage #ifdef VERSION_tls , pgDBTLS = TlsDisabled + , pgDBTLSParams = Nothing #endif } @@ -754,12 +756,20 @@ mkPGHandle db sock = pure $ PGTlsContext ctx "N" -> throwIO (userError "Server does not support TLS") _ -> throwIO (userError "Unexpected response from server when issuing SSLRequest") - params = (TLS.defaultParamsClient tlsHost tlsPort) - { TLS.clientSupported = - def { TLS.supportedCiphers = TLS.ciphersuite_strong } - , TLS.clientShared = clientShared - , TLS.clientHooks = clientHooks - } + params = + case pgDBTLSParams db of + Nothing -> (TLS.defaultParamsClient tlsHost tlsPort) + { TLS.clientSupported = + def + { TLS.supportedCiphers = TLS.ciphersuite_strong +#if MIN_VERSION_tls(2,0,0) + , TLS.supportedExtendedMainSecret = TLS.AllowEMS +#endif + } + , TLS.clientShared = clientShared + , TLS.clientHooks = clientHooks + } + Just userParams -> userParams { TLS.clientShared = clientShared, TLS.clientHooks = clientHooks } tlsHost = case pgDBAddr db of Left (h,_) -> h Right (Net.SockAddrUnix s) -> s