postgresql-typed 0.5.3.0 → 0.6.2.5
raw patch · 14 files changed
Files
- Database/PostgreSQL/Typed/Enum.hs +16/−4
- Database/PostgreSQL/Typed/ErrCodes.hs +128/−1
- Database/PostgreSQL/Typed/Inet.hs +12/−11
- Database/PostgreSQL/Typed/Protocol.hs +274/−45
- Database/PostgreSQL/Typed/Query.hs +22/−5
- Database/PostgreSQL/Typed/Relation.hs +24/−12
- Database/PostgreSQL/Typed/TH.hs +40/−19
- Database/PostgreSQL/Typed/TemplatePG.hs +35/−9
- Database/PostgreSQL/Typed/Types.hs +5/−3
- README.md +107/−0
- postgresql-typed.cabal +50/−8
- test/Bench.hs +42/−0
- test/Connect.hs +52/−11
- test/Main.hs +64/−22
Database/PostgreSQL/Typed/Enum.hs view
@@ -91,7 +91,7 @@ #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,14 +108,14 @@ []] ] , 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 []]+ [ 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) []]@@ -135,4 +135,16 @@ #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif+ tySynInstD c l t = TH.TySynInstD+#if MIN_VERSION_template_haskell(2,15,0)+ $ TH.TySynEqn Nothing (TH.AppT (TH.ConT c) l)+#else+ c $ TH.TySynEqn [l]+#endif+ t namelit l = TH.ConE 'PGName `TH.AppE` TH.ListE (map TH.LitE l)+ conP n p = TH.ConP n+#if MIN_VERSION_template_haskell(2,18,0)+ []+#endif+ p
Database/PostgreSQL/Typed/ErrCodes.hs view
@@ -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-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@@ -72,6 +72,7 @@ , 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 @@ , 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@@ -99,6 +101,21 @@ , 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@@ -121,6 +138,7 @@ , 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 +202,7 @@ , collation_mismatch , indeterminate_collation , wrong_object_type+ , generated_always , undefined_column , _UNDEFINED_CURSOR , _UNDEFINED_DATABASE@@ -233,6 +252,7 @@ , object_in_use , cant_change_runtime_param , lock_not_available+ , unsafe_new_enum_value_usage -- * Class 57 - Operator Intervention , operator_intervention , query_canceled@@ -245,6 +265,8 @@ , 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 +533,10 @@ 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 +581,10 @@ 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"@@ -619,6 +649,66 @@ 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"@@ -695,6 +785,10 @@ 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 +985,10 @@ 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"@@ -1071,6 +1169,10 @@ 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"@@ -1111,6 +1213,10 @@ 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 +1414,7 @@ ,(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 +1423,7 @@ ,(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")@@ -1338,6 +1446,21 @@ ,(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")@@ -1363,6 +1486,7 @@ ,(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 +1544,7 @@ ,(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")@@ -1457,6 +1582,7 @@ ,(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")@@ -1467,6 +1593,7 @@ ,(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")
Database/PostgreSQL/Typed/Inet.hs view
@@ -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 @@ 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)
Database/PostgreSQL/Typed/Protocol.hs view
@@ -2,8 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno@@ -18,6 +19,10 @@ , defaultPGDatabase , PGConnection , PGError(..)+#ifdef VERSION_tls+ , PGTlsMode(..)+ , PGTlsValidateMode (..)+#endif , pgErrorCode , pgConnectionDatabase , pgTypeEnv@@ -50,17 +55,25 @@ , pgFetch -- * Notifications , PGNotification(..)- , pgGetNotifications , pgGetNotification+ , pgGetNotifications+#ifdef VERSION_tls+ -- * TLS Helpers+ , pgTlsValidate+#endif+ , pgSupportsTls ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$)) #endif import Control.Arrow ((&&&), first, second)-import Control.Exception (Exception, throwIO, onException, finally)+import Control.Exception (Exception, onException, finally, throwIO)+#ifdef VERSION_tls+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@@ -68,10 +81,13 @@ 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)+#ifdef VERSION_tls+import Data.Default (def)+#endif import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef') import Data.Int (Int32, Int16)@@ -81,17 +97,37 @@ #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif+import Data.Time.Clock (getCurrentTime) import Data.Tuple (swap) import Data.Typeable (Typeable) #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif-import Data.Word (Word32)-import Network (HostName, PortID(..), connectTo)-import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering))-import System.IO.Error (mkIOError, eofErrorType, ioError)+import Data.Word (Word32, Word8)+#ifdef VERSION_tls+import Data.X509 (SignedCertificate, HashALG(HashSHA256))+import Data.X509.Memory (readSignedObjectFromMemory)+import Data.X509.CertificateStore (makeCertificateStore)+import qualified Data.X509.Validation+#endif+#ifndef mingw32_HOST_OS+import Foreign.C.Error (eWOULDBLOCK, getErrno, errnoToIOError)+import Foreign.C.Types (CChar(..), CInt(..), CSize(..))+import Foreign.Ptr (Ptr, castPtr)+import GHC.IO.Exception (IOErrorType(InvalidArgument))+#endif+import qualified Network.Socket as Net+import qualified Network.Socket.ByteString as NetBS+import qualified Network.Socket.ByteString.Lazy as NetBSL+#ifdef VERSION_tls+import qualified Network.TLS as TLS+import qualified Network.TLS.Extra.Cipher as TLS+#endif+import System.IO (stderr, hPutStrLn)+import System.IO.Error (IOError, mkIOError, eofErrorType, ioError, ioeSetErrorString) import System.IO.Unsafe (unsafeInterleaveIO) import Text.Read (readMaybe)+import Text.Show.Functions () import Database.PostgreSQL.Typed.Types import Database.PostgreSQL.Typed.Dynamic@@ -107,20 +143,60 @@ | StateClosed deriving (Show, Eq) +#ifdef VERSION_tls+data PGTlsValidateMode+ = TlsValidateFull+ -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQHN against the+ -- certicate's CN+ | TlsValidateCA+ -- ^ Equivalent to sslmode=verify-ca. Ie: Only check that the certificate has+ -- been signed by the root certificate we provide+ deriving (Show, Eq)++data PGTlsMode+ = TlsDisabled+ -- ^ TLS is disabled+ | TlsNoValidate+ | TlsValidate PGTlsValidateMode SignedCertificate+ deriving (Eq, Show)++-- | Constructs a 'PGTlsMode' to validate the server certificate with given root+-- certificate (in PEM format)+pgTlsValidate :: PGTlsValidateMode -> BSC.ByteString -> Either String PGTlsMode+pgTlsValidate mode certPem =+ case readSignedObjectFromMemory certPem of+ [] -> Left "Could not parse any certificate in PEM"+ (x:_) -> Right (TlsValidate mode x)++pgSupportsTls :: PGConnection -> Bool+pgSupportsTls PGConnection{connHandle=PGTlsContext _} = True+pgSupportsTls _ = False+#else+pgSupportsTls :: PGConnection -> Bool+pgSupportsTls _ = False+#endif+ -- |Information for how to connect to a database, to be passed to 'pgConnect'. data PGDatabase = PGDatabase- { 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")) , pgDBDebug :: Bool -- ^ Log all low-level server messages , pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@)- }+#ifdef VERSION_tls+ , pgDBTLS :: PGTlsMode -- ^ TLS mode+#endif+ } deriving (Show) 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+#ifdef VERSION_tls+ PGDatabase a1 n1 u1 p1 l1 _ _ s1 == PGDatabase a2 n2 u2 p2 l2 _ _ s2 =+ a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2 && s1 == s2+#else+ PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ =+ a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2+#endif newtype PGPreparedStatement = PGPreparedStatement Integer deriving (Eq, Show)@@ -128,10 +204,48 @@ preparedStatementName :: PGPreparedStatement -> BS.ByteString preparedStatementName (PGPreparedStatement n) = BSC.pack $ show n +data PGHandle+ = PGSocket Net.Socket+#ifdef VERSION_tls+ | PGTlsContext TLS.Context+#endif++pgPutBuilder :: PGHandle -> B.Builder -> IO ()+pgPutBuilder (PGSocket s) b = NetBSL.sendAll s (B.toLazyByteString b)+#ifdef VERSION_tls+pgPutBuilder (PGTlsContext c) b = TLS.sendData c (B.toLazyByteString b)+#endif++pgPut:: PGHandle -> BS.ByteString -> IO ()+pgPut (PGSocket s) bs = NetBS.sendAll s bs+#ifdef VERSION_tls+pgPut (PGTlsContext c) bs = TLS.sendData c (BSL.fromChunks [bs])+#endif++pgGetSome :: PGHandle -> Int -> IO BSC.ByteString+pgGetSome (PGSocket s) count = NetBS.recv s count+#ifdef VERSION_tls+pgGetSome (PGTlsContext c) _ = TLS.recvData c+#endif++pgCloseHandle :: PGHandle -> IO ()+pgCloseHandle (PGSocket s) = Net.close s+#ifdef VERSION_tls+pgCloseHandle (PGTlsContext c) = do+ TLS.bye c `catch` \(_ :: IOError) -> pure ()+ TLS.contextClose c+#endif++pgFlush :: PGConnection -> IO ()+pgFlush PGConnection{connHandle=PGSocket _} = pure ()+#ifdef VERSION_tls+pgFlush PGConnection{connHandle=PGTlsContext c} = TLS.contextFlush c+#endif+ -- |An established connection to the PostgreSQL server. -- These objects are not thread-safe and must only be used for a single request at a time. data PGConnection = PGConnection- { connHandle :: Handle+ { connHandle :: PGHandle , connDatabase :: !PGDatabase , connPid :: !Word32 -- unused , connKey :: !Word32 -- unused@@ -178,9 +292,6 @@ 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 <http://www.postgresql.org/docs/current/interactive/protocol-message-formats.html>. data PGFrontendMessage@@ -274,18 +385,22 @@ -- 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 , pgDBParams = [] , pgDBDebug = False , pgDBLogMessage = defaultLogMessage+#ifdef VERSION_tls+ , pgDBTLS = TlsDisabled+#endif } -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@@ -298,7 +413,7 @@ 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@@ -360,9 +475,9 @@ 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+ connDebugMsg c $ "> " ++ show msg+ pgPutBuilder h $ Fold.foldMap B.char7 t <> B.word32BE (fromIntegral $ 4 + BS.length b)+ pgPut h b -- or B.hPutBuilder? But we've already had to convert to BS to get length where (t, b) = second (BSL.toStrict . B.toLazyByteString) $ messageBody msg state _ StateClosed = StateClosed@@ -371,10 +486,7 @@ state Terminate _ = StateClosed state _ _ = StateUnsync -pgFlush :: PGConnection -> IO ()-pgFlush = hFlush . connHandle - getByteStringNul :: G.Get BS.ByteString getByteStringNul = fmap BSL.toStrict G.getLazyByteStringNul @@ -452,13 +564,13 @@ -- |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@@ -480,11 +592,20 @@ -- |Process all pending messages data RecvNonBlock = RecvNonBlock deriving (Show) instance RecvMsg RecvNonBlock where- recvMsgData c = do- r <- BS.hGetNonBlocking (connHandle c) smallChunkSize+#ifndef mingw32_HOST_OS+ recvMsgData PGConnection{connHandle=PGSocket s} = do+ r <- recvNonBlock s smallChunkSize if BS.null r then return (Left RecvNonBlock) else return (Right r)+#else+ recvMsgData PGConnection{connHandle=PGSocket _} =+ throwIO (userError "Non-blocking recvMsgData is not supported on mingw32 ATM")+#endif+#ifdef VERSION_tls+ recvMsgData PGConnection{connHandle=PGTlsContext _} =+ throwIO (userError "Non-blocking recvMsgData is not supported on TLS connections")+#endif -- |Wait for ReadyForQuery data RecvSync = RecvSync deriving (Show)@@ -515,7 +636,7 @@ -- 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 >>=@@ -552,10 +673,20 @@ input <- newIORef getMessage tr <- newIORef 0 notif <- newIORef emptyQueue- h <- connectTo (pgDBHost db) (pgDBPort db)- hSetBuffering h (BlockBuffering Nothing)+ addr <- either+ (\(h,p) -> head <$> Net.getAddrInfo (Just defai) (Just h) (Just p))+ (\a -> return defai{ Net.addrAddress = a, Net.addrFamily = case a of+ Net.SockAddrInet{} -> Net.AF_INET+ Net.SockAddrInet6{} -> Net.AF_INET6+ Net.SockAddrUnix{} -> Net.AF_UNIX+ _ -> Net.AF_UNSPEC })+ $ pgDBAddr db+ sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr)+ unless (Net.addrFamily addr == Net.AF_UNIX) $ Net.setSocketOption sock Net.NoDelay 1+ Net.connect sock $ Net.addrAddress addr+ pgHandle <- mkPGHandle db sock let c = PGConnection- { connHandle = h+ { connHandle = pgHandle , connDatabase = db , connPid = 0 , connKey = 0@@ -576,10 +707,12 @@ , ("bytea_output", "hex") , ("DateStyle", "ISO, YMD") , ("IntervalStyle", "iso_8601")+ , ("extra_float_digits", "3") ] ++ pgDBParams db pgFlush c conn c where+ defai = Net.defaultHints{ Net.addrSocketType = Net.Stream } conn c = pgRecv c >>= msg c msg c (Right RecvSync) = do cp <- readIORef (connParameters c)@@ -595,7 +728,7 @@ 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@@ -603,11 +736,61 @@ #endif msg _ (Left m) = fail $ "pgConnect: unexpected response: " ++ show m +mkPGHandle :: PGDatabase -> Net.Socket -> IO PGHandle+#ifdef VERSION_tls+mkPGHandle db sock =+ case pgDBTLS db of+ TlsDisabled -> pure (PGSocket sock)+ TlsNoValidate -> mkTlsContext+ TlsValidate _ _ -> mkTlsContext+ where+ mkTlsContext = do+ NetBSL.sendAll sock sslRequest+ resp <- NetBS.recv sock 1+ case resp of+ "S" -> do+ ctx <- TLS.contextNew sock params+ void $ TLS.handshake ctx+ pure $ PGTlsContext ctx+ "N" -> throwIO (userError "Server does not support TLS")+ _ -> throwIO (userError "Unexpected response from server when issuing SSLRequest")+ params = (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)+#else+mkPGHandle _ sock = pure (PGSocket sock)+#endif+ -- |Disconnect cleanly from the PostgreSQL server. pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect' -> IO () pgDisconnect c@PGConnection{ connHandle = h } =- pgSend c Terminate `finally` 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'@@ -928,14 +1111,60 @@ res EmptyQueryResponse = return ([], Just 0) res m = fail $ "pgFetch: unexpected response: " ++ show m +-- |Retrieve a notifications, blocking if necessary.+pgGetNotification :: PGConnection -> IO PGNotification+pgGetNotification c =+ maybe (pgRecv c) return+ =<< atomicModifyIORef' (connNotifications c) deQueue+ -- |Retrieve any pending notifications. Non-blocking. pgGetNotifications :: PGConnection -> IO [PGNotification] pgGetNotifications c = do RecvNonBlock <- pgRecv c queueToList <$> atomicModifyIORef' (connNotifications c) (emptyQueue, )+ where+ queueToList :: Queue a -> [a]+ queueToList (Queue e d) = d ++ reverse e --- |Retrieve a notifications, blocking if necessary.-pgGetNotification :: PGConnection -> IO PGNotification-pgGetNotification c =- maybe (pgRecv c) return- =<< atomicModifyIORef' (connNotifications c) deQueue++--TODO: Implement non-blocking recv on mingw32+#ifndef mingw32_HOST_OS+recvNonBlock+ :: Net.Socket -- ^ Connected socket+ -> Int -- ^ Maximum number of bytes to receive+ -> IO BS.ByteString -- ^ Data received+recvNonBlock s nbytes+ | nbytes < 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.Protocol.recvNonBlock")+ | otherwise = createAndTrim nbytes $ \ptr -> recvBufNonBlock s ptr nbytes++recvBufNonBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int+recvBufNonBlock s ptr nbytes+ | nbytes <= 0 = ioError (mkInvalidRecvArgError "Database.PostgreSQL.Typed.recvBufNonBlock")+ | otherwise = do+ len <-+#if MIN_VERSION_network(3,1,0)+ Net.withFdSocket s $ \fd ->+#elif MIN_VERSION_network(3,0,0)+ Net.fdSocket s >>= \fd ->+#else+ let fd = Net.fdSocket s in+#endif+ c_recv fd (castPtr ptr) (fromIntegral nbytes) 0+ if len == -1+ then do+ errno <- getErrno+ if errno == eWOULDBLOCK+ then return 0+ else throwIO (errnoToIOError "recvBufNonBlock" errno Nothing (Just "Database.PostgreSQL.Typed"))+ else+ return $ fromIntegral len++mkInvalidRecvArgError :: String -> IOError+mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError+ InvalidArgument+ loc Nothing Nothing) "non-positive length"+++foreign import ccall unsafe "recv"+ c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt+#endif
Database/PostgreSQL/Typed/Query.hs view
@@ -25,6 +25,8 @@ 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)@@ -52,6 +54,7 @@ -- -- > [pgSQL|SELECT a FROM t|] `unsafeModifyQuery` (<> (" WHERE a = " <> pgSafeLiteral x)) unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q+ getQueryString :: PGTypeEnv -> q -> BS.ByteString class PGQuery q PGValues => PGRawQuery q -- |Execute a query that does not return results.@@ -66,12 +69,14 @@ 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 +84,7 @@ 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 +92,7 @@ instance PGRawQuery q => PGQuery (QueryParser q a) a where pgRunQuery c (QueryParser q p) = second (fmap $ p e) <$> pgRunQuery c (q e) where e = pgTypeEnv c unsafeModifyQuery (QueryParser q p) f = QueryParser (\e -> unsafeModifyQuery (q e) f) p+ getQueryString e (QueryParser q _) = getQueryString e $ q e instance Functor (QueryParser q) where fmap f (QueryParser q p) = QueryParser q (\e -> f . p e)@@ -143,7 +150,7 @@ | 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@@ -180,10 +187,11 @@ 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"+ l <- TH.newName "l" (vars, vals) <- mapAndUnzipM (\t -> do v <- newName 'p' $ tpgValueName t return @@ -202,7 +210,7 @@ (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 @@ -213,7 +221,16 @@ #endif ) prep)- `TH.AppE` TH.LamE [TH.VarP e, 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 $ case conv of+ [x] -> x+ _ -> TH.TupE+#if MIN_VERSION_template_haskell(2,16,0)+ $ map Just+#endif+ conv) []+ , TH.Match TH.WildP (TH.NormalB $ TH.VarE 'error `TH.AppE` TH.LitE (TH.StringL "pgSQL: result arity mismatch")) []+ ])) <$> mapM parse exprs where (sqlp, exprs) = sqlPlaceholders sqle@@ -240,7 +257,7 @@ 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 []
Database/PostgreSQL/Typed/Relation.hs view
@@ -61,9 +61,9 @@ 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)))@@ -86,7 +86,7 @@ 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))) [] ]@@ -114,7 +114,7 @@ ] [] , 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@@ -124,7 +124,7 @@ [ 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 @@ [ 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,20 +145,20 @@ ]) [] ] , 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) [] ] ] #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)@@ -176,7 +176,7 @@ (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) [] ]@@ -191,15 +191,27 @@ #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif+ tySynInstD c l t = TH.TySynInstD+#if MIN_VERSION_template_haskell(2,15,0)+ $ TH.TySynEqn Nothing (TH.AppT (TH.ConT c) l)+#else+ c $ TH.TySynEqn [l]+#endif+ t pgcall f t = TH.VarE f `TH.AppE` (TH.ConE 'PGTypeProxy `TH.SigE` (TH.ConT ''PGTypeID `TH.AppT` t)) colenc f (v, t, False) = TH.ConE 'Just `TH.AppE` (pgcall f t `TH.AppE` TH.VarE v) colenc f (v, t, True) = TH.VarE 'fmap `TH.AppE` pgcall f t `TH.AppE` TH.VarE v- colpat (v, _, False) = 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
Database/PostgreSQL/Typed/TH.hs view
@@ -20,27 +20,29 @@ ) 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)+#ifdef VERSION_tls+import Control.Exception (throwIO)+#endif+import Control.Monad (liftM2) import qualified Data.ByteString as BS+#ifdef VERSION_tls+import qualified Data.ByteString.Char8 as BSC+#endif import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BSU import qualified Data.Foldable as Fold-import Data.Maybe (isJust, fromMaybe)-import Data.String (fromString)+import 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,21 +55,40 @@ 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"+#ifdef VERSION_tls+ tlsEnabled <- isJust <$> lookupEnv "TPG_TLS"+ tlsVerifyMode <- lookupEnv "TPG_TLS_MODE" >>= \modeStr ->+ case modeStr of+ Just "full" -> pure TlsValidateFull+ Just "ca" -> pure TlsValidateCA+ Just other -> throwIO (userError ("Unknown verify mode: " ++ other))+ Nothing -> pure TlsValidateCA+ mTlsCertPem <- lookupEnv "TPG_TLS_ROOT_CERT"+ dbTls <- case mTlsCertPem of+ Just certPem ->+ case pgTlsValidate tlsVerifyMode (BSC.pack certPem) of+ Right x -> pure x+ Left err -> throwIO (userError err)+ Nothing | tlsEnabled -> pure TlsNoValidate+ Nothing -> pure TlsDisabled+#endif return $ defaultPGDatabase- { pgDBHost = host- , pgDBPort = port+ { pgDBAddr = either (Right . Net.SockAddrUnix) (Left . (,) host) port , pgDBName = BSU.fromString db , pgDBUser = BSU.fromString user , pgDBPass = BSU.fromString pass , pgDBDebug = debug+#ifdef VERSION_tls+ , pgDBTLS = dbTls+#endif } {-# NOINLINE tpgState #-}
Database/PostgreSQL/Typed/TemplatePG.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- Copyright 2010, 2011, 2012, 2013 Chris Forno -- |This module exposes the high-level Template Haskell interface for querying@@ -19,18 +21,28 @@ , rollback , PGException , pgConnect+#if !MIN_VERSION_network(2,7,0)+ , PortID(..)+#endif , PG.pgDisconnect ) where -import Control.Exception (catchJust)-import Control.Monad (liftM, void, guard)-import Data.ByteString (ByteString)+import 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)+#if MIN_VERSION_network(2,7,0)+import Data.Word (Word16)+#else+import Network (PortID(..))+#endif+#if !defined(mingw32_HOST_OS)+import qualified Network.Socket as Net+#endif+import System.Environment (lookupEnv) import qualified Database.PostgreSQL.Typed.Protocol as PG import Database.PostgreSQL.Typed.Query@@ -89,7 +101,17 @@ type PGException = PG.PGError -pgConnect :: HostName -- ^ the host to connect to+#if MIN_VERSION_network(2,7,0)+-- |For backwards compatibility with old network package.+data PortID+ = Service String+ | PortNumber Word16+#if !defined(mingw32_HOST_OS)+ | UnixSocket String+#endif+#endif++pgConnect :: String -- ^ the host to connect to -> PortID -- ^ the port to connect on -> ByteString -- ^ the database to connect to -> ByteString -- ^ the username to connect as@@ -98,8 +120,12 @@ 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)+#if !defined(mingw32_HOST_OS)+ UnixSocket s -> Right (Net.SockAddrUnix s)+#endif , PG.pgDBName = d , PG.pgDBUser = u , PG.pgDBPass = p
Database/PostgreSQL/Typed/Types.hs view
@@ -232,7 +232,9 @@ -- |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@@ -798,7 +800,7 @@ 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@@ -808,7 +810,7 @@ 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
+ README.md view
@@ -0,0 +1,107 @@+# Haskell PostgreSQL-typed++A Haskell PostgreSQL interface that provides type-safety through compile-time (template Haskell) database access.+See the [Haddock](http://hackage.haskell.org/package/postgresql-typed) documentation in [Database.PostgreSQL.Typed](http://hackage.haskell.org/package/postgresql-typed/docs/Database-PostgreSQL-Typed.html) or the [test cases](test/Main.hs) for simple examples.++## Getting started++### Installation++Use your preferred package manager to install or add to your package dependencies:++- `stack install postgresql-typed` or+- `cabal install postgresql-typed`++You'll also likely need to add `network` as a dependency.++### Enable ghc extensions++Make sure you enable `TemplateHaskell`, `QuasiQuotes`, and `DataKinds` language extensions, either in your cabal `default-extensions` or in a `{-# LANGUAGE TemplateHaskell, QuasiQuotes, DataKinds #-}` pragma in your source.++### Setup compile-time database connection++Either set the following environment variables:++- `TPG_DB` the database name to use (default: same as user)+- `TPG_USER` the username to connect as (default: `$USER` or `postgres`)+- `TPG_PASS` the password to use (default: *empty*)+- `TPG_HOST` the host to connect to (default: `localhost`)+- `TPG_PORT` or `TPG_SOCK` the port number or local socket path to connect on (default port: `5432`)++*Or* in your code call `Database.PostgreSQL.Typed.useTPGDatabase` with a database config as a top-level quote in each code file where you have SQL queries.+It's often helpful to make your own utility function to do this:++```haskell+-- |Call this at top-level at the beginning of every file (rather than 'useTPGDatabase')+useMyTPGConfig :: Language.Haskell.TH.DecsQ+useMyTPGConfig = useTPGDatabase PGDatabase{ ... } -- or load config from file+```++### Setup your database schema++Your tables and other schema need to be created in your development (compile-time) database before you compile your code.+No queries will actually be executed, so there does not need to be any data, but it will do query parsing with the database (prepare queries) so any referenced objects must exist.++### Setup run-time database connection++Use `pgConnect` to connect to your database using a `PGDatabase` configuration.+The run-time database does not need to be the same as the build-time database (though it can be), but it *must* have the same schema.+It's recommended to use `bracket (pgConnect PGDatabase{..}) pgDisconnect`.+If you need a pool of connections, consider `resource-pool` (while `PGConnection`s are mostly thread-safe, they can't be used for multiple queries simultaneously).++### Complete example++schema.sql:+```sql+CREATE TABLE thing (id SERIAL PRIMARY KEY, name TEXT NOT NULL);+```++DBConfig.hs:+```haskell+{-# LANGUAGE OverloadedStrings #-}+module DBConfig where++import qualified Database.PostgreSQL.Typed as PG+import Network.Socket (SockAddr(SockAddrUnix))++myPGDatabase :: PG.PGDatabase+myPGDatabase = PG.defaultPGDatabase+ { PG.pgDBAddr = if tcp then Left ("localhost", "5432") else Right (SockAddrUnix "/run/postgresql/.s.PGSQL.5432")+ , PG.pgDBUser = "user"+ , PG.pgDBName = "db"+ } where tcp = False+```++Main.hs:+```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Exception (bracket)+import Control.Monad (void, unless)+import Data.Int (Int32)+import Data.Maybe (listToMaybe)+import qualified Database.PostgreSQL.Typed as PG++import DBConfig++PG.useTPGDatabase myPGDatabase++data Thing = Thing Int32 String+ deriving (Eq)++createThing :: PG.PGConnection -> Thing -> IO ()+createThing pg (Thing tid tname) =+ void $ PG.pgExecute pg [PG.pgSQL|INSERT INTO thing (id, name) VALUES (${tid}, ${tname})|]++lookupThing :: PG.PGConnection -> Int32 -> IO (Maybe Thing)+lookupThing pg tid = fmap (uncurry Thing) . listToMaybe <$>+ PG.pgQuery pg [PG.pgSQL|SELECT id, name FROM thing WHERE id = ${tid}|]++main = bracket (PG.pgConnect myPGDatabase) PG.pgDisconnect $ \pg -> do+ let myt = Thing 1 "cat"+ createThing pg myt+ t <- lookupThing pg 1+ unless (t == Just myt) $ fail "wrong thing!"+```
postgresql-typed.cabal view
@@ -1,9 +1,9 @@ Name: postgresql-typed-Version: 0.5.3.0-Cabal-Version: >= 1.8+Version: 0.6.2.5+Cabal-Version: >= 1.10 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 <dylan-pgtyped@dylex.net> Stability: provisional@@ -21,6 +21,7 @@ Originally based on Chris Forno's templatepg library. Tested-With: GHC == 7.10.3, GHC == 8.0.1 Build-Type: Simple+extra-source-files: README.md source-repository head type: git@@ -53,7 +54,16 @@ Flag HDBC Description: Provide an HDBC driver backend using the raw PostgreSQL protocol. +Flag tls+ Description: Enable TLS (SSL) support in PostgreSQL server connections.+ Default: True++Flag crypton+ Description: Use crypton rather than cryptonite.+ Default: True+ Library+ default-language: Haskell2010 Build-Depends: base >= 4.8 && < 5, array,@@ -65,7 +75,7 @@ template-haskell, haskell-src-meta, network,- attoparsec >= 0.12 && < 0.14,+ attoparsec >= 0.12 && < 0.15, utf8-string Exposed-Modules: Database.PostgreSQL.Typed@@ -87,7 +97,11 @@ 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@@ -98,22 +112,32 @@ if flag(scientific) Build-Depends: scientific >= 0.3 if flag(aeson)- Build-Depends: aeson >= 0.7+ Build-Depends: aeson >= 0.7 && < 2.3 if flag(HDBC) Build-Depends: HDBC >= 2.2 Exposed-Modules: Database.PostgreSQL.Typed.HDBC+ if flag(tls)+ Build-Depends: data-default+ if flag(crypton)+ Build-Depends: tls >= 1.7, crypton-x509, crypton-x509-store, crypton-x509-validation+ else+ Build-Depends: tls < 1.7, x509, x509-store, x509-validation test-suite test+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs Other-Modules: Connect- 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@@ -127,6 +151,24 @@ 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+ if flag(tls)+ Build-Depends: tls++benchmark bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Bench.hs+ other-modules: Connect+ build-depends:+ base,+ bytestring,+ time,+ network,+ criterion,+ postgresql-typed+ if flag(tls)+ Build-Depends: tls
+ test/Bench.hs view
@@ -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+ ]
test/Connect.hs view
@@ -1,17 +1,58 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} module Connect where -import Database.PostgreSQL.Typed (PGDatabase(..), defaultPGDatabase)-import Network (PortID(UnixSocket))+#ifdef VERSION_tls+import Control.Exception (throwIO)+#endif+import qualified Data.ByteString.Char8 as BSC+import Data.Maybe (fromMaybe, isJust)+import Database.PostgreSQL.Typed (PGDatabase (..),+ defaultPGDatabase)+#ifdef VERSION_tls+import Database.PostgreSQL.Typed.Protocol (PGTlsMode (..),+ PGTlsValidateMode (..),+ pgTlsValidate)+#endif+import Network.Socket (SockAddr (SockAddrUnix))+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO) db :: PGDatabase-db = defaultPGDatabase- { pgDBName = "templatepg"+db = unsafePerformIO $ do+ mPort <- lookupEnv "PGPORT"+ pgDBAddr <- case mPort of+ Nothing -> #ifndef mingw32_HOST_OS- , pgDBPort = UnixSocket "/tmp/.s.PGSQL.5432"+ Right . SockAddrUnix . fromMaybe "/tmp/.s.PGSQL.5432" <$> lookupEnv "PGSOCK"+#else+ pure $ pgDBAddr defaultPGDatabase #endif- , pgDBUser = "templatepg"- -- , pgDBDebug = True- , pgDBParams = [("TimeZone", "UTC")]- }-+ Just port -> pure $ Left ("localhost", port)+#ifdef VERSION_tls+ pgDBTLS <- do+ enabled <- isJust <$> lookupEnv "PGTLS"+ validateFull <- isJust <$> lookupEnv "PGTLS_VALIDATEFULL"+ rootcert <- fmap BSC.pack <$> lookupEnv "PGTLS_ROOTCERT"+ case (enabled,validateFull,rootcert) of+ (False,_,_) -> pure TlsDisabled+ (True,False,Nothing) -> pure TlsNoValidate+ (True,True,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateFull cert+ (True,True,Nothing) -> throwIO $ userError "Need to pass the root certificate on the PGTLS_ROOTCERT environment variable to validate FQHN"+ (True,False,Just cert) -> either (throwIO . userError) pure $ pgTlsValidate TlsValidateCA cert+#endif+ pgDBPass <- maybe BSC.empty BSC.pack <$> lookupEnv "PG_PASS"+ pgDBDebug <- isJust <$> lookupEnv "PG_DEBUG"+ pure $ defaultPGDatabase+ { pgDBName = "templatepg"+ , pgDBUser = "templatepg"+ , pgDBParams = [("TimeZone", "UTC")]+ , pgDBDebug+#ifdef VERSION_tls+ , pgDBTLS+#endif+ , pgDBAddr+ , pgDBPass+ }+{-# NOINLINE db #-}
test/Main.hs view
@@ -1,11 +1,10 @@ {-# 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 import Control.Exception (try)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC+import Control.Monad (unless) import Data.Char (isDigit, toUpper) import Data.Int (Int32) import qualified Data.Time as Time@@ -17,6 +16,7 @@ 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@@ -36,7 +36,8 @@ -- 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 @@ 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@@ -82,15 +85,15 @@ , SQLExpr <$> Q.arbitrary , 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 (' ', '~')) +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]@@ -100,26 +103,60 @@ 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 -> 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, ${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 + [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'- , strString s Q.=== s'+ , getSafeString 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 getSafeString) l Q.=== l' , Range.normalize' r Q.=== r' , e Q.=== e' , a Q.=== a' ] +selectProp' :: PGConnection -> Bool -> Int32 -> Float -> Time.LocalTime -> Time.UTCTime -> Time.Day -> Time.DiffTime -> SafeString -> [Maybe SafeString] -> Range.Range Int32 -> MyEnum -> PGInet -> Q.Property+selectProp' pgc b i f t z d p s l r e a = Q.ioProperty $ do+ [(Just b', Just i', Just f', Just s', Just d', Just t', Just z', Just p', Just l', Just r', Just e', Just a')] <- pgQuery pgc+ [pgSQL|SELECT ${b}::bool, ${Just i}::int, ${f}::float4, ${getSafeString s}::varchar, ${Just d}::date, ${t}::timestamp, ${z}::timestamptz, ${p}::interval, ${map (fmap getSafeString) l}::text[], ${r}::int4range, ${e}::myenum, ${a}::inet|]+ return $ Q.conjoin+ [ i Q.=== i'+ , b Q.=== b'+ , getSafeString s Q.=== s'+ , f Q.=== f'+ , d Q.=== d'+ , t Q.=== t'+ , z Q.=== z'+ , p Q.=== p'+ , map (fmap getSafeString) l Q.=== l'+ , Range.normalize' r Q.=== r'+ , e Q.=== e'+ , a Q.=== a'+ ]++selectFoo :: PGConnection -> [MyFoo] -> Q.Property+selectFoo pgc l = Q.ioProperty $ do+ _ <- pgExecute pgc [pgSQL|TRUNCATE myfoo|]+ let loop [] = return ()+ loop [x] = do+ 1 <- pgExecute pgc [pgSQL|INSERT INTO myfoo (bar, adé) VALUES (${fooBar x}, ${fooAdé x})|]+ return ()+ loop (x:y:r) = do+ 1 <- pgExecute pgc [pgSQL|INSERT INTO myfoo (adé, bar) VALUES (${fooAdé x}, ${fooBar x})|]+ 1 <- pgExecute pgc [pgSQL|$INSERT INTO myfoo (adé, bar) VALUES (${fooAdé y}, ${fooBar y})|]+ loop r+ loop l+ r <- pgQuery pgc [pgSQL|SELECT * FROM myfoo ORDER BY id|]+ return $ l Q.=== map (\(i,a,b) -> MyFoo i a b) r+ tokenProp :: String -> Q.Property tokenProp s = not (has0 s) Q.==> s Q.=== show (sqlTokens s) where@@ -133,8 +170,11 @@ r <- Q.quickCheckResult $ selectProp c+ Q..&&. selectProp' c+ Q..&&. selectFoo c Q..&&. tokenProp Q..&&. [pgSQL|#abc ${3.14::Float} def $f$ $$ ${1} $f$${2::Int32}|] Q.=== "abc 3.14::real def $f$ $$ ${1} $f$2::integer"+ Q..&&. getQueryString (pgTypeEnv c) ([pgSQL|SELECT ${"ab'cd"::String}::text, ${3.14::Float}::float4|] :: PGSimpleQuery (Maybe String, Maybe Float)) Q.=== "SELECT 'ab''cd'::text, 3.14::float4" Q..&&. pgEnumValues Q.=== [(MyEnum_abc, "abc"), (MyEnum_DEF, "DEF"), (MyEnum_XX_ye, "XX_ye")] Q..&&. Q.conjoin (map (\(s, t) -> sqlTokens s Q.=== t) [ ("",@@ -171,8 +211,10 @@ 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