postgresql-typed 0.5.3.0 → 0.6
raw patch · 11 files changed
+496/−98 lines, 11 filesdep +criteriondep +data-defaultdep +tlsdep ~basedep ~bytestringdep ~network
Dependencies added: criterion, data-default, tls, x509, x509-store, x509-validation
Dependency ranges changed: base, bytestring, network
Files
- Database/PostgreSQL/Typed/ErrCodes.hs +32/−1
- Database/PostgreSQL/Typed/Inet.hs +12/−11
- Database/PostgreSQL/Typed/Protocol.hs +260/−41
- Database/PostgreSQL/Typed/Query.hs +5/−1
- Database/PostgreSQL/Typed/TH.hs +40/−19
- Database/PostgreSQL/Typed/TemplatePG.hs +12/−8
- README.md +6/−0
- postgresql-typed.cabal +29/−3
- test/Bench.hs +42/−0
- test/Connect.hs +52/−11
- test/Main.hs +6/−3
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-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 @@ , 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@@ -121,6 +123,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 +187,7 @@ , collation_mismatch , indeterminate_collation , wrong_object_type+ , generated_always , undefined_column , _UNDEFINED_CURSOR , _UNDEFINED_DATABASE@@ -245,6 +249,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 +517,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 +565,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"@@ -695,6 +709,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 +909,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"@@ -1111,6 +1133,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 +1334,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 +1343,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")@@ -1363,6 +1391,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 +1449,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")@@ -1467,6 +1497,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,15 +55,23 @@ , 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 import qualified Crypto.Hash as Hash@@ -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,15 +97,34 @@ #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) @@ -107,20 +142,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 } 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 +203,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 +291,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 +384,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@@ -360,9 +474,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 +485,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 +563,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 +591,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 +635,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 +672,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@@ -580,6 +710,7 @@ 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)@@ -603,11 +734,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 +1109,52 @@ 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 <- c_recv (Net.fdSocket s) (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
@@ -184,6 +184,7 @@ 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 @@ #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 $ 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
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,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 @@ , 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 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
+ README.md view
@@ -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.++[](https://travis-ci.org/dylex/postgresql-typed)
postgresql-typed.cabal view
@@ -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 <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,6 +54,10 @@ 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+ Library Build-Depends: base >= 4.8 && < 5,@@ -103,6 +108,8 @@ Build-Depends: HDBC >= 2.2 Exposed-Modules: Database.PostgreSQL.Typed.HDBC+ if flag(tls)+ Build-Depends: data-default, tls, x509, x509-store, x509-validation test-suite test type: exitcode-stdio-1.0@@ -112,6 +119,8 @@ Extensions: TemplateHaskell, QuasiQuotes build-depends: base, network, time, bytestring, postgresql-typed, QuickCheck GHC-Options: -Wall+ if flag(tls)+ Build-Depends: tls test-suite hdbc type: exitcode-stdio-1.0@@ -127,6 +136,23 @@ 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+ 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,9 +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 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 @@ 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