postgresql-simple-0.5.1.2/0000755000000000000000000000000012633616517013547 5ustar0000000000000000postgresql-simple-0.5.1.2/postgresql-simple.cabal0000644000000000000000000000657612633616517020243 0ustar0000000000000000Name: postgresql-simple Version: 0.5.1.2 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. License: BSD3 License-file: LICENSE Author: Bryan O'Sullivan, Leon P Smith Maintainer: Leon P Smith Copyright: (c) 2011 MailRank, Inc. (c) 2011-2015 Leon P Smith Category: Database Build-type: Simple Cabal-version: >= 1.9.2 extra-source-files: CONTRIBUTORS Library hs-source-dirs: src Exposed-modules: Database.PostgreSQL.Simple Database.PostgreSQL.Simple.Arrays Database.PostgreSQL.Simple.Copy Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow Database.PostgreSQL.Simple.LargeObjects Database.PostgreSQL.Simple.HStore Database.PostgreSQL.Simple.HStore.Internal Database.PostgreSQL.Simple.Notification Database.PostgreSQL.Simple.Ok Database.PostgreSQL.Simple.Range Database.PostgreSQL.Simple.SqlQQ Database.PostgreSQL.Simple.Time Database.PostgreSQL.Simple.Time.Internal Database.PostgreSQL.Simple.ToField Database.PostgreSQL.Simple.ToRow Database.PostgreSQL.Simple.Transaction Database.PostgreSQL.Simple.TypeInfo Database.PostgreSQL.Simple.TypeInfo.Macro Database.PostgreSQL.Simple.TypeInfo.Static Database.PostgreSQL.Simple.Types Database.PostgreSQL.Simple.Errors -- Other-modules: Database.PostgreSQL.Simple.Internal Other-modules: Database.PostgreSQL.Simple.Compat Database.PostgreSQL.Simple.HStore.Implementation Database.PostgreSQL.Simple.Time.Implementation Database.PostgreSQL.Simple.Time.Internal.Parser Database.PostgreSQL.Simple.Time.Internal.Printer Database.PostgreSQL.Simple.TypeInfo.Types Build-depends: aeson >= 0.6, attoparsec >= 0.10.3, base >= 4.4 && < 5, bytestring >= 0.9, bytestring-builder, case-insensitive, containers, hashable, postgresql-libpq >= 0.9 && < 0.10, template-haskell, text >= 0.11.1, time, transformers, uuid-types >= 1.0.0, scientific, vector if !impl(ghc >= 7.6) Build-depends: ghc-prim extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns TypeOperators ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git location: http://github.com/lpsmith/postgresql-simple source-repository this type: git location: http://github.com/lpsmith/postgresql-simple tag: v0.5.1.2 test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: Common Notify Serializable Time ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind extensions: NamedFieldPuns , OverloadedStrings , Rank2Types , RecordWildCards , PatternGuards , ScopedTypeVariables build-depends: base , aeson , base16-bytestring , bytestring , containers , cryptohash , HUnit , postgresql-simple , text , time , vector if !impl(ghc >= 7.6) build-depends: ghc-prim postgresql-simple-0.5.1.2/CONTRIBUTORS0000644000000000000000000000221112633616517015423 0ustar0000000000000000Bryan O'Sullivan Leon P Smith Felipe Lessa Ozgun Ataman Joey Adams Rekado Leonid Onokhov Bas van Dijk Jason Dusek Jeff Chu Oliver Charles Simon Meier Alexey Uimanov Doug Beardsley Manuel Gómez Michael Snoyman Adam Bergmark Tobias Florek Francesco Mazzoli Chris Allen Simon Hengel Tom Ellis Mike Ledger João Cristóvão Bardur Arantsson Travis Staton Sam Rijs Janne Hellsten Timmy Tofu Alexey Khudyakov Timo von Holtz Amit Levy postgresql-simple-0.5.1.2/LICENSE0000644000000000000000000000565312633616517014565 0ustar0000000000000000Copyright (c) 2011, Leon P Smith All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Leon P Smith nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Copyright (c) 2011, MailRank, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. postgresql-simple-0.5.1.2/Setup.hs0000644000000000000000000000005612633616517015204 0ustar0000000000000000import Distribution.Simple main = defaultMain postgresql-simple-0.5.1.2/test/0000755000000000000000000000000012633616517014526 5ustar0000000000000000postgresql-simple-0.5.1.2/test/Serializable.hs0000644000000000000000000000445312633616517017476 0ustar0000000000000000module Serializable (testSerializable) where import Common import Control.Concurrent import Control.Exception as E import Data.IORef import Database.PostgreSQL.Simple.Transaction initCounter :: Connection -> IO () initCounter conn = do 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\ \ CREATE TABLE testSerializableCounter (n INT)" 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)" return () getCounter :: Connection -> IO Int getCounter conn = do [Only n] <- query_ conn "SELECT n FROM testSerializableCounter" return n putCounter :: Connection -> Int -> IO () putCounter conn n = do 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n) return () testSerializable :: TestEnv -> Test testSerializable TestEnv{..} = TestCase $ withConn $ \conn2 -> do initCounter conn attemptCounter <- newIORef (0 :: Int) readyToBother <- newEmptyMVar bothered <- newEmptyMVar finished <- newEmptyMVar _ <- forkIO $ do withTransactionSerializable conn2 $ do modifyIORef attemptCounter (+1) n <- getCounter conn2 True <- tryPutMVar readyToBother () readMVar bothered putCounter conn2 (n+1) putMVar finished () takeMVar readyToBother withTransactionSerializable conn $ do n <- getCounter conn putCounter conn (n+1) True <- tryPutMVar bothered () takeMVar finished ac <- readIORef attemptCounter assertEqual "attemptCounter" 2 ac ok <- E.catch (do withTransactionSerializable conn (fail "Whoops") return False) (\(_ :: IOException) -> return True) assertBool "Exceptions (besides serialization failure) should be\ \ propagated through withTransactionSerializable" ok -- Make sure transaction isn't dangling 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345" 0 <- execute_ conn "ROLLBACK" -- This prints "NOTICE: there is no transaction in progress" [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter" return () postgresql-simple-0.5.1.2/test/Notify.hs0000644000000000000000000000222512633616517016333 0ustar0000000000000000module Notify (testNotify) where import Common import Control.Applicative import Control.Concurrent import Control.Monad import Data.Function import Data.List import Database.PostgreSQL.Simple.Notification import qualified Data.ByteString as B -- TODO: Test with payload, but only for PostgreSQL >= 9.0 -- (when that feature was introduced). testNotify :: TestEnv -> Test testNotify TestEnv{..} = TestCase $ withConn $ \conn2 -> do execute_ conn "LISTEN foo" execute_ conn "LISTEN bar" results_mv <- newEmptyMVar forkIO $ replicateM 2 (getNotification conn) >>= putMVar results_mv threadDelay 100000 execute_ conn2 "NOTIFY foo" execute_ conn2 "NOTIFY bar" [n1, n2] <- sortBy (compare `on` notificationChannel) <$> takeMVar results_mv assertEqual "n1" "bar" (notificationChannel n1) assertEqual "n2" "foo" (notificationChannel n2) -- Other sanity checks assertEqual "Server PIDs match" (notificationPid n1) (notificationPid n2) assertBool "notificationData is empty" $ all (B.null . notificationData) [n1, n2] postgresql-simple-0.5.1.2/test/Time.hs0000644000000000000000000001033712633616517015764 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {- Testing strategies: fromString . toString == id ** Todo? toString . fromString == almost id ** Todo? postgresql -> haskell -> postgresql * Done haskell -> postgresql -> haskell ** Todo? But still, what we really want to establish is that the two values correspond; for example, a conversion that consistently added hour when printed to a string and subtracted an hour when parsed from string would still pass these tests. Right now, we are checking that 1400+ timestamps in the range of 1860 to 2060 round trip from postgresql to haskell and back in 5 different timezones. In addition to UTC, the four timezones were selected so that 2 have a positive offset, and 2 have a negative offset, and that 2 have an offset of a whole number of hours, while the other two do not. It may be worth adding a few more timezones to ensure better test coverage. We are checking a handful of selected timestamps to ensure we hit various corner-cases in the code, in addition to 1400 timestamps randomly generated with granularity of seconds down to microseconds in powers of ten. -} module Time (testTime) where import Common import Control.Monad(forM_, replicateM_) import Data.Time import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.SqlQQ numTests :: Int numTests = 200 testTime :: TestEnv -> Test testTime env@TestEnv{..} = TestCase $ do initializeTable env execute_ conn "SET timezone TO 'UTC'" checkRoundTrips env "1860-01-01 00:00:00+00" execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00 checkRoundTrips env "1883-11-18 12:00:00-06" execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00 checkRoundTrips env "1888-01-01 00:00:00+09" execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45 checkRoundTrips env "1919-12-31 23:48:44+05:30" execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30 checkRoundTrips env "1935-03-30 00:00:52-03:30" initializeTable :: TestEnv -> IO () initializeTable TestEnv{..} = withTransaction conn $ do execute_ conn [sql| CREATE TEMPORARY TABLE testtime ( x serial, y timestamptz, PRIMARY KEY(x) ) |] let test :: ByteString -> IO () = \x -> do execute conn [sql| INSERT INTO testtime (y) VALUES (?) |] (Only x) return () -- America/Chicago test "1883-11-18 11:59:59-05:50:36" test "1883-11-18 12:09:23-05:50:36" test "1883-11-18 12:00:00-06" -- Asia/Tokyo test "1887-12-31 23:59:59+09:18:59" test "1888-01-01 00:18:58+09:18:59" test "1888-01-01 00:00:00+09" -- Asia/Kathmandu test "1919-12-31 23:59:59+05:41:16" test "1919-12-31 23:48:44+05:30" test "1985-12-31 23:59:59+05:30" test "1986-01-01 00:15:00+05:45" -- America/St_Johns test "1935-03-29 23:59:59-03:30:52" test "1935-03-30 00:00:52-03:30" -- While the above special cases are probably a decent start, there -- are probably more that are well worth adding to ensure better -- coverage. let pop :: ByteString -> Double -> IO () = \x y -> replicateM_ numTests $ execute conn [sql| INSERT INTO testtime (y) VALUES ('1860-01-01 00:00:00+00'::timestamptz + ?::interval * ROUND(RANDOM() * ?)) |] (x,y) pop "1 microsecond" 6.3113904e15 pop "10 microseconds" 6.3113904e14 pop "100 microseconds" 6.3113904e13 pop "1 millisecond" 6.3113904e12 pop "10 milliseconds" 6.3113904e11 pop "100 milliseconds" 6.3113904e10 pop "1 second" 6.3113904e9 checkRoundTrips :: TestEnv -> ByteString -> IO () checkRoundTrips TestEnv{..} limit = do yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |] forM_ yxs $ \yx -> do res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx assertBool "UTCTime did not round-trip from SQL to Haskell and back" $ res == [Only True] yxs :: [(ZonedTime, Int)] <- query conn [sql| SELECT y, x FROM testtime WHERE y > ? |] (Only limit) forM_ yxs $ \yx -> do res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $ res == [Only True] postgresql-simple-0.5.1.2/test/Main.hs0000644000000000000000000003441112633616517015751 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} import Common import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.Types(Query(..),Values(..)) import Database.PostgreSQL.Simple.HStore import Database.PostgreSQL.Simple.Copy import qualified Database.PostgreSQL.Simple.Transaction as ST import Control.Applicative import Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import Data.IORef import Data.Typeable import qualified Data.ByteString as B import Data.Map (Map) import Data.List (sort) import qualified Data.Map as Map import Data.Text(Text) import qualified Data.Text.Encoding as T import System.Exit (exitFailure) import System.IO import qualified Data.Vector as V import Data.Aeson import GHC.Generics (Generic) import Notify import Serializable import Time tests :: [TestEnv -> Test] tests = [ TestLabel "Bytea" . testBytea , TestLabel "ExecuteMany" . testExecuteMany , TestLabel "Fold" . testFold , TestLabel "Notify" . testNotify , TestLabel "Serializable" . testSerializable , TestLabel "Time" . testTime , TestLabel "Array" . testArray , TestLabel "HStore" . testHStore , TestLabel "JSON" . testJSON , TestLabel "Savepoint" . testSavepoint , TestLabel "Unicode" . testUnicode , TestLabel "Values" . testValues , TestLabel "Copy" . testCopy , TestLabel "Double" . testDouble , TestLabel "1-ary generic" . testGeneric1 , TestLabel "2-ary generic" . testGeneric2 , TestLabel "3-ary generic" . testGeneric3 ] testBytea :: TestEnv -> Test testBytea TestEnv{..} = TestList [ testStr "empty" [] , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) , testStr "ascending" [0..255] , testStr "descending" [255,254..0] , testStr "ascending, doubled up" $ doubleUp [0..255] , testStr "descending, doubled up" $ doubleUp [255,254..0] ] where testStr label bytes = TestLabel label $ TestCase $ do let bs = B.pack bytes [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs] assertBool "SQL -> Haskell conversion altered the string" $ bs == r doubleUp = concatMap (\x -> [x, x]) testExecuteMany :: TestEnv -> Test testExecuteMany TestEnv{..} = TestCase $ do execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" let rows :: [(Int, String, Binary ByteString)] rows = [ (1, "hello", Binary "bye") , (2, "world", Binary "\0\r\t\n") , (3, "?", Binary "") ] count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows count @?= fromIntegral (length rows) rows' <- query_ conn "SELECT * FROM tmp_executeMany" rows' @?= rows return () testFold :: TestEnv -> Test testFold TestEnv{..} = TestCase $ do xs <- fold_ conn "SELECT generate_series(1,10000)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..10000] :: [Int]) ref <- newIORef [] forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b" (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do xs <- readIORef ref writeIORef ref $! (a,b):xs xs <- readIORef ref reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]] -- Make sure fold propagates our exception. ref <- newIORef [] True <- expectError (== TestException) $ forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) -> if a == 5 then do -- Cause a SQL error to trip up CLOSE. True <- expectError isSyntaxError $ execute_ conn "asdf" True <- expectError ST.isFailedTransactionError $ (query_ conn "SELECT 1" :: IO [(Only Int)]) throwIO TestException else do xs <- readIORef ref writeIORef ref $! (a :: Int) : xs xs <- readIORef ref reverse xs @?= [1..4] withTransaction conn $ replicateM_ 2 $ do xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..5] :: [Int]) ref <- newIORef [] forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) -> forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do xs <- readIORef ref writeIORef ref $! (a :: Int, b :: Int) : xs xs <- readIORef ref reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]] xs <- fold_ conn "SELECT 1 WHERE FALSE" [] $ \xs (Only x) -> return (x:xs) xs @?= ([] :: [Int]) -- TODO: add more complete tests, e.g.: -- -- * Fold in a transaction -- -- * Fold in a transaction after a previous fold has been performed -- -- * Nested fold return () queryFailure :: forall a. (FromField a, Typeable a, Show a) => Connection -> Query -> a -> Assertion queryFailure conn q resultType = do x :: Either SomeException [Only a] <- E.try $ query_ conn q case x of Left _ -> return () Right val -> assertFailure ("Did not fail as expected: " ++ show q ++ " :: " ++ show (typeOf resultType) ++ " -> " ++ show val) testArray :: TestEnv -> Test testArray TestEnv{..} = TestCase $ do xs <- query_ conn "SELECT '{1,2,3,4}'::_int4" xs @?= [Only (V.fromList [1,2,3,4 :: Int])] xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4" xs @?= [Only (V.fromList [V.fromList [1,2], V.fromList [3,4 :: Int]])] queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) testHStore :: TestEnv -> Test testHStore TestEnv{..} = TestCase $ do execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore" roundTrip [] roundTrip [("foo","bar"),("bar","baz"),("baz","hello")] roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] where roundTrip :: [(Text,Text)] -> Assertion roundTrip xs = do let m = Only (HStoreMap (Map.fromList xs)) m' <- query conn "SELECT ?::hstore" m [m] @?= m' testJSON :: TestEnv -> Test testJSON TestEnv{..} = TestCase $ do roundTrip (Map.fromList [] :: Map Text Text) roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text) roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text) roundTrip (V.fromList [1,2,3,4,5::Int]) roundTrip ("foo" :: Text) roundTrip (42 :: Int) where roundTrip :: ToJSON a => a -> Assertion roundTrip a = do let js = Only (toJSON a) js' <- query conn "SELECT ?::json" js [js] @?= js' testSavepoint :: TestEnv -> Test testSavepoint TestEnv{..} = TestCase $ do True <- expectError ST.isNoActiveTransactionError $ withSavepoint conn $ return () let getRows :: IO [Int] getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a" withTransaction conn $ do execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)" execute_ conn "INSERT INTO tmp_savepoint VALUES (1)" [1] <- getRows withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" [1,2] <- getRows return () [1,2] <- getRows withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" [1,2,3] <- getRows True <- expectError isUniqueViolation $ execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" True <- expectError ST.isFailedTransactionError getRows -- Body returning successfully after handling error, -- but 'withSavepoint' will roll back without complaining. return () -- Rolling back clears the error condition. [1,2] <- getRows -- 'withSavepoint' will roll back after an exception, even if the -- exception wasn't SQL-related. True <- expectError (== TestException) $ withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" [1,2,3] <- getRows throwIO TestException [1,2] <- getRows -- Nested savepoint can be rolled back while the -- outer effects are retained. withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" True <- expectError isUniqueViolation $ withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" [1,2,3,4] <- getRows execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" [1,2,3] <- getRows return () [1,2,3] <- getRows return () -- Transaction committed successfully, even though there were errors -- (but we rolled them back). [1,2,3] <- getRows return () testUnicode :: TestEnv -> Test testUnicode TestEnv{..} = TestCase $ do let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure -- the table gets created correctly. let messages = map Only ["привет","мир"] :: [Only Text] execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)") executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages messages' <- query_ conn "SELECT сообщение FROM ру́сский" sort messages @?= sort messages' testValues :: TestEnv -> Test testValues TestEnv{..} = TestCase $ do execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)" test (Values ["int4","text"] []) test (Values ["int4","text"] [(1,"hello")]) test (Values ["int4","text"] [(1,"hello"),(2,"world")]) test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")]) test (Values [] [(1,"hello")]) test (Values [] [(1,"hello"),(2,"world")]) test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")]) where test :: Values (Int, Text) -> Assertion test table@(Values _ vals) = do execute conn "INSERT INTO values_test ?" (Only table) vals' <- query_ conn "DELETE FROM values_test RETURNING *" sort vals @?= sort vals' testCopy :: TestEnv -> Test testCopy TestEnv{..} = TestCase $ do execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)" copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" mapM_ (putCopyData conn) copyRows putCopyEnd conn copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" mapM_ (putCopyData conn) abortRows putCopyError conn "aborted" -- Hmm, does postgres always produce \n as an end-of-line here, or -- are there cases where it will use a \r\n as well? copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)" rows <- loop [] sort rows @?= sort copyRows -- Now, let's just verify that the connection state is back to ready, -- so that we can issue more queries: [Only (x::Int)] <- query_ conn "SELECT 2 + 2" x @?= 4 where copyRows = ["1,foo\n" ,"2,bar\n"] abortRows = ["3,baz\n"] loop rows = do mrow <- getCopyData conn case mrow of CopyOutDone _ -> return rows CopyOutRow row -> loop (row:rows) testDouble :: TestEnv -> Test testDouble TestEnv{..} = TestCase $ do [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8" assertBool "expected NaN" (isNaN x) [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8" x @?= (1 / 0) [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8" x @?= (-1 / 0) testGeneric1 :: TestEnv -> Test testGeneric1 TestEnv{..} = TestCase $ do roundTrip conn (Gen1 123) where roundTrip conn x0 = do r <- query conn "SELECT ?::int" (x0 :: Gen1) r @?= [x0] testGeneric2 :: TestEnv -> Test testGeneric2 TestEnv{..} = TestCase $ do roundTrip conn (Gen2 123 "asdf") where roundTrip conn x0 = do r <- query conn "SELECT ?::int, ?::text" x0 r @?= [x0] testGeneric3 :: TestEnv -> Test testGeneric3 TestEnv{..} = TestCase $ do roundTrip conn (Gen3 123 "asdf" True) where roundTrip conn x0 = do r <- query conn "SELECT ?::int, ?::text, ?::bool" x0 r @?= [x0] data Gen1 = Gen1 Int deriving (Show,Eq,Generic) instance FromRow Gen1 instance ToRow Gen1 data Gen2 = Gen2 Int Text deriving (Show,Eq,Generic) instance FromRow Gen2 instance ToRow Gen2 data Gen3 = Gen3 Int Text Bool deriving (Show,Eq,Generic) instance FromRow Gen3 instance ToRow Gen3 data TestException = TestException deriving (Eq, Show, Typeable) instance Exception TestException expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool expectError p io = (io >> return False) `E.catch` \ex -> if p ex then return True else throwIO ex isUniqueViolation :: SqlError -> Bool isUniqueViolation SqlError{..} = sqlState == "23505" isSyntaxError :: SqlError -> Bool isSyntaxError SqlError{..} = sqlState == "42601" ------------------------------------------------------------------------ -- | Action for connecting to the database that will be used for testing. -- -- Note that some tests, such as Notify, use multiple connections, and assume -- that 'testConnect' connects to the same database every time it is called. testConnect :: IO Connection testConnect = connectPostgreSQL "" withTestEnv :: (TestEnv -> IO a) -> IO a withTestEnv cb = withConn $ \conn -> cb TestEnv { conn = conn , withConn = withConn } where withConn = bracket testConnect close main :: IO () main = do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] Counts{cases, tried, errors, failures} <- withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure postgresql-simple-0.5.1.2/test/Common.hs0000644000000000000000000000160512633616517016314 0ustar0000000000000000module Common ( module Database.PostgreSQL.Simple, module Test.HUnit, TestEnv(..), md5, ) where import Data.ByteString (ByteString) import Data.Text (Text) import Database.PostgreSQL.Simple import Test.HUnit import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString.Base16 as Base16 import qualified Data.Text.Encoding as TE data TestEnv = TestEnv { conn :: Connection -- ^ Connection shared by all the tests , withConn :: forall a. (Connection -> IO a) -> IO a -- ^ Bracket for spawning additional connections } -- | Return the MD5 hash of a 'ByteString', in lowercase hex format. -- -- Example: -- -- >[Only hash] <- query_ conn "SELECT md5('hi')" -- >assertEqual "md5('hi')" (md5 "hi") hash md5 :: ByteString -> Text md5 = TE.decodeUtf8 . Base16.encode . MD5.hash postgresql-simple-0.5.1.2/src/0000755000000000000000000000000012633616517014336 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/0000755000000000000000000000000012633616517016042 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/0000755000000000000000000000000012633616517020045 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple.hs-boot0000644000000000000000000000115712633616517022577 0ustar0000000000000000module Database.PostgreSQL.Simple ( Connection , Query , query , query_ , execute , execute_ , executeMany ) where import Data.Int(Int64) import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query_ :: FromRow r => Connection -> Query -> IO [r] execute :: ToRow q => Connection -> Query -> q -> IO Int64 executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple.hs0000644000000000000000000010761512633616517021644 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A mid-level client library for the PostgreSQL database, aimed at ease of -- use and high performance. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple ( -- * Writing queries -- $use -- ** The Query type -- $querytype -- ** Parameter substitution -- $subst -- *** Type inference -- $inference -- ** Substituting a single parameter -- $only_param -- ** Representing a list of values -- $in -- ** Modifying multiple rows at once -- $many -- ** @RETURNING@: modifications that return results -- $returning -- * Extracting results -- $result -- ** Handling null values -- $null -- ** Type conversions -- $types -- * Types Connection , Query , ToRow , FromRow , In(..) , Binary(..) , Only(..) , (:.)(..) -- ** Exceptions , SqlError(..) , PQ.ExecStatus(..) , FormatError(..) , QueryError(..) , ResultError(..) -- * Connection management , Base.connectPostgreSQL , Base.close , Base.connect , Base.ConnectInfo(..) , Base.defaultConnectInfo , Base.postgreSQLConnectionString -- * Queries that return results , query , query_ -- ** Queries taking parser as argument , queryWith , queryWith_ -- * Queries that stream results , FoldOptions(..) , FetchQuantity(..) , defaultFoldOptions , fold , foldWithOptions , fold_ , foldWithOptions_ , forEach , forEach_ , returning -- ** Queries that stream results taking a parser as an argument , foldWith , foldWithOptionsAndParser , foldWith_ , foldWithOptionsAndParser_ , forEachWith , forEachWith_ , returningWith -- * Statements that do not return results , execute , execute_ , executeMany -- , Base.insertID -- * Transaction handling , withTransaction , withSavepoint -- , Base.autocommit , begin , commit , rollback -- * Helper functions , formatMany , formatQuery ) where import Data.ByteString.Builder ( Builder, byteString, char8, intDec ) import Control.Applicative ((<$>)) import Control.Exception as E import Control.Monad (unless) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat) import Database.PostgreSQL.Simple.Compat ( (<>), toByteString ) import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.FromRow (FromRow(..)) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.ToField (Action(..)) import Database.PostgreSQL.Simple.ToRow (ToRow(..)) import Database.PostgreSQL.Simple.Types ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import Database.PostgreSQL.Simple.Internal as Base import Database.PostgreSQL.Simple.Transaction import Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Strict -- | Format a query string. -- -- This function is exposed to help with debugging and logging. Do not -- use it to prepare queries for execution. -- -- String parameters are escaped according to the character set in use -- on the 'Connection'. -- -- Throws 'FormatError' if the query string could not be formatted -- correctly. formatQuery :: ToRow q => Connection -> Query -> q -> IO ByteString formatQuery conn q@(Query template) qs | null xs && '?' `B.notElem` template = return template | otherwise = toByteString <$> buildQuery conn q template xs where xs = toRow qs -- | Format a query string with a variable number of rows. -- -- This function is exposed to help with debugging and logging. Do not -- use it to prepare queries for execution. -- -- The query string must contain exactly one substitution group, -- identified by the SQL keyword \"@VALUES@\" (case insensitive) -- followed by an \"@(@\" character, a series of one or more \"@?@\" -- characters separated by commas, and a \"@)@\" character. White -- space in a substitution group is permitted. -- -- Throws 'FormatError' if the query string could not be formatted -- correctly. formatMany :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString formatMany _ q [] = fmtError "no rows supplied" q [] formatMany conn q@(Query template) qs = do case parseTemplate template of Just (before, qbits, after) -> do bs <- mapM (buildQuery conn q qbits . toRow) qs return . toByteString . mconcat $ byteString before : intersperse (char8 ',') bs ++ [byteString after] Nothing -> fmtError "syntax error in multi-row template" q [] -- Split the input string into three pieces, @before@, @qbits@, and @after@, -- following this grammar: -- -- start: ^ before qbits after $ -- before: ([^?]* [^?\w])? 'VALUES' \s* -- qbits: '(' \s* '?' \s* (',' \s* '?' \s*)* ')' -- after: [^?]* -- -- \s: [ \t\n\r\f] -- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9] -- -- This would be much more concise with some sort of regex engine. -- 'formatMany' used to use pcre-light instead of this hand-written parser, -- but pcre is a hassle to install on Windows. parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString) parseTemplate template = -- Convert input string to uppercase, to facilitate searching. search $ B.map toUpper_ascii template where -- Search for the next occurrence of "VALUES" search bs = case B.breakSubstring "VALUES" bs of (x, y) -- If "VALUES" is not present in the string, or any '?' characters -- were encountered prior to it, fail. | B.null y || ('?' `B.elem` x) -> Nothing -- If "VALUES" is preceded by an identifier character (a.k.a. \w), -- try the next occurrence. | not (B.null x) && isIdent (B.last x) -> search $ B.drop 6 y -- Otherwise, we have a legitimate "VALUES" token. | otherwise -> parseQueryBits $ skipSpace $ B.drop 6 y -- Parse '(' \s* '?' \s* . If this doesn't match -- (and we don't consume a '?'), look for another "VALUES". -- -- qb points to the open paren (if present), meaning it points to the -- beginning of the "qbits" production described above. This is why we -- pass it down to finishQueryBits. parseQueryBits qb | Just ('(', skipSpace -> bs1) <- B.uncons qb , Just ('?', skipSpace -> bs2) <- B.uncons bs1 = finishQueryBits qb bs2 | otherwise = search qb -- Parse (',' \s* '?' \s*)* ')' [^?]* . -- -- Since we've already consumed at least one '?', there's no turning back. -- The parse has to succeed here, or the whole thing fails -- (because we don't allow '?' to appear outside of the VALUES list). finishQueryBits qb bs0 | Just (')', bs1) <- B.uncons bs0 = if '?' `B.elem` bs1 then Nothing else Just $ slice3 template qb bs1 | Just (',', skipSpace -> bs1) <- B.uncons bs0 , Just ('?', skipSpace -> bs2) <- B.uncons bs1 = finishQueryBits qb bs2 | otherwise = Nothing -- Slice a string into three pieces, given the start offset of the second -- and third pieces. Each "offset" is actually a tail of the uppercase -- version of the template string. Its length is used to infer the offset. -- -- It is important to note that we only slice the original template. -- We don't want our all-caps trick messing up the actual query string. slice3 source p1 p2 = (s1, s2, source'') where (s1, source') = B.splitAt (B.length source - B.length p1) source (s2, source'') = B.splitAt (B.length p1 - B.length p2) source' toUpper_ascii c | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) | otherwise = c -- Based on the definition of {ident_cont} in src/backend/parser/scan.l -- in the PostgreSQL source. No need to check [a-z], since we converted -- the whole string to uppercase. isIdent c = (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || (c >= '\x80' && c <= '\xFF') || c == '_' || c == '$' -- Based on {space} in scan.l isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r') skipSpace = B.dropWhile isSpace_ascii buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s = let (h,t) = B.break (=='?') s in byteString h : if B.null t then [] else split (B.tail t) zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps zipParams [t] [] = t zipParams _ _ = fmtError (show (B.count '?' template) ++ " '?' characters, but " ++ show (length xs) ++ " parameters") q xs -- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. -- -- Returns the number of rows affected. -- -- Throws 'FormatError' if the query could not be formatted correctly, or -- a 'SqlError' exception if the backend returns an error. execute :: (ToRow q) => Connection -> Query -> q -> IO Int64 execute conn template qs = do result <- exec conn =<< formatQuery conn template qs finishExecute conn template result -- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. -- -- Returns the number of rows affected. If the list of parameters is empty, -- this function will simply return 0 without issuing the query to the backend. -- If this is not desired, consider using the 'Values' constructor instead. -- -- Throws 'FormatError' if the query could not be formatted correctly, or -- a 'SqlError' exception if the backend returns an error. -- -- For example, here's a command that inserts two rows into a table -- with two columns: -- -- @ -- executeMany c [sql| -- INSERT INTO sometable VALUES (?,?) -- |] [(1, \"hello\"),(2, \"world\")] -- @ -- -- Here's an canonical example of a multi-row update command: -- -- @ -- executeMany c [sql| -- UPDATE sometable -- SET sometable.y = upd.y -- FROM (VALUES (?,?)) as upd(x,y) -- WHERE sometable.x = upd.x -- |] [(1, \"hello\"),(2, \"world\")] -- @ executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 executeMany _ _ [] = return 0 executeMany conn q qs = do result <- exec conn =<< formatMany conn q qs finishExecute conn q result -- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL -- query that accepts multi-row input and is expected to return results. -- Note that it is possible to write -- @'query' conn "INSERT ... RETURNING ..." ...@ -- in cases where you are only inserting a single row, and do not need -- functionality analogous to 'executeMany'. -- -- If the list of parameters is empty, this function will simply return @[]@ -- without issuing the query to the backend. If this is not desired, -- consider using the 'Values' constructor instead. -- -- Throws 'FormatError' if the query could not be formatted correctly. returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] returning = returningWith fromRow returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] returningWith _ _ _ [] = return [] returningWith parser conn q qs = do result <- exec conn =<< formatMany conn q qs finishQueryWith parser conn q result -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. All results are retrieved and converted before this -- function returns. -- -- When processing large results, this function will consume a lot of -- client-side memory. Consider using 'fold' instead. -- -- Exceptions that may be thrown: -- -- * 'FormatError': the query string could not be formatted correctly. -- -- * 'QueryError': the result contains no columns (i.e. you should be -- using 'execute' instead of 'query'). -- -- * 'ResultError': result conversion failed. -- -- * 'SqlError': the postgresql backend returned an error, e.g. -- a syntax or type error, or an incorrect table or column name. query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query = queryWith fromRow -- | A version of 'query' that does not perform query substitution. query_ :: (FromRow r) => Connection -> Query -> IO [r] query_ = queryWith_ fromRow -- | A version of 'query' taking parser as argument queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO [r] queryWith parser conn template qs = do result <- exec conn =<< formatQuery conn template qs finishQueryWith parser conn template result -- | A version of 'query_' taking parser as argument queryWith_ :: RowParser r -> Connection -> Query -> IO [r] queryWith_ parser conn q@(Query que) = do result <- exec conn que finishQueryWith parser conn q result -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. Results are streamed incrementally from the server, and -- consumed via a left fold. -- -- When dealing with small results, it may be simpler (and perhaps -- faster) to use 'query' instead. -- -- This fold is /not/ strict. The stream consumer is responsible for -- forcing the evaluation of its result to avoid space leaks. -- -- This is implemented using a database cursor. As such, this requires -- a transaction. This function will detect whether or not there is a -- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly' -- transaction if needed. The cursor is given a unique temporary name, -- so the consumer may itself call fold. -- -- Exceptions that may be thrown: -- -- * 'FormatError': the query string could not be formatted correctly. -- -- * 'QueryError': the result contains no columns (i.e. you should be -- using 'execute' instead of 'query'). -- -- * 'ResultError': result conversion failed. -- -- * 'SqlError': the postgresql backend returned an error, e.g. -- a syntax or type error, or an incorrect table or column name. fold :: ( FromRow row, ToRow params ) => Connection -> Query -> params -> a -> (a -> row -> IO a) -> IO a fold = foldWithOptions defaultFoldOptions -- | A version of 'fold' taking a parser as an argument foldWith :: ( ToRow params ) => RowParser row -> Connection -> Query -> params -> a -> (a -> row -> IO a) -> IO a foldWith = foldWithOptionsAndParser defaultFoldOptions -- | Number of rows to fetch at a time. 'Automatic' currently defaults -- to 256 rows, although it might be nice to make this more intelligent -- based on e.g. the average size of the rows. data FetchQuantity = Automatic | Fixed !Int data FoldOptions = FoldOptions { fetchQuantity :: !FetchQuantity, transactionMode :: !TransactionMode } -- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly' defaultFoldOptions :: FoldOptions defaultFoldOptions = FoldOptions { fetchQuantity = Automatic, transactionMode = TransactionMode ReadCommitted ReadOnly } -- | The same as 'fold', but this provides a bit more control over -- lower-level details. Currently, the number of rows fetched per -- round-trip to the server and the transaction mode may be adjusted -- accordingly. If the connection is already in a transaction, -- then the existing transaction is used and thus the 'transactionMode' -- option is ignored. foldWithOptions :: ( FromRow row, ToRow params ) => FoldOptions -> Connection -> Query -> params -> a -> (a -> row -> IO a) -> IO a foldWithOptions opts = foldWithOptionsAndParser opts fromRow -- | A version of 'foldWithOptions' taking a parser as an argument foldWithOptionsAndParser :: (ToRow params) => FoldOptions -> RowParser row -> Connection -> Query -> params -> a -> (a -> row -> IO a) -> IO a foldWithOptionsAndParser opts parser conn template qs a f = do q <- formatQuery conn template qs doFold opts parser conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. fold_ :: (FromRow r) => Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a fold_ = foldWithOptions_ defaultFoldOptions -- | A version of 'fold_' taking a parser as an argument foldWith_ :: RowParser r -> Connection -> Query -> a -> (a -> r -> IO a) -> IO a foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions foldWithOptions_ :: (FromRow r) => FoldOptions -> Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f -- | A version of 'foldWithOptions_' taking a parser as an argument foldWithOptionsAndParser_ :: FoldOptions -> RowParser r -> Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f doFold :: FoldOptions -> RowParser row -> Connection -> Query -> Query -> a -> (a -> row -> IO a) -> IO a doFold FoldOptions{..} parser conn _template q a0 f = do stat <- withConnection conn PQ.transactionStatus case stat of PQ.TransIdle -> withTransactionMode transactionMode conn go PQ.TransInTrans -> go PQ.TransActive -> fail "foldWithOpts FIXME: PQ.TransActive" -- This _shouldn't_ occur in the current incarnation of -- the library, as we aren't using libpq asynchronously. -- However, it could occur in future incarnations of -- this library or if client code uses the Internal module -- to use raw libpq commands on postgresql-simple connections. PQ.TransInError -> fail "foldWithOpts FIXME: PQ.TransInError" -- This should be turned into a better error message. -- It is probably a bad idea to automatically roll -- back the transaction and start another. PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown" -- Not sure what this means. where declare = do name <- newTempName conn _ <- execute_ conn $ mconcat [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] return name close name = (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex -> -- Don't throw exception if CLOSE failed because the transaction is -- aborted. Otherwise, it will throw away the original error. unless (isFailedTransactionError ex) $ throwIO ex go = bracket declare close $ \(Query name) -> let q = toByteString (byteString "FETCH FORWARD " <> intDec chunkSize <> byteString " FROM " <> byteString name ) loop a = do result <- exec conn q status <- PQ.resultStatus result case status of PQ.TuplesOk -> do nrows <- PQ.ntuples result ncols <- PQ.nfields result if nrows > 0 then do let inner a row = do x <- getRowWith parser row ncols conn result f a x foldM' inner a 0 (nrows - 1) >>= loop else return a _ -> throwResultError "fold" result status in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently -- One possibility is to use the type of the results, although this -- still isn't a perfect solution, given that common types (e.g. text) -- are of highly variable size. -- A refinement of this technique is to pick this number adaptively -- as results are read in from the database. chunkSize = case fetchQuantity of Automatic -> 256 Fixed n -> n -- | A version of 'fold' that does not transform a state value. forEach :: (ToRow q, FromRow r) => Connection -> Query -- ^ Query template. -> q -- ^ Query parameters. -> (r -> IO ()) -- ^ Result consumer. -> IO () forEach = forEachWith fromRow {-# INLINE forEach #-} -- | A version of 'forEach' taking a parser as an argument forEachWith :: ( ToRow q ) => RowParser r -> Connection -> Query -> q -> (r -> IO ()) -> IO () forEachWith parser conn template qs = foldWith parser conn template qs () . const {-# INLINE forEachWith #-} -- | A version of 'forEach' that does not perform query substitution. forEach_ :: (FromRow r) => Connection -> Query -- ^ Query template. -> (r -> IO ()) -- ^ Result consumer. -> IO () forEach_ = forEachWith_ fromRow {-# INLINE forEach_ #-} forEachWith_ :: RowParser r -> Connection -> Query -> (r -> IO ()) -> IO () forEachWith_ parser conn template = foldWith_ parser conn template () . const {-# INLINE forEachWith_ #-} forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] forM' lo hi m = loop hi [] where loop !n !as | n < lo = return as | otherwise = do a <- m n loop (n-1) (a:as) {-# INLINE forM' #-} foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a foldM' f a lo hi = loop a lo where loop a !n | n > hi = return a | otherwise = do a' <- f a n loop a' (n+1) {-# INLINE foldM' #-} finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] finishQueryWith parser conn q result = do status <- PQ.resultStatus result case status of PQ.EmptyQuery -> throwIO $ QueryError "query: Empty query" q PQ.CommandOk -> throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do nrows <- PQ.ntuples result ncols <- PQ.nfields result forM' 0 (nrows-1) $ \row -> getRowWith parser row ncols conn result PQ.CopyOut -> throwIO $ QueryError "query: COPY TO is not supported" q PQ.CopyIn -> throwIO $ QueryError "query: COPY FROM is not supported" q PQ.BadResponse -> throwResultError "query" result status PQ.NonfatalError -> throwResultError "query" result status PQ.FatalError -> throwResultError "query" result status getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r getRowWith parser row ncols conn result = do let rw = Row row result let unCol (PQ.Col x) = fromIntegral x :: Int okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn case okvc of Ok (val,col) | col == ncols -> return val | otherwise -> do vals <- forM' 0 (ncols-1) $ \c -> do tinfo <- getTypeInfo conn =<< PQ.ftype result c v <- PQ.getvalue result row c return ( tinfo , fmap ellipsis v ) throw (ConversionFailed (show (unCol ncols) ++ " values: " ++ show vals) Nothing "" (show (unCol col) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type") Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error" Errors [x] -> throwIO x Errors xs -> throwIO $ ManyErrors xs ellipsis :: ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs -- $use -- -- SQL-based applications are somewhat notorious for their -- susceptibility to attacks through the injection of maliciously -- crafted data. The primary reason for widespread vulnerability to -- SQL injections is that many applications are sloppy in handling -- user data when constructing SQL queries. -- -- This library provides a 'Query' type and a parameter substitution -- facility to address both ease of use and security. -- $querytype -- -- A 'Query' is a @newtype@-wrapped 'ByteString'. It intentionally -- exposes a tiny API that is not compatible with the 'ByteString' -- API; this makes it difficult to construct queries from fragments of -- strings. The 'query' and 'execute' functions require queries to be -- of type 'Query'. -- -- To most easily construct a query, enable GHC's @OverloadedStrings@ -- language extension and write your query as a normal literal string. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Database.PostgreSQL.Simple -- > -- > hello :: IO Int -- > hello = do -- > conn <- connectPostgreSQL "" -- > [Only i] <- query_ conn "select 2 + 2" -- > return i -- -- A 'Query' value does not represent the actual query that will be -- executed, but is a template for constructing the final query. -- $subst -- -- Since applications need to be able to construct queries with -- parameters that change, this library provides a query substitution -- capability. -- -- The 'Query' template accepted by 'query' and 'execute' can contain -- any number of \"@?@\" characters. Both 'query' and 'execute' -- accept a third argument, typically a tuple. When constructing the -- real query to execute, these functions replace the first \"@?@\" in -- the template with the first element of the tuple, the second -- \"@?@\" with the second element, and so on. If necessary, each -- tuple element will be quoted and escaped prior to substitution; -- this defeats the single most common injection vector for malicious -- data. -- -- For example, given the following 'Query' template: -- -- > select * from user where first_name = ? and age > ? -- -- And a tuple of this form: -- -- > ("Boris" :: String, 37 :: Int) -- -- The query to be executed will look like this after substitution: -- -- > select * from user where first_name = 'Boris' and age > 37 -- -- If there is a mismatch between the number of \"@?@\" characters in -- your template and the number of elements in your tuple, a -- 'FormatError' will be thrown. -- -- Note that the substitution functions do not attempt to parse or -- validate your query. It's up to you to write syntactically valid -- SQL, and to ensure that each \"@?@\" in your query template is -- matched with the right tuple element. -- $inference -- -- Automated type inference means that you will often be able to avoid -- supplying explicit type signatures for the elements of a tuple. -- However, sometimes the compiler will not be able to infer your -- types. Consider a case where you write a numeric literal in a -- parameter tuple: -- -- > query conn "select ? + ?" (40,2) -- -- The above query will be rejected by the compiler, because it does -- not know the specific numeric types of the literals @40@ and @2@. -- This is easily fixed: -- -- > query conn "select ? + ?" (40 :: Double, 2 :: Double) -- -- The same kind of problem can arise with string literals if you have -- the @OverloadedStrings@ language extension enabled. Again, just -- use an explicit type signature if this happens. -- -- Finally, remember that the compiler must be able to infer the type -- of a query's /results/ as well as its parameters. We might like -- the following example to work: -- -- > print =<< query_ conn "select 2 + 2" -- -- Unfortunately, while a quick glance tells us that the result type -- should be a single row containing a single numeric column, the -- compiler has no way to infer what the types are. We can easily fix -- this by providing an explicit type annotation: -- -- > xs <- query_ conn "select 2 + 2" -- > print (xs :: [Only Int]) -- $only_param -- -- Haskell lacks a single-element tuple type, so if you have just one -- value you want substituted into a query or a single-column result, -- what should you do? -- -- The obvious approach would appear to be something like this: -- -- > instance (ToField a) => ToRow a where -- > ... -- -- Unfortunately, this wreaks havoc with type inference, so we take a -- different tack. To represent a single value @val@ as a parameter, write -- a singleton list @[val]@, use 'Just' @val@, or use 'Only' @val@. -- -- Here's an example using a singleton list: -- -- > execute conn "insert into users (first_name) values (?)" -- > ["Nuala"] -- -- A row of /n/ query results is represented using an /n/-tuple, so -- you should use 'Only' to represent a single-column result. -- $in -- -- Suppose you want to write a query using an @IN@ clause: -- -- > select * from users where first_name in ('Anna', 'Boris', 'Carla') -- -- In such cases, it's common for both the elements and length of the -- list after the @IN@ keyword to vary from query to query. -- -- To address this case, use the 'In' type wrapper, and use a single -- \"@?@\" character to represent the list. Omit the parentheses -- around the list; these will be added for you. -- -- Here's an example: -- -- > query conn "select * from users where first_name in ?" $ -- > Only $ In ["Anna", "Boris", "Carla"] -- -- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be -- substituted instead, to ensure that your clause remains -- syntactically valid. -- $many -- -- If you know that you have many rows of data to insert into a table, -- it is much more efficient to perform all the insertions in a single -- multi-row @INSERT@ statement than individually. -- -- The 'executeMany' function is intended specifically for helping -- with multi-row @INSERT@ and @UPDATE@ statements. Its rules for -- query substitution are different than those for 'execute'. -- -- What 'executeMany' searches for in your 'Query' template is a -- single substring of the form: -- -- > values (?,?,?) -- -- The rules are as follows: -- -- * The keyword @VALUES@ is matched case insensitively. -- -- * There must be no other \"@?@\" characters anywhere in your -- template. -- -- * There must be one or more \"@?@\" in the parentheses. -- -- * Extra white space is fine. -- -- The last argument to 'executeMany' is a list of parameter -- tuples. These will be substituted into the query where the @(?,?)@ -- string appears, in a form suitable for use in a multi-row @INSERT@ -- or @UPDATE@. -- -- Here is an example: -- -- > executeMany conn -- > "insert into users (first_name,last_name) values (?,?)" -- > [("Boris","Karloff"),("Ed","Wood")] -- -- The query that will be executed here will look like this -- (reformatted for tidiness): -- -- > insert into users (first_name,last_name) values -- > ('Boris','Karloff'),('Ed','Wood') -- $returning -- -- PostgreSQL supports returning values from data manipulation statements -- such as @INSERT@ and @UPDATE@. You can use these statements by -- using 'query' instead of 'execute'. For multi-tuple inserts, -- use 'returning' instead of 'executeMany'. -- -- For example, were there an auto-incrementing @id@ column and -- timestamp column @t@ that defaulted to the present time for the -- @sales@ table, then the following query would insert two new -- sales records and also return their new @id@s and timestamps. -- -- > let q = "insert into sales (amount, label) values (?,?) returning id, t" -- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust") -- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")] -- $result -- -- The 'query' and 'query_' functions return a list of values in the -- 'FromRow' typeclass. This class performs automatic extraction -- and type conversion of rows from a query result. -- -- Here is a simple example of how to extract results: -- -- > import qualified Data.Text as Text -- > -- > xs <- query_ conn "select name,age from users" -- > forM_ xs $ \(name,age) -> -- > putStrLn $ Text.unpack name ++ " is " ++ show (age :: Int) -- -- Notice two important details about this code: -- -- * The number of columns we ask for in the query template must -- exactly match the number of elements we specify in a row of the -- result tuple. If they do not match, a 'ResultError' exception -- will be thrown. -- -- * Sometimes, the compiler needs our help in specifying types. It -- can infer that @name@ must be a 'Text', due to our use of the -- @unpack@ function. However, we have to tell it the type of @age@, -- as it has no other information to determine the exact type. -- $null -- -- The type of a result tuple will look something like this: -- -- > (Text, Int, Int) -- -- Although SQL can accommodate @NULL@ as a value for any of these -- types, Haskell cannot. If your result contains columns that may be -- @NULL@, be sure that you use 'Maybe' in those positions of your -- tuple. -- -- > (Text, Maybe Int, Int) -- -- If 'query' encounters a @NULL@ in a row where the corresponding -- Haskell type is not 'Maybe', it will throw a 'ResultError' -- exception. -- $only_result -- -- To specify that a query returns a single-column result, use the -- 'Only' type. -- -- > xs <- query_ conn "select id from users" -- > forM_ xs $ \(Only dbid) -> {- ... -} -- $types -- -- Conversion of SQL values to Haskell values is somewhat -- permissive. Here are the rules. -- -- * For numeric types, any Haskell type that can accurately represent -- all values of the given PostgreSQL type is considered \"compatible\". -- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@ -- column to a Haskell 'Int'. The Haskell 'Float' type can accurately -- represent a @SMALLINT@, so it is considered compatble with those types. -- -- * A numeric compatibility check is based only on the type of a -- column, /not/ on its values. For instance, a PostgreSQL 64-bit -- @BIGINT@ column will be considered incompatible with a Haskell -- 'Int16', even if it contains the value @1@. -- -- * If a numeric incompatibility is found, 'query' will throw a -- 'ResultError'. -- -- * The 'String' and 'Text' types are assumed to be encoded as -- UTF-8. If you use some other encoding, decoding may fail or give -- wrong results. In such cases, write a @newtype@ wrapper and a -- custom 'Result' instance to handle your encoding. postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/0000755000000000000000000000000012633616517021276 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Internal.hs0000644000000000000000000005374012633616517023417 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Internal -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Internal bits. This interface is less stable and can change at any time. -- In particular this means that while the rest of the postgresql-simple -- package endeavors to follow the package versioning policy, this module -- does not. Also, at the moment there are things in here that aren't -- particularly internal and are exported elsewhere; these will eventually -- disappear from this module. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Internal where import Control.Applicative import Control.Exception import Control.Concurrent.MVar import Control.Monad(MonadPlus(..)) import Data.ByteString(ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.ByteString.Builder ( Builder, byteString ) import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap import Data.IORef import Data.Maybe(fromMaybe) import Data.Monoid import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Typeable import Data.Word import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.LibPQ(ExecStatus(..)) import Database.PostgreSQL.Simple.Compat ( toByteString ) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes) import Database.PostgreSQL.Simple.Types (Query(..)) import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import GHC.IO.Exception #if !defined(mingw32_HOST_OS) import Control.Concurrent(threadWaitRead, threadWaitWrite) #endif -- | A Field represents metadata about a particular field -- -- You don't particularly want to retain these structures for a long -- period of time, as they will retain the entire query result, not -- just the field metadata data Field = Field { result :: !PQ.Result , column :: {-# UNPACK #-} !PQ.Column , typeOid :: {-# UNPACK #-} !PQ.Oid -- ^ This returns the type oid associated with the column. Analogous -- to libpq's @PQftype@. } type TypeInfoCache = IntMap.IntMap TypeInfo data Connection = Connection { connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64) } deriving (Typeable) instance Eq Connection where x == y = connectionHandle x == connectionHandle y data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus , sqlErrorMsg :: ByteString , sqlErrorDetail :: ByteString , sqlErrorHint :: ByteString } deriving (Show, Typeable) fatalError :: ByteString -> SqlError fatalError msg = SqlError "" FatalError msg "" "" instance Exception SqlError -- | Exception thrown if 'query' is used to perform an @INSERT@-like -- operation, or 'execute' is used to perform a @SELECT@-like operation. data QueryError = QueryError { qeMessage :: String , qeQuery :: Query } deriving (Eq, Show, Typeable) instance Exception QueryError -- | Exception thrown if a 'Query' could not be formatted correctly. -- This may occur if the number of \'@?@\' characters in the query -- string does not match the number of parameters provided. data FormatError = FormatError { fmtMessage :: String , fmtQuery :: Query , fmtParams :: [ByteString] } deriving (Eq, Show, Typeable) instance Exception FormatError data ConnectInfo = ConnectInfo { connectHost :: String , connectPort :: Word16 , connectUser :: String , connectPassword :: String , connectDatabase :: String } deriving (Eq,Read,Show,Typeable) -- | Default information for setting up a connection. -- -- Defaults are as follows: -- -- * Server on @localhost@ -- -- * Port on @5432@ -- -- * User @postgres@ -- -- * No password -- -- * Database @postgres@ -- -- Use as in the following example: -- -- > connect defaultConnectInfo { connectHost = "db.example.com" } defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnectInfo { connectHost = "127.0.0.1" , connectPort = 5432 , connectUser = "postgres" , connectPassword = "" , connectDatabase = "" } -- | Connect with the given username to the given database. Will throw -- an exception if it cannot connect. connect :: ConnectInfo -> IO Connection connect = connectPostgreSQL . postgreSQLConnectionString -- | Attempt to make a connection based on a libpq connection string. -- See -- for more information. Also note that environment variables also affect -- parameters not provided, parameters provided as the empty string, and a -- few other things; see -- for details. Here is an example with some of the most commonly used -- parameters: -- -- > host='db.somedomain.com' port=5432 ... -- -- This attempts to connect to @db.somedomain.com:5432@. Omitting the port -- will normally default to 5432. -- -- On systems that provide unix domain sockets, omitting the host parameter -- will cause libpq to attempt to connect via unix domain sockets. -- The default filesystem path to the socket is constructed from the -- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the -- @pg_config_manual.h@ header file. Connecting via unix sockets tends -- to use the @peer@ authentication method, which is very secure and -- does not require a password. -- -- On Windows and other systems without unix domain sockets, omitting -- the host will default to @localhost@. -- -- > ... dbname='postgres' user='postgres' password='secret \' \\ pw' -- -- This attempts to connect to a database named @postgres@ with -- user @postgres@ and password @secret \' \\ pw@. Backslash -- characters will have to be double-quoted in literal Haskell strings, -- of course. Omitting @dbname@ and @user@ will both default to the -- system username that the client process is running as. -- -- Omitting @password@ will default to an appropriate password found -- in the @pgpass@ file, or no password at all if a matching line is -- not found. See -- for -- more information regarding this file. -- -- As all parameters are optional and the defaults are sensible, the -- empty connection string can be useful for development and -- exploratory use, assuming your system is set up appropriately. -- -- On Unix, such a setup would typically consist of a local -- postgresql server listening on port 5432, as well as a system user, -- database user, and database sharing a common name, with permissions -- granted to the user on the database. -- -- On Windows, in addition you will either need @pg_hba.conf@ -- to specify the use of the @trust@ authentication method for -- the connection, which may not be appropriate for multiuser -- or production machines, or you will need to use a @pgpass@ file -- with the @password@ or @md5@ authentication methods. -- -- See -- for more information regarding the authentication process. -- -- SSL/TLS will typically "just work" if your postgresql server supports or -- requires it. However, note that libpq is trivially vulnerable to a MITM -- attack without setting additional SSL parameters in the connection string. -- In particular, @sslmode@ needs to be set to @require@, @verify-ca@, or -- @verify-full@ in order to perform certificate validation. When @sslmode@ -- is @require@, then you will also need to specify a @sslrootcert@ file, -- otherwise no validation of the server's identity will be performed. -- Client authentication via certificates is also possible via the -- @sslcert@ and @sslkey@ parameters. connectPostgreSQL :: ByteString -> IO Connection connectPostgreSQL connstr = do conn <- connectdb connstr stat <- PQ.status conn case stat of PQ.ConnectionOk -> do connectionHandle <- newMVar conn connectionObjects <- newMVar (IntMap.empty) connectionTempNameCounter <- newIORef 0 let wconn = Connection{..} version <- PQ.serverVersion conn let settings | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8" | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on" _ <- execute_ wconn settings return wconn _ -> do msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn throwIO $ fatalError msg connectdb :: ByteString -> IO PQ.Connection #if defined(mingw32_HOST_OS) connectdb = PQ.connectdb #else connectdb conninfo = do conn <- PQ.connectStart conninfo loop conn where funcName = "Database.PostgreSQL.Simple.connectPostgreSQL" loop conn = do status <- PQ.connectPoll conn case status of PQ.PollingFailed -> throwLibPQError conn "connection failed" PQ.PollingReading -> do mfd <- PQ.socket conn case mfd of Nothing -> throwIO $! fdError funcName Just fd -> do threadWaitRead fd loop conn PQ.PollingWriting -> do mfd <- PQ.socket conn case mfd of Nothing -> throwIO $! fdError funcName Just fd -> do threadWaitWrite fd loop conn PQ.PollingOk -> return conn #endif -- | Turns a 'ConnectInfo' data structure into a libpq connection string. postgreSQLConnectionString :: ConnectInfo -> ByteString postgreSQLConnectionString connectInfo = fromString connstr where connstr = str "host=" connectHost $ num "port=" connectPort $ str "user=" connectUser $ str "password=" connectPassword $ str "dbname=" connectDatabase $ [] str name field | null value = id | otherwise = showString name . quote value . space where value = field connectInfo num name field | value <= 0 = id | otherwise = showString name . shows value . space where value = field connectInfo quote str rest = '\'' : foldr delta ('\'' : rest) str where delta c cs = case c of '\\' -> '\\' : '\\' : cs '\'' -> '\\' : '\'' : cs _ -> c : cs space [] = [] space xs = ' ':xs oid2int :: Oid -> Int oid2int (Oid x) = fromIntegral x {-# INLINE oid2int #-} exec :: Connection -> ByteString -> IO PQ.Result #if defined(mingw32_HOST_OS) exec conn sql = withConnection conn $ \h -> do mres <- PQ.exec h sql case mres of Nothing -> throwLibPQError h "PQexec returned no results" Just res -> return res #else exec conn sql = withConnection conn $ \h -> do success <- PQ.sendQuery h sql if success then awaitResult h Nothing else throwLibPQError h "PQsendQuery failed" where awaitResult h mres = do mfd <- PQ.socket h case mfd of Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec" Just fd -> do threadWaitRead fd _ <- PQ.consumeInput h -- FIXME? getResult h mres getResult h mres = do isBusy <- PQ.isBusy h if isBusy then awaitResult h mres else do mres' <- PQ.getResult h case mres' of Nothing -> case mres of Nothing -> throwLibPQError h "PQgetResult returned no results" Just res -> return res Just res -> do status <- PQ.resultStatus res case status of PQ.EmptyQuery -> getResult h mres' PQ.CommandOk -> getResult h mres' PQ.TuplesOk -> getResult h mres' PQ.CopyOut -> return res PQ.CopyIn -> return res PQ.BadResponse -> getResult h mres' PQ.NonfatalError -> getResult h mres' PQ.FatalError -> getResult h mres' #endif -- | A version of 'execute' that does not perform query substitution. execute_ :: Connection -> Query -> IO Int64 execute_ conn q@(Query stmt) = do result <- exec conn stmt finishExecute conn q result finishExecute :: Connection -> Query -> PQ.Result -> IO Int64 finishExecute _conn q result = do status <- PQ.resultStatus result case status of PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q PQ.CommandOk -> do ncols <- PQ.nfields result if ncols /= 0 then throwIO $ QueryError ("execute resulted in " ++ show ncols ++ "-column result") q else do nstr <- PQ.cmdTuples result return $ case nstr of Nothing -> 0 -- is this appropriate? Just str -> toInteger str PQ.TuplesOk -> do ncols <- PQ.nfields result throwIO $ QueryError ("execute resulted in " ++ show ncols ++ "-column result") q PQ.CopyOut -> throwIO $ QueryError "execute: COPY TO is not supported" q PQ.CopyIn -> throwIO $ QueryError "execute: COPY FROM is not supported" q PQ.BadResponse -> throwResultError "execute" result status PQ.NonfatalError -> throwResultError "execute" result status PQ.FatalError -> throwResultError "execute" result status where toInteger str = B8.foldl' delta 0 str where delta acc c = if '0' <= c && c <= '9' then 10 * acc + fromIntegral (ord c - ord '0') else error ("finishExecute: not an int: " ++ B8.unpack str) throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a throwResultError _ result status = do errormsg <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessagePrimary detail <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageDetail hint <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageHint state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate throwIO $ SqlError { sqlState = state , sqlExecStatus = status , sqlErrorMsg = errormsg , sqlErrorDetail = detail , sqlErrorHint = hint } disconnectedError :: SqlError disconnectedError = fatalError "connection disconnected" -- | Atomically perform an action with the database handle, if there is one. withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a withConnection Connection{..} m = do withMVar connectionHandle $ \conn -> do if PQ.isNullConnection conn then throwIO disconnectedError else m conn close :: Connection -> IO () close Connection{..} = mask $ \restore -> (do conn <- takeMVar connectionHandle restore (PQ.finish conn) `finally` do putMVar connectionHandle =<< PQ.newNullConnection ) newNullConnection :: IO Connection newNullConnection = do connectionHandle <- newMVar =<< PQ.newNullConnection connectionObjects <- newMVar IntMap.empty connectionTempNameCounter <- newIORef 0 return Connection{..} data Row = Row { row :: {-# UNPACK #-} !PQ.Row , rowresult :: !PQ.Result } newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a } deriving ( Functor, Applicative, Alternative, Monad ) liftRowParser :: IO a -> RowParser a liftRowParser = RP . lift . lift . liftConversion newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } liftConversion :: IO a -> Conversion a liftConversion m = Conversion (\_ -> Ok <$> m) instance Functor Conversion where fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn) instance Applicative Conversion where pure a = Conversion $ \_conn -> pure (pure a) mf <*> ma = Conversion $ \conn -> do okf <- runConversion mf conn case okf of Ok f -> (fmap . fmap) f (runConversion ma conn) Errors errs -> return (Errors errs) instance Alternative Conversion where empty = Conversion $ \_conn -> pure empty ma <|> mb = Conversion $ \conn -> do oka <- runConversion ma conn case oka of Ok _ -> return oka Errors _ -> (oka <|>) <$> runConversion mb conn instance Monad Conversion where return a = Conversion $ \_conn -> return (return a) m >>= f = Conversion $ \conn -> do oka <- runConversion m conn case oka of Ok a -> runConversion (f a) conn Errors err -> return (Errors err) instance MonadPlus Conversion where mzero = empty mplus = (<|>) conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn conversionError :: Exception err => err -> Conversion a conversionError err = Conversion $ \_ -> return (Errors [SomeException err]) newTempName :: Connection -> IO Query newTempName Connection{..} = do !n <- atomicModifyIORef connectionTempNameCounter (\n -> let !n' = n+1 in (n', n')) return $! Query $ B8.pack $ "temp" ++ show n -- FIXME? What error should getNotification and getCopyData throw? fdError :: ByteString -> IOError fdError funcName = IOError { ioe_handle = Nothing, ioe_type = ResourceVanished, ioe_location = B8.unpack funcName, ioe_description = "failed to fetch file descriptor", ioe_errno = Nothing, ioe_filename = Nothing } libPQError :: ByteString -> IOError libPQError desc = IOError { ioe_handle = Nothing, ioe_type = OtherError, ioe_location = "libpq", ioe_description = B8.unpack desc, ioe_errno = Nothing, ioe_filename = Nothing } throwLibPQError :: PQ.Connection -> ByteString -> IO a throwLibPQError conn default_desc = do msg <- maybe default_desc id <$> PQ.errorMessage conn throwIO $! libPQError msg fmtError :: String -> Query -> [Action] -> a fmtError msg q xs = throw FormatError { fmtMessage = msg , fmtQuery = q , fmtParams = map twiddle xs } where twiddle (Plain b) = toByteString b twiddle (Escape s) = s twiddle (EscapeByteA s) = s twiddle (EscapeIdentifier s) = s twiddle (Many ys) = B.concat (map twiddle ys) fmtErrorBs :: Query -> [Action] -> ByteString -> a fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs -- | Quote bytestring or throw 'FormatError' quote :: Query -> [Action] -> Either ByteString ByteString -> Builder quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString) buildAction :: Connection -- ^ Connection for string escaping -> Query -- ^ Query for message error -> [Action] -- ^ List of parameters for message error -> Action -- ^ Action to build -> IO Builder buildAction _ _ _ (Plain b) = pure b buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s buildAction conn q xs (EscapeIdentifier s) = either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s buildAction conn q xs (Many ys) = mconcat <$> mapM (buildAction conn q xs) ys checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a) checkError _ (Just x) = return $ Right x checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString)) -> Connection -> ByteString -> IO (Either ByteString ByteString) escapeWrap f conn s = withConnection conn $ \c -> f c s >>= checkError c escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeStringConn = escapeWrap PQ.escapeStringConn escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeIdentifier = escapeWrap PQ.escapeIdentifier escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeByteaConn = escapeWrap PQ.escapeByteaConn postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore.hs0000644000000000000000000000230512633616517023036 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Parsers and printers for hstore, a extended type bundled with -- PostgreSQL providing finite maps from text strings to text strings. -- See for more -- information. -- -- Note that in order to use this type, a database superuser must -- install it by running a sql script in the share directory. This -- can be done on PostgreSQL 9.1 and later with the command -- @CREATE EXTENSION hstore@. See -- for more -- information. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore ( HStoreList(..) , HStoreMap(..) , ToHStore(..) , HStoreBuilder , toBuilder , toLazyByteString , hstore , parseHStoreList , ToHStoreText(..) , HStoreText ) where import Database.PostgreSQL.Simple.HStore.Implementation postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToRow.hs0000644000000000000000000000747612633616517022722 0ustar0000000000000000{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'ToRow' typeclass, for rendering a collection of -- parameters to a SQL query. -- -- Predefined instances are provided for tuples containing up to ten -- elements. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) where import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..)) import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..)) import GHC.Generics -- | A collection type that can be turned into a list of rendering -- 'Action's. -- -- Instances should use the 'toField' method of the 'ToField' class -- to perform conversion of each element of the collection. class ToRow a where toRow :: a -> [Action] default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] toRow = gtoRow . from -- ^ ToField a collection of values. instance ToRow () where toRow _ = [] instance (ToField a) => ToRow (Only a) where toRow (Only v) = [toField v] instance (ToField a, ToField b) => ToRow (a,b) where toRow (a,b) = [toField a, toField b] instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where toRow (a,b,c) = [toField a, toField b, toField c] instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where toRow (a,b,c,d) = [toField a, toField b, toField c, toField d] instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a,b,c,d,e) where toRow (a,b,c,d,e) = [toField a, toField b, toField c, toField d, toField e] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a,b,c,d,e,f) where toRow (a,b,c,d,e,f) = [toField a, toField b, toField c, toField d, toField e, toField f] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a,b,c,d,e,f,g) where toRow (a,b,c,d,e,f,g) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) => ToRow (a,b,c,d,e,f,g,h) where toRow (a,b,c,d,e,f,g,h) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i) => ToRow (a,b,c,d,e,f,g,h,i) where toRow (a,b,c,d,e,f,g,h,i) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j) => ToRow (a,b,c,d,e,f,g,h,i,j) where toRow (a,b,c,d,e,f,g,h,i,j) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j] instance (ToField a) => ToRow [a] where toRow = map toField instance (ToRow a, ToRow b) => ToRow (a :. b) where toRow (a :. b) = toRow a ++ toRow b -- Type class for default implementation of ToRow using generics class GToRow f where gtoRow :: f p -> [Action] instance GToRow f => GToRow (M1 c i f) where gtoRow (M1 x) = gtoRow x instance (GToRow f, GToRow g) => GToRow (f :*: g) where gtoRow (f :*: g) = gtoRow f ++ gtoRow g instance (ToField a) => GToRow (K1 R a) where gtoRow (K1 a) = [toField a] instance GToRow U1 where gtoRow _ = [] postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo.hs0000644000000000000000000001251612633616517023374 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This module provides convenient and efficient access to parts of the -- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if -- you need to work with types that do not appear in -- 'Database.PostgreSQL.Simple.TypeInfo.Static'. -- -- The current scheme could be more efficient, especially for some use -- cases. In particular, connection pools that use many user-added -- types and connect to a set of servers with identical (or at least -- compatible) @pg_type@ and associated tables could share a common -- typeinfo cache, thus saving memory and communication between the -- client and server. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo ( getTypeInfo , TypeInfo(..) , Attribute(..) ) where import qualified Data.ByteString as B import qualified Data.IntMap as IntMap import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Control.Concurrent.MVar import Control.Exception (throw) import qualified Database.PostgreSQL.LibPQ as PQ import {-# SOURCE #-} Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo.Types import Database.PostgreSQL.Simple.TypeInfo.Static -- | Returns the metadata of the type with a particular oid. To find -- this data, 'getTypeInfo' first consults postgresql-simple's -- built-in 'staticTypeInfo' table, then checks the connection's -- typeinfo cache. Finally, the database's 'pg_type' table will -- be queried only if necessary, and the result will be stored -- in the connections's cache. getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo getTypeInfo conn@Connection{..} oid = case staticTypeInfo oid of Just name -> return name Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache -> IO (TypeInfoCache, TypeInfo) getTypeInfo' conn oid oidmap = case IntMap.lookup (oid2int oid) oidmap of Just typeinfo -> return (oidmap, typeinfo) Nothing -> do names <- query conn "SELECT oid, typcategory, typdelim, typname,\ \ typelem, typrelid\ \ FROM pg_type WHERE oid = ?" (Only oid) (oidmap', typeInfo) <- case names of [] -> return $ throw (fatalError "invalid type oid") [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do case typcategory of 'A' -> do (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap let !typeInfo = Array{..} return $! (oidmap', typeInfo) 'R' -> do rngsubtypeOids <- query conn "SELECT rngsubtype\ \ FROM pg_range\ \ WHERE rngtypid = ?" (Only oid) case rngsubtypeOids of [Only rngsubtype_] -> do (oidmap', rngsubtype) <- getTypeInfo' conn rngsubtype_ oidmap let !typeInfo = Range{..} return $! (oidmap', typeInfo) _ -> fail "range subtype query failed to return exactly one result" 'C' -> do cols <- query conn "SELECT attname, atttypid\ \ FROM pg_attribute\ \ WHERE attrelid = ?\ \ AND attnum > 0\ \ AND NOT attisdropped\ \ ORDER BY attnum" (Only typrelid) vec <- MV.new $! length cols (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0 let !typeInfo = Composite{..} return $! (oidmap', typeInfo) _ -> do let !typeInfo = Basic{..} return $! (oidmap, typeInfo) _ -> fail "typename query returned more than one result" -- oid is a primary key, so the query should -- never return more than one result let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap' return $! (oidmap'', typeInfo) getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache -> MV.IOVector Attribute -> Int -> IO (TypeInfoCache, V.Vector Attribute) getAttInfos conn cols oidmap vec n = case cols of [] -> do !attributes <- V.unsafeFreeze vec return $! (oidmap, attributes) ((attname, attTypeOid):xs) -> do (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap MV.write vec n $! Attribute{..} getAttInfos conn xs oidmap' vec (n+1) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromRow.hs-boot0000644000000000000000000000113412633616517024165 0ustar0000000000000000module Database.PostgreSQL.Simple.FromRow where import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Types class FromRow a instance (FromField a) => FromRow (Only a) instance (FromField a, FromField b) => FromRow (a,b) instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) instance (FromField a, FromField b, FromField c, FromField d, FromField e ,FromField f) => FromRow (a,b,c,d,e,f) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/SqlQQ.hs0000644000000000000000000000677712633616517022654 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.SqlQQ (sql) where import Database.PostgreSQL.Simple.Types (Query) import Language.Haskell.TH import Language.Haskell.TH.Quote import Data.Char import Data.String -- | 'sql' is a quasiquoter that eases the syntactic burden -- of writing big sql statements in Haskell source code. For example: -- -- > {-# LANGUAGE QuasiQuotes #-} -- > -- > query conn [sql| SELECT column_a, column_b -- > FROM table1 NATURAL JOIN table2 -- > WHERE ? <= time AND time < ? -- > AND name LIKE ? -- > ORDER BY size DESC -- > LIMIT 100 |] -- > (beginTime,endTime,string) -- -- This quasiquoter returns a literal string expression of type 'Query', -- and attempts to mimimize whitespace; otherwise the above query would -- consist of approximately half whitespace when sent to the database -- backend. It also recognizes and strips out standard sql comments "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be -- preserved as-is. It does preserve whitespace inside standard SQL string -- literals. But it can get confused by the non-standard PostgreSQL string -- literal syntax (which is the default setting in PostgreSQL 8 and below), -- the extended escape string syntax, quoted identifiers, and other similar -- constructs. -- -- Of course, this caveat only applies to text written inside the SQL -- quasiquoter; whitespace reduction is a compile-time computation and -- thus will not touch the @string@ parameter above, which is a run-time -- value. -- -- Also note that this will not work if the substring @|]@ is contained -- in the query. sql :: QuasiQuoter sql = QuasiQuoter { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ quasiquoter used in pattern context" , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ quasiquoter used in type context" , quoteExp = sqlExp , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ quasiquoter used in declaration context" } sqlExp :: String -> Q Exp sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace minimizeSpace :: String -> String minimizeSpace = drop 1 . reduceSpace where needsReduced [] = False needsReduced ('-':'-':_) = True needsReduced (x:_) = isSpace x reduceSpace xs = case dropWhile isSpace xs of [] -> [] ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys) ys -> ' ' : insql ys insql ('\'':xs) = '\'' : instring xs insql xs | needsReduced xs = reduceSpace xs insql (x:xs) = x : insql xs insql [] = [] instring ('\'':'\'':xs) = '\'':'\'': instring xs instring ('\'':xs) = '\'': insql xs instring (x:xs) = x : instring xs instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ string literal not terminated" postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToRow.hs-boot0000644000000000000000000000075212633616517023651 0ustar0000000000000000{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} module Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) where import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField import GHC.Generics class ToRow a where toRow :: a -> [Action] default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] toRow = gtoRow . from class GToRow f where gtoRow :: f p -> [Action] instance ToField a => ToRow (Only a) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Copy.hs0000644000000000000000000002204412633616517022546 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Copy -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- mid-level support for COPY IN and COPY OUT. See -- for -- more information. -- -- To use this binding, first call 'copy' with an appropriate -- query as documented in the link above. Then, in the case of a -- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it -- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@ -- query, call 'putCopyData' repeatedly and then finish by calling -- either 'putCopyEnd' to proceed or 'putCopyError' to abort. -- -- You cannot issue another query on the same connection while a copy -- is ongoing; this will result in an exception. It is harmless to -- concurrently call @getNotification@ on a connection while it is in -- a @CopyIn@ or @CopyOut@ state, however be aware that current versions -- of the PostgreSQL backend will not deliver notifications to a client -- while a transaction is ongoing. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Copy ( copy , copy_ , CopyOutResult(..) , getCopyData , putCopyData , putCopyEnd , putCopyError ) where import Control.Applicative import Control.Concurrent import Control.Exception ( throwIO ) import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Typeable(Typeable) import Data.Int(Int64) import qualified Data.ByteString.Char8 as B import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Internal -- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former -- case, the connection's state will change to @CopyIn@; in the latter, -- @CopyOut@. The connection must be in the ready state in order -- to call this function. Performs parameter subsitution. copy :: ( ToRow params ) => Connection -> Query -> params -> IO () copy conn template qs = do q <- formatQuery conn template qs doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q -- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former -- case, the connection's state will change to @CopyIn@; in the latter, -- @CopyOut@. The connection must be in the ready state in order -- to call this function. Does not perform parameter subsitution. copy_ :: Connection -> Query -> IO () copy_ conn (Query q) = do doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO () doCopy funcName conn template q = do result <- exec conn q status <- PQ.resultStatus result let err = throwIO $ QueryError (B.unpack funcName ++ " " ++ show status) template case status of PQ.EmptyQuery -> err PQ.CommandOk -> err PQ.TuplesOk -> err PQ.CopyOut -> return () PQ.CopyIn -> return () PQ.BadResponse -> throwResultError funcName result status PQ.NonfatalError -> throwResultError funcName result status PQ.FatalError -> throwResultError funcName result status data CopyOutResult = CopyOutRow !B.ByteString -- ^ Data representing either exactly -- one row of the result, or header -- or footer data depending on format. | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the -- number of rows returned. deriving (Eq, Typeable, Show) -- | Retrieve some data from a @COPY TO STDOUT@ query. A connection -- must be in the @CopyOut@ state in order to call this function. If this -- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state, -- if it returns 'CopyOutDone', then the connection has reverted to the -- ready state. getCopyData :: Connection -> IO CopyOutResult getCopyData conn = withConnection conn loop where funcName = "Database.PostgreSQL.Simple.Copy.getCopyData" loop pqconn = do #if defined(mingw32_HOST_OS) row <- PQ.getCopyData pqconn False #else row <- PQ.getCopyData pqconn True #endif case row of PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn #if defined(mingw32_HOST_OS) PQ.CopyOutWouldBlock -> do fail (B.unpack funcName ++ ": the impossible happened") #else PQ.CopyOutWouldBlock -> do mfd <- PQ.socket pqconn case mfd of Nothing -> throwIO (fdError funcName) Just fd -> do threadWaitRead fd _ <- PQ.consumeInput pqconn loop pqconn #endif PQ.CopyOutError -> do mmsg <- PQ.errorMessage pqconn throwIO SqlError { sqlState = "", sqlExecStatus = FatalError, sqlErrorMsg = maybe "" id mmsg, sqlErrorDetail = "", sqlErrorHint = funcName } -- | Feed some data to a @COPY FROM STDIN@ query. Note that -- the data does not need to represent a single row, or even an -- integral number of rows. The net result of -- @putCopyData conn a >> putCopyData conn b@ -- is the same as @putCopyData conn c@ whenever @c == BS.append a b@. -- -- A connection must be in the @CopyIn@ state in order to call this -- function, otherwise a 'SqlError' exception will result. The -- connection remains in the @CopyIn@ state after this function -- is called. putCopyData :: Connection -> B.ByteString -> IO () putCopyData conn dat = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyData" -- | Completes a @COPY FROM STDIN@ query. Returns the number of rows -- processed. -- -- A connection must be in the @CopyIn@ state in order to call this -- function, otherwise a 'SqlError' exception will result. The -- connection's state changes back to ready after this function -- is called. putCopyEnd :: Connection -> IO Int64 putCopyEnd conn = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn getCopyCommandTag funcName pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd" -- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply -- an arbitrary error message that may show up in the PostgreSQL -- server's log. -- -- A connection must be in the @CopyIn@ state in order to call this -- function, otherwise a 'SqlError' exception will result. The -- connection's state changes back to ready after this function -- is called. putCopyError :: Connection -> B.ByteString -> IO () putCopyError conn err = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn consumeResults pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyError" doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult) -> PQ.Connection -> IO () doCopyIn funcName action = loop where loop pqconn = do stat <- action pqconn case stat of PQ.CopyInOk -> return () PQ.CopyInError -> do mmsg <- PQ.errorMessage pqconn throwIO SqlError { sqlState = "", sqlExecStatus = FatalError, sqlErrorMsg = maybe "" id mmsg, sqlErrorDetail = "", sqlErrorHint = funcName } PQ.CopyInWouldBlock -> do mfd <- PQ.socket pqconn case mfd of Nothing -> throwIO (fdError funcName) Just fd -> do threadWaitWrite fd loop pqconn {-# INLINE doCopyIn #-} getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64 getCopyCommandTag funcName pqconn = do result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result consumeResults pqconn let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput) case P.parseOnly rowCount cmdStat of Left _ -> fail errCmdStatusFmt Right n -> return $! n where errCmdStatus = B.unpack funcName ++ ": failed to fetch command status" errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status" consumeResults :: PQ.Connection -> IO () consumeResults pqconn = do mres <- PQ.getResult pqconn case mres of Nothing -> return () Just _ -> consumeResults pqconn postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Ok.hs0000644000000000000000000000525312633616517022210 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------ -- | -- Module : Database.PostgreSQL.Simple.Ok -- Copyright : (c) 2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- Stability : experimental -- -- The 'Ok' type is a simple error handler, basically equivalent to -- @Either [SomeException]@. This type (without the list) was used to -- handle conversion errors in early versions of postgresql-simple. -- -- One of the primary reasons why this type was introduced is that -- @Either SomeException@ had not been provided an instance for 'Alternative', -- and it would have been a bad idea to provide an orphaned instance for a -- commonly-used type and typeclass included in @base@. -- -- Extending the failure case to a list of 'SomeException's enables a -- more sensible 'Alternative' instance definitions: '<|>' concatinates -- the list of exceptions when both cases fail, and 'empty' is defined as -- 'Errors []'. Though '<|>' one could pick one of two exceptions, and -- throw away the other, and have 'empty' provide a generic exception, -- this avoids cases where 'empty' overrides a more informative exception -- and allows you to see all the different ways your computation has failed. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Ok where import Control.Applicative import Control.Exception import Control.Monad(MonadPlus(..)) import Data.Typeable -- FIXME: [SomeException] should probably be something else, maybe -- a difference list (or a tree?) data Ok a = Errors [SomeException] | Ok !a deriving(Show, Typeable, Functor) -- | Two 'Errors' cases are considered equal, regardless of what the -- list of exceptions looks like. instance Eq a => Eq (Ok a) where Errors _ == Errors _ = True Ok a == Ok b = a == b _ == _ = False instance Applicative Ok where pure = Ok Errors es <*> _ = Errors es _ <*> Errors es = Errors es Ok f <*> Ok a = Ok (f a) instance Alternative Ok where empty = Errors [] a@(Ok _) <|> _ = a Errors _ <|> b@(Ok _) = b Errors as <|> Errors bs = Errors (as ++ bs) instance MonadPlus Ok where mzero = empty mplus = (<|>) instance Monad Ok where return = Ok Errors es >>= _ = Errors es Ok a >>= f = f a fail str = Errors [SomeException (ErrorCall str)] -- | a way to reify a list of exceptions into a single exception newtype ManyErrors = ManyErrors [SomeException] deriving (Show, Typeable) instance Exception ManyErrors postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Range.hs0000644000000000000000000002634212633616517022675 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Range -- Copyright: (c) 2014-2015 Leonid Onokhov -- (c) 2014-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Range ( RangeBound(..) , PGRange(..) , empty , isEmpty, isEmptyBy , contains, containsBy ) where import Control.Applicative hiding (empty) import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString as B import Data.ByteString.Builder ( Builder, byteString, lazyByteString, char8 , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec , wordDec, word8Dec, word16Dec, word32Dec, word64Dec , doubleDec, floatDec ) import Data.Int (Int16, Int32, Int64, Int8) import Data.Function (on) import Data.Monoid (mempty) import Data.Scientific (Scientific) import qualified Data.Text.Lazy.Builder as LT import qualified Data.Text.Lazy.Encoding as LT import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime, zonedTimeToUTC) import Data.Typeable (Typeable) import Data.Word (Word, Word16, Word32, Word64, Word8) import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString) import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Time hiding (PosInfinity, NegInfinity) -- import qualified Database.PostgreSQL.Simple.Time as Time import Database.PostgreSQL.Simple.ToField -- | Represents boundary of a range data RangeBound a = NegInfinity | Inclusive !a | Exclusive !a | PosInfinity deriving (Show, Typeable, Eq, Functor) -- | Generic range type data PGRange a = PGRange !(RangeBound a) !(RangeBound a) deriving (Show, Typeable, Functor) empty :: PGRange a empty = PGRange PosInfinity NegInfinity instance Ord a => Eq (PGRange a) where x == y = eq x y || (isEmpty x && isEmpty y) where eq (PGRange a m) (PGRange b n) = a == b && m == n isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool isEmptyBy cmp v = case v of (PGRange PosInfinity _) -> True (PGRange _ NegInfinity) -> True (PGRange NegInfinity _) -> False (PGRange _ PosInfinity) -> False (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT -- | Is a range empty? If this returns 'True', then the 'contains' -- predicate will always return 'False'. However, if this returns -- 'False', it is not necessarily true that there exists a point for -- which 'contains' returns 'True'. -- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@, -- for example. isEmpty :: Ord a => PGRange a -> Bool isEmpty = isEmptyBy compare -- | Does a range contain a given point? Note that in some cases, this may -- not correspond exactly with a server-side computation. Consider @UTCTime@ -- for example, which has a resolution of a picosecond, whereas postgresql's -- @timestamptz@ types have a resolution of a microsecond. Putting such -- Haskell values into the database will result in them being rounded, which -- can change the value of the containment predicate. contains :: Ord a => PGRange a -> (a -> Bool) contains = containsBy compare containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool) containsBy cmp rng x = case rng of PGRange _lb NegInfinity -> False PGRange lb ub -> checkLB lb x && checkUB ub x where checkLB lb x = case lb of NegInfinity -> True PosInfinity -> False Inclusive a -> cmp a x /= GT Exclusive a -> cmp a x == LT checkUB ub x = case ub of NegInfinity -> False PosInfinity -> True Inclusive z -> cmp x z /= GT Exclusive z -> cmp x z == LT lowerBound :: Parser (a -> RangeBound a) lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive) {-# INLINE lowerBound #-} upperBound :: Parser (a -> RangeBound a) upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive) {-# INLINE upperBound #-} -- | Generic range parser pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString) pgrange = do lb <- lowerBound v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',') v2 <- rangeElem $ \c -> c == ')' || c == ']' ub <- upperBound A.endOfInput let low = if B.null v1 then NegInfinity else lb v1 up = if B.null v2 then PosInfinity else ub v2 return (low, up) rangeElem :: (Char -> Bool) -> Parser B.ByteString rangeElem end = (A.char '"' *> doubleQuoted) <|> A.takeTill end {-# INLINE rangeElem #-} -- | Simple double quoted value parser doubleQuoted :: Parser B.ByteString doubleQuoted = toByteString <$> go mempty where go acc = do h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"') let rest = do start <- A.anyChar case start of '\\' -> do c <- A.anyChar go (acc <> h <> char8 c) '"' -> (A.char '"' *> go (acc <> h <> char8 '"')) <|> pure (acc <> h) _ -> error "impossible in doubleQuoted" rest rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder rangeToBuilder = rangeToBuilderBy compare -- | Generic range to builder for plain values rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder rangeToBuilderBy cmp f x = if isEmptyBy cmp x then byteString "'empty'" else let (PGRange a b) = x in buildLB a <> buildUB b where buildLB NegInfinity = byteString "'[," buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\"," buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\"," buildLB PosInfinity = error "impossible in rangeToBuilder" buildUB NegInfinity = error "impossible in rangeToBuilder" buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'" buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'" buildUB PosInfinity = byteString "]'" {-# INLINE rangeToBuilder #-} instance (FromField a, Typeable a) => FromField (PGRange a) where fromField f mdat = do info <- typeInfo f case info of Range{} -> let f' = f { typeOid = typoid (rngsubtype info) } in case mdat of Nothing -> returnError UnexpectedNull f "" Just "empty" -> pure $ empty Just bs -> let parseIt NegInfinity = pure NegInfinity parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v) parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v) parseIt PosInfinity = pure PosInfinity in case parseOnly pgrange bs of Left e -> returnError ConversionFailed f e Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub _ -> returnError Incompatible f "" instance ToField (PGRange Int8) where toField = Plain . rangeToBuilder int8Dec {-# INLINE toField #-} instance ToField (PGRange Int16) where toField = Plain . rangeToBuilder int16Dec {-# INLINE toField #-} instance ToField (PGRange Int32) where toField = Plain . rangeToBuilder int32Dec {-# INLINE toField #-} instance ToField (PGRange Int) where toField = Plain . rangeToBuilder intDec {-# INLINE toField #-} instance ToField (PGRange Int64) where toField = Plain . rangeToBuilder int64Dec {-# INLINE toField #-} instance ToField (PGRange Integer) where toField = Plain . rangeToBuilder integerDec {-# INLINE toField #-} instance ToField (PGRange Word8) where toField = Plain . rangeToBuilder word8Dec {-# INLINE toField #-} instance ToField (PGRange Word16) where toField = Plain . rangeToBuilder word16Dec {-# INLINE toField #-} instance ToField (PGRange Word32) where toField = Plain . rangeToBuilder word32Dec {-# INLINE toField #-} instance ToField (PGRange Word) where toField = Plain . rangeToBuilder wordDec {-# INLINE toField #-} instance ToField (PGRange Word64) where toField = Plain . rangeToBuilder word64Dec {-# INLINE toField #-} instance ToField (PGRange Float) where toField = Plain . rangeToBuilder floatDec {-# INLINE toField #-} instance ToField (PGRange Double) where toField = Plain . rangeToBuilder doubleDec {-# INLINE toField #-} instance ToField (PGRange Scientific) where toField = Plain . rangeToBuilder f where f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder {-# INLINE toField #-} instance ToField (PGRange UTCTime) where toField = Plain . rangeToBuilder utcTimeToBuilder {-# INLINE toField #-} instance ToField (PGRange ZonedTime) where toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder {-# INLINE toField #-} cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize instance ToField (PGRange LocalTime) where toField = Plain . rangeToBuilder localTimeToBuilder {-# INLINE toField #-} instance ToField (PGRange Day) where toField = Plain . rangeToBuilder dayToBuilder {-# INLINE toField #-} instance ToField (PGRange TimeOfDay) where toField = Plain . rangeToBuilder timeOfDayToBuilder {-# INLINE toField #-} instance ToField (PGRange UTCTimestamp) where toField = Plain . rangeToBuilder utcTimestampToBuilder {-# INLINE toField #-} instance ToField (PGRange ZonedTimestamp) where toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder {-# INLINE toField #-} cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>) instance ToField (PGRange LocalTimestamp) where toField = Plain . rangeToBuilder localTimestampToBuilder {-# INLINE toField #-} instance ToField (PGRange Date) where toField = Plain . rangeToBuilder dateToBuilder {-# INLINE toField #-} instance ToField (PGRange NominalDiffTime) where toField = Plain . rangeToBuilder nominalDiffTimeToBuilder {-# INLINE toField #-} postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo.hs-boot0000644000000000000000000000040712633616517024331 0ustar0000000000000000module Database.PostgreSQL.Simple.TypeInfo where import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.TypeInfo.Types import Database.PostgreSQL.Simple.Internal getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Transaction.hs0000644000000000000000000002201712633616517024121 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Database.PostgreSQL.Simple.Transaction ( -- * Transaction handling withTransaction , withTransactionLevel , withTransactionMode , withTransactionModeRetry , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..) , ReadWriteMode(..) , defaultTransactionMode , defaultIsolationLevel , defaultReadWriteMode -- , Base.autocommit , begin , beginLevel , beginMode , commit , rollback -- * Savepoint , withSavepoint , Savepoint , newSavepoint , releaseSavepoint , rollbackToSavepoint , rollbackToAndReleaseSavepoint -- * Error predicates , isSerializationError , isNoActiveTransactionError , isFailedTransactionError ) where import qualified Control.Exception as E import qualified Data.ByteString as B import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Errors import Database.PostgreSQL.Simple.Compat (mask, (<>)) -- | Of the four isolation levels defined by the SQL standard, -- these are the three levels distinguished by PostgreSQL as of version 9.0. -- See -- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' -- was equivalent to 'Serializable'. data IsolationLevel = DefaultIsolationLevel -- ^ the isolation level will be taken from -- PostgreSQL's per-connection -- @default_transaction_isolation@ variable, -- which is initialized according to the -- server's config. The default configuration -- is 'ReadCommitted'. | ReadCommitted | RepeatableRead | Serializable deriving (Show, Eq, Ord, Enum, Bounded) data ReadWriteMode = DefaultReadWriteMode -- ^ the read-write mode will be taken from -- PostgreSQL's per-connection -- @default_transaction_read_only@ variable, -- which is initialized according to the -- server's config. The default configuration -- is 'ReadWrite'. | ReadWrite | ReadOnly deriving (Show, Eq, Ord, Enum, Bounded) data TransactionMode = TransactionMode { isolationLevel :: !IsolationLevel, readWriteMode :: !ReadWriteMode } deriving (Show, Eq) defaultTransactionMode :: TransactionMode defaultTransactionMode = TransactionMode defaultIsolationLevel defaultReadWriteMode defaultIsolationLevel :: IsolationLevel defaultIsolationLevel = DefaultIsolationLevel defaultReadWriteMode :: ReadWriteMode defaultReadWriteMode = DefaultReadWriteMode -- | Execute an action inside a SQL transaction. -- -- This function initiates a transaction with a \"@begin -- transaction@\" statement, then executes the supplied action. If -- the action succeeds, the transaction will be completed with -- 'Base.commit' before this function returns. -- -- If the action throws /any/ kind of exception (not just a -- PostgreSQL-related exception), the transaction will be rolled back using -- 'rollback', then the exception will be rethrown. -- -- For nesting transactions, see 'withSavepoint'. withTransaction :: Connection -> IO a -> IO a withTransaction = withTransactionMode defaultTransactionMode -- | Execute an action inside of a 'Serializable' transaction. If a -- serialization failure occurs, roll back the transaction and try again. -- Be warned that this may execute the IO action multiple times. -- -- A 'Serializable' transaction creates the illusion that your program has -- exclusive access to the database. This means that, even in a concurrent -- setting, you can perform queries in sequence without having to worry about -- what might happen between one statement and the next. -- -- Think of it as STM, but without @retry@. withTransactionSerializable :: Connection -> IO a -> IO a withTransactionSerializable = withTransactionModeRetry TransactionMode { isolationLevel = Serializable , readWriteMode = ReadWrite } isSerializationError -- | Execute an action inside a SQL transaction with a given isolation level. withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a withTransactionLevel lvl = withTransactionMode defaultTransactionMode { isolationLevel = lvl } -- | Execute an action inside a SQL transaction with a given transaction mode. withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a withTransactionMode mode conn act = mask $ \restore -> do beginMode mode conn r <- restore act `E.onException` rollback conn commit conn return r -- | Like 'withTransactionMode', but also takes a custom callback to -- determine if a transaction should be retried if an 'SqlError' occurs. -- If the callback returns True, then the transaction will be retried. -- If the callback returns False, or an exception other than an 'SqlError' -- occurs then the transaction will be rolled back and the exception rethrown. -- -- This is used to implement 'withTransactionSerializable'. withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a withTransactionModeRetry mode shouldRetry conn act = mask $ \restore -> retryLoop $ E.try $ do a <- restore act commit conn return a where retryLoop :: IO (Either E.SomeException a) -> IO a retryLoop act' = do beginMode mode conn r <- act' case r of Left e -> do rollback conn case fmap shouldRetry (E.fromException e) of Just True -> retryLoop act' _ -> E.throwIO e Right a -> return a -- | Rollback a transaction. rollback :: Connection -> IO () rollback conn = execute_ conn "ABORT" >> return () -- | Commit a transaction. commit :: Connection -> IO () commit conn = execute_ conn "COMMIT" >> return () -- | Begin a transaction. begin :: Connection -> IO () begin = beginMode defaultTransactionMode -- | Begin a transaction with a given isolation level beginLevel :: IsolationLevel -> Connection -> IO () beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } -- | Begin a transaction with a given transaction mode beginMode :: TransactionMode -> Connection -> IO () beginMode mode conn = do _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) return () where isolevel = case isolationLevel mode of DefaultIsolationLevel -> "" ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" Serializable -> " ISOLATION LEVEL SERIALIZABLE" readmode = case readWriteMode mode of DefaultReadWriteMode -> "" ReadWrite -> " READ WRITE" ReadOnly -> " READ ONLY" ------------------------------------------------------------------------ -- Savepoint -- | Create a savepoint, and roll back to it if an error occurs. This may only -- be used inside of a transaction, and provides a sort of -- \"nested transaction\". -- -- See withSavepoint :: Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do sp <- newSavepoint conn r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp releaseSavepoint conn sp `E.catch` \err -> if isFailedTransactionError err then rollbackToAndReleaseSavepoint conn sp else E.throwIO err return r -- | Create a new savepoint. This may only be used inside of a transaction. newSavepoint :: Connection -> IO Savepoint newSavepoint conn = do name <- newTempName conn _ <- execute_ conn ("SAVEPOINT " <> name) return (Savepoint name) -- | Destroy a savepoint, but retain its effects. -- -- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if -- the transaction is aborted due to an error. 'commit' would merely warn and -- roll back. releaseSavepoint :: Connection -> Savepoint -> IO () releaseSavepoint conn (Savepoint name) = execute_ conn ("RELEASE SAVEPOINT " <> name) >> return () -- | Roll back to a savepoint. This will not release the savepoint. rollbackToSavepoint :: Connection -> Savepoint -> IO () rollbackToSavepoint conn (Savepoint name) = execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return () -- | Roll back to a savepoint and release it. This is like calling -- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a -- round trip to the database server. rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO () rollbackToAndReleaseSavepoint conn (Savepoint name) = execute_ conn sql >> return () where sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Notification.hs0000644000000000000000000001101212633616517024253 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.Notification -- Copyright : (c) 2011-2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- Stability : experimental -- -- Support for receiving asynchronous notifications via PostgreSQL's -- Listen/Notify mechanism. See -- for more -- information. -- -- Note that on Windows, @getNotification@ currently uses a polling loop -- of 1 second to check for more notifications, due to some inadequacies -- in GHC's IO implementation and interface on that platform. See GHC -- issue #7353 for more information. While this workaround is less than -- ideal, notifications are still better than polling the database directly. -- Notifications do not create any extra work for the backend, and are -- likely cheaper on the client side as well. -- -- -- ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.Notification ( Notification(..) , getNotification , getNotificationNonBlocking , getBackendPID ) where import Control.Concurrent import Control.Monad ( when ) import Control.Exception ( throwIO ) import qualified Data.ByteString as B import Database.PostgreSQL.Simple.Internal import qualified Database.PostgreSQL.LibPQ as PQ import System.Posix.Types ( CPid ) data Notification = Notification { notificationPid :: !CPid , notificationChannel :: !B.ByteString , notificationData :: !B.ByteString } convertNotice :: PQ.Notify -> Notification convertNotice PQ.Notify{..} = Notification { notificationPid = notifyBePid , notificationChannel = notifyRelname , notificationData = notifyExtra } -- | Returns a single notification. If no notifications are available, -- 'getNotification' blocks until one arrives. getNotification :: Connection -> IO Notification getNotification conn = loop False where funcName = "Database.PostgreSQL.Simple.Notification.getNotification" loop doConsume = do res <- withConnection conn $ \c -> do when doConsume (PQ.consumeInput c >> return ()) mmsg <- PQ.notifies c case mmsg of Nothing -> do mfd <- PQ.socket c case mfd of Nothing -> throwIO $ fdError funcName Just fd -> return (Left fd) Just msg -> return (Right msg) -- FIXME? what happens if the connection is closed/reset right here? case res of #if defined(mingw32_HOST_OS) -- threadWaitRead doesn't work for sockets on Windows, so just poll -- for input every second (PQconsumeInput is non-blocking). -- -- We could call select(), but FFI calls can't be interrupted with -- async exceptions, whereas threadDelay can. Left _fd -> threadDelay 1000000 >> loop True #else Left fd -> threadWaitRead fd >> loop True #endif Right msg -> return $! convertNotice msg -- | Non-blocking variant of 'getNotification'. Returns a single notification, -- if available. If no notifications are available, returns 'Nothing'. getNotificationNonBlocking :: Connection -> IO (Maybe Notification) getNotificationNonBlocking conn = withConnection conn $ \c -> do mmsg <- PQ.notifies c case mmsg of Just msg -> return $! Just $! convertNotice msg Nothing -> do _ <- PQ.consumeInput c mmsg' <- PQ.notifies c case mmsg' of Just msg -> return $! Just $! convertNotice msg Nothing -> return Nothing -- | Returns the process 'CPid' of the backend server process -- handling this connection. -- -- The backend PID is useful for debugging purposes and for comparison -- to NOTIFY messages (which include the PID of the notifying backend -- process). Note that the PID belongs to a process executing on the -- database server host, not the local host! getBackendPID :: Connection -> IO CPid getBackendPID conn = withConnection conn PQ.backendPID postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Compat.hs0000644000000000000000000000447412633616517023066 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | This is a module of its own, partly because it uses the CPP extension, -- which doesn't play well with backslash-broken string literals. module Database.PostgreSQL.Simple.Compat ( mask , (<>) , unsafeDupablePerformIO , toByteString , scientificBuilder , toPico , fromPico ) where import qualified Control.Exception as E import Data.Monoid import Data.ByteString (ByteString) #if MIN_VERSION_bytestring(0,10,0) import Data.ByteString.Lazy (toStrict) #else import qualified Data.ByteString as B import Data.ByteString.Lazy (toChunks) #endif import Data.ByteString.Builder (Builder, toLazyByteString) #if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) #else import Data.Scientific (scientificBuilder) #endif #if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) #elif __GLASGOW_HASKELL__ >= 611 import GHC.IO (unsafeDupablePerformIO) #else import GHC.IOBase (unsafeDupablePerformIO) #endif import Data.Fixed (Pico) #if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(MkFixed)) #else import Unsafe.Coerce (unsafeCoerce) #endif -- | Like 'E.mask', but backported to base before version 4.3.0. -- -- Note that the restore callback is monomorphic, unlike in 'E.mask'. This -- could be fixed by changing the type signature, but it would require us to -- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The -- 'withTransactionMode' function calls the restore callback only once, so we -- don't need that polymorphism. mask :: ((IO a -> IO a) -> IO b) -> IO b #if MIN_VERSION_base(4,3,0) mask io = E.mask $ \restore -> io restore #else mask io = do b <- E.blocked E.block $ io $ \m -> if b then m else E.unblock m #endif {-# INLINE mask #-} #if !MIN_VERSION_base(4,5,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif toByteString :: Builder -> ByteString #if MIN_VERSION_bytestring(0,10,0) toByteString x = toStrict (toLazyByteString x) #else toByteString x = B.concat (toChunks (toLazyByteString x)) #endif #if MIN_VERSION_base(4,7,0) toPico :: Integer -> Pico toPico = MkFixed fromPico :: Pico -> Integer fromPico (MkFixed i) = i #else toPico :: Integer -> Pico toPico = unsafeCoerce fromPico :: Pico -> Integer fromPico = unsafeCoerce #endif postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToField.hs-boot0000644000000000000000000000220512633616517024120 0ustar0000000000000000module Database.PostgreSQL.Simple.ToField where import Database.PostgreSQL.Simple.Types import Data.ByteString.Builder(Builder) import Data.ByteString(ByteString) -- | How to render an element when substituting it into a query. data Action = Plain Builder -- ^ Render without escaping or quoting. Use for non-text types -- such as numbers, when you are /certain/ that they will not -- introduce formatting vulnerabilities via use of characters such -- as spaces or \"@'@\". | Escape ByteString -- ^ Escape and enclose in quotes before substituting. Use for all -- text-like types, and anything else that may contain unsafe -- characters when rendered. | EscapeByteA ByteString -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding -- quotes. This is used by the 'Binary' newtype wrapper. | EscapeIdentifier ByteString -- ^ Escape before substituting. Use for all sql identifiers like -- table, column names, etc. This is used by the 'Identifier' newtype -- wrapper. | Many [Action] -- ^ Concatenate a series of rendering actions. class ToField a instance ToField Oid postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Arrays.hs0000644000000000000000000000665012633616517023102 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Arrays -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A Postgres array parser and pretty-printer. ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Arrays where import Control.Applicative (Applicative(..), Alternative(..), (<$>)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Monoid import Data.Attoparsec.ByteString.Char8 -- | Parse one of three primitive field formats: array, quoted and plain. arrayFormat :: Char -> Parser ArrayFormat arrayFormat delim = Array <$> array delim <|> Plain <$> plain delim <|> Quoted <$> quoted data ArrayFormat = Array [ArrayFormat] | Plain ByteString | Quoted ByteString deriving (Eq, Show, Ord) array :: Char -> Parser [ArrayFormat] array delim = char '{' *> option [] (arrays <|> strings) <* char '}' where strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) arrays = sepBy1 (Array <$> array delim) (char ',') -- NB: Arrays seem to always be delimited by commas. -- | Recognizes a quoted string. quoted :: Parser ByteString quoted = char '"' *> option "" contents <* char '"' where esc = char '\\' *> (char '\\' <|> char '"') unQ = takeWhile1 (notInClass "\"\\") contents = mconcat <$> many (unQ <|> B.singleton <$> esc) -- | Recognizes a plain string literal, not containing quotes or brackets and -- not containing the delimiter character. plain :: Char -> Parser ByteString plain delim = takeWhile1 (notInClass (delim:"\"{}")) -- Mutually recursive 'fmt' and 'delimit' separate out value formatting -- from the subtleties of delimiting. -- | Format an array format item, using the delimiter character if the item is -- itself an array. fmt :: Char -> ArrayFormat -> ByteString fmt = fmt' False -- | Format a list of array format items, inserting the appropriate delimiter -- between them. When the items are arrays, they will be delimited with -- commas; otherwise, they are delimited with the passed-in-delimiter. delimit :: Char -> [ArrayFormat] -> ByteString delimit _ [] = "" delimit c [x] = fmt' True c x delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) where c' | Array _ <- x = ',' | otherwise = c -- | Format an array format item, using the delimiter character if the item is -- itself an array, optionally applying quoting rules. Creates copies for -- safety when used in 'FromField' instances. fmt' :: Bool -> Char -> ArrayFormat -> ByteString fmt' quoting c x = case x of Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') Plain bytes -> B.copy bytes Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"') | otherwise -> B.copy q -- NB: The 'snoc' and 'cons' functions always copy. -- | Escape a string according to Postgres double-quoted string format. esc :: ByteString -> ByteString esc = B.concatMap f where f '"' = "\\\"" f '\\' = "\\\\" f c = B.singleton c -- TODO: Implement easy performance improvements with unfoldr. postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time.hs0000644000000000000000000002776712633616517022553 0ustar0000000000000000{- | Module: Database.PostgreSQL.Simple.Time Copyright: (c) 2012-2015 Leon P Smith License: BSD3 Maintainer: Leon P Smith Stability: experimental This module provides time types that supports positive and negative infinity, as well as some functions for converting to and from strings. Also, this module also contains commentary regarding postgresql's timestamp types, civil timekeeping in general, and how it relates to postgresql-simple. You can read more about PostgreSQL's date and time types at , and the IANA time zone database at . Stack Overflow also has some excellent commentary on time, if it is a wiki page or a highly upvoted question and answer. If the answer regarding time has not received about a hundred upvotes at least, then the answer is almost invariably completely and painfully wrong, even if it's the chosen answer or the most highly upvoted answer to a question. PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types, because values of these types represent a self-contained, unambiguous point in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@) can be converted to Haskell's 'Data.Time.LocalTime', because values of these types are ambiguous by themselves, and require context to disambiguate. While this behavior may be superficially counterintuitive because the names might suggest otherwise, this behavior is correct. In fact, the \"timezone\" language in both the postgresql and haskell types would be better read as \"offset (from UTC)\", thus we have postgresql's \"timestamp with offset\" corresponding to Haskell's \"time with the offset \'zero\'\" and Haskell's \"time with an offset (that might be nonzero)\". Similarly, postgresql's \"timestamp without an offset\" corresponds to Haskell's \"local time (without an offset)\". It's important to distinguish between an offset, a standard time, and a time zone. An offset is simply a difference of a local time from UTC, such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset (which may vary throughout the year, due to daylight savings) that a region follows, such as Universal Coordinated Time (UTC), Eastern Standard Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST). And a time zone, much like a standard time, is a function from timestamps to offsets. A time zone is different from a standard time because different regions inside a standard time can be governed by different civil authorities with different laws and thus have different histories of civil time. An IANA time zone is any region of the world that has had the same history of civil time since @1970-01-01 00:00+00@. For example, as of today, both @America\/New_York@ and @America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but Indiana used to be on Central Standard Time until 1942, and did not observe daylight savings time (EST only) until 2006. Thus, the choice between these two time zones still matters if you are dealing with timestamps prior to 2006, and could become relevant again if (most of) Indiana moves back to Central Time. (Of course, if the Central to Eastern switch was the only difference, then these two time zones would be the same in IANA's eyes, due to their cutoff date of 1970-01-01.) Getting back to practicalities, PostgreSQL's @timestamptz@ type does not actually store an offset; rather, it uses the offset provided to calculate UTC, and stores the timestamp as UTC. If an offset is not provided, the given timestamp is assumed to be a local time for whatever the @timezone@ variable is set to, and the IANA TZ database is consulted to calculate an offset from UTC for the time in question. Note that while most (local timestamp, time zone) pairs correspond to exactly one UTC timestamp, some correspond to two UTC timestamps, while others correspond to none at all. The ambiguous case occurs when the civil time is rolled back, making a calendar day longer than 24 hours. In this case, PostgreSQL silently chooses the second, later possibility. The inconsistent case occurs when the civil time is moved forward, making a calendar day less than 24 hours. In this case, PostgreSQL silently assumes the local time was read off a clock that had not been moved forward at the prescribed time, and moves the clock forward for you. Thus, converting from local time to UTC need not be monotonic, if these inconsistent cases are allowed. When retrieving a @timestamptz@, the backend looks at the @time zone@ connection variable and then consults the IANA TZ database to calculate an offset for the timestamp in the given time zone. Note that while some of the information contained in the IANA TZ database is a bit of a standardized fiction, the conversion from UTC time to a (local time, offset) pair in a particular time zone is always unambiguous, and the result can always be unambiguously converted back to UTC. Thus, postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime', or use the offset to convert back to 'Data.Time.UTCTime'. By contrast, the @timestamp@ type ignores any offsets provided to it, and never sends back an offset. Thus, postgresql-simple equates this with 'Data.Time.LocalTime', which has no concept of an offset. One can convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@ operator, whose semantics also demonstrates that @timestamptz@ is 'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'. PostgreSQL's @timezone@ is a per-connection variable that by default is initialized to @\'localtime\'@, which normally corresponds to the server's time zone. However, this default can be modified on the server side for an entire cluster, or on a per-user or per-database basis. Moreover, a client can modify their instance of the variable at any time, and can apply that change to the remaining duration of the connection, the current transaction, or the execution context of a server-side function. In addition, upon connection initialization, the libpq client checks for the existence of the @PGTZ@ environment variable, and if it exists, modifies @timezone@ accordingly. With a few caveats, postgresql-simple is designed so that you can both send and receive timestamps with the server and get a correct result, no matter what the @timezone@ setting is. But it is important to understand the caveats: 1. The correctness of server-side computations can depend on the @timezone@ setting. Examples include adding an @interval@ to a @timestamptz@, or type casting between @timestamp@ and @timestamptz@, or applying the @DATE@ function to a @timestamptz@. 2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result will depend on the @timezone@ setting, although the result will always represent the same instant in time regardless of the time zone. 3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@ can be useful, as it will be converted to UTC via the tz database, but correctness will depend on the @timezone@ setting. You may prefer to use an explicit @AT TIME ZONE@ conversion instead, which would avoid this contextual dependence. Furthermore, although these following points don't involve the @timezone@ setting, they are related to the last point above: 1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can be useful. In practice, the most common context used to disambiguate @timestamp@ is that it represents UTC, and this coding technique will work as expected in this situation. 2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is almost always the wrong thing to do, as the offset will be ignored and discarded. This is likely to lead to inconsistencies in the database, and may lead to partial data loss. When dealing with local timestamps that refer to the future, it is often useful to store it as a local time in a @timestamp@ column and store the time zone in a second column. One reason to do this is so that you can convert to UTC on the fly as needed, and be protected against future changes to the TZ database due to changes in local time standards. In any case, 'Data.Time.ZonedTime' is not suitable for this application, because despite its name, it represents an offset and not a time zone. Time zones can change; offsets do not. In reality, we can't convert a local timestamp that occurs sufficiently far in the future to UTC, because we don't know how to do it yet. There are a few limitations and caveats that one might need to be aware of with the current implementation when dealing with older timestamps: For sufficiently old timestamps in almost all time zones, the IANA TZ database specifies offsets from UTC that is not an integral number of minutes. This corresponds to local mean time; that is, astronomical time in the city that defines the time zone. Different time zones moved away from local mean time to a standard time at different points in history, so \"sufficiently old\" depends on the time zone in question. Thus, when retrieving a @timestamptz@ postgresql will in some cases provide seconds in the offset. For example: @ $ psql psql (9.4.5) Type \"help\" for help. lpsmith=> SET timezone TO \'America/New_York\'; SET lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz), (\'1883-11-18 17:00:00+00\'::timestamptz); column1 ------------------------------ 1883-11-18 12:03:57-04:56:02 1883-11-18 12:00:00-05 (2 rows) @ Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type, however 'Data.Time.ZonedTime' will fail on the former timestamp. Because 'Data.Time.ZonedTime' assumes that offsets are an integer number of minutes, there isn't an particularly good solution here. PostgreSQL, like most software, uses the proleptic Gregorian calendar for its date calculations, extending the Gregorian calendar backwards in time before its introduction and pretending that the Julian calendar does not exist. For most purposes, the adoption of the Gregorian calendar ranges from @1582-10-15@ to @1923-03-01@, depending on location and sometimes even political allegiances within a single location. Timestamps BCE are not supported. For example, PostgreSQL will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of the year the Roman Empire adopted the Julian Calendar, but postgresql-simple does not (yet?) have the ability to either parse or generate this syntax. Unfortunately this syntax isn't convenient to print or especially parse. Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@, which is the Julian date on the proleptic Gregorian Calendar. Although postgresql's timestamp types are perfectly capable of representing timestamps nearly 300,000 years in the past, using this would require postgresql-simple and other client programs to support binary parameters and results. Dealing with years BCE is also complicated slightly by the fact that Haskell's time library has a year \"0000\", which is a convention often used by astronomers, while postgresql adopts the more historically accurate convention that there is no year zero, but rather \"1 BCE\" was immediately followed by \"1 CE\". -} module Database.PostgreSQL.Simple.Time ( Unbounded(..) , Date , UTCTimestamp , ZonedTimestamp , LocalTimestamp , parseDay , parseUTCTime , parseZonedTime , parseLocalTime , parseTimeOfDay , parseDate , parseUTCTimestamp , parseZonedTimestamp , parseLocalTimestamp , dayToBuilder , utcTimeToBuilder , zonedTimeToBuilder , localTimeToBuilder , timeOfDayToBuilder , timeZoneToBuilder , dateToBuilder , utcTimestampToBuilder , zonedTimestampToBuilder , localTimestampToBuilder , unboundedToBuilder , nominalDiffTimeToBuilder ) where import Database.PostgreSQL.Simple.Time.Implementation postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromField.hs0000644000000000000000000005764512633616517023522 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards, TemplateHaskell #-} {- | Module: Database.PostgreSQL.Simple.FromField Copyright: (c) 2011 MailRank, Inc. (c) 2011-2013 Leon P Smith License: BSD3 Maintainer: Leon P Smith Stability: experimental The 'FromField' typeclass, for converting a single value in a row returned by a SQL query into a more useful Haskell representation. Note that each instance of 'FromField' is documented by a list of compatible postgresql types. A Haskell numeric type is considered to be compatible with all PostgreSQL numeric types that are less accurate than it. For instance, the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit @int@ type because it can represent a @int@ exactly. On the other hand, since a 'Double' might lose precision if representing PostgreSQL's 64-bit @bigint@, the two are /not/ considered compatible. Note that the 'Float' and 'Double' instances use attoparsec's 'double' conversion routine, which sacrifices some accuracy for speed. If you need accuracy, consider first converting data to a 'Scientific' or 'Rational' type, and then converting to a floating-point type. If you are defining your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be achieved simply by @'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@ types. If this is unacceptable, you may find 'Database.PostgreSQL.Simple.FromRow.fieldWith' useful. Also note that while converting to a 'Double' through the 'Scientific' type is likely somewhat faster than converting through the 'Rational' type, the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values. Thus, if you need precision conversion of regular floating point values and the possibility of receiving these special values from the backend, stick with 'Rational'. Because 'FromField' is a typeclass, one may provide conversions to additional Haskell types without modifying postgresql-simple. This is particularly useful for supporting PostgreSQL types that postgresql-simple does not support out-of-box. Here's an example of what such an instance might look like for a UUID type that implements the @Read@ class: @ import Data.UUID ( UUID ) import Database.PostgreSQL.Simple.FromField ( FromField (fromField) , typeOid, returnError, ResultError (..) ) import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid) import qualified Data.ByteString.Char8 as B instance FromField UUID where fromField f mdata = if typeOid f /= typoid uuid then returnError Incompatible f \"\" else case B.unpack \`fmap\` mdata of Nothing -> returnError UnexpectedNull f \"\" Just dat -> case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of [x] -> return x _ -> returnError ConversionFailed f dat @ Note that because PostgreSQL's @uuid@ type is built into postgres and is not provided by an extension, the 'typeOid' of @uuid@ does not change and thus we can examine it directly. One could hard-code the type oid, or obtain it by other means, but in this case we simply pull it out of the static table provided by postgresql-simple. On the other hand if the type is provided by an extension, such as @PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from database to database. In this case it is recommended that FromField instances use 'typename' instead. -} module Database.PostgreSQL.Simple.FromField ( FromField(..) , FieldParser , Conversion() , runConversion , conversionMap , conversionError , ResultError(..) , returnError , Field , typename , TypeInfo(..) , Attribute(..) , typeInfo , typeInfoByOid , name , tableOid , tableColumn , format , typeOid , PQ.Oid(..) , PQ.Format(..) , pgArrayFieldParser , fromJSONField ) where #include "MachDeps.h" import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) import qualified Data.Aeson as JSON import qualified Data.Aeson.Parser as JSON (value') import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int16, Int32, Int64) import Data.IORef (IORef, newIORef) import Data.Ratio (Ratio) import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay ) import Data.Typeable (Typeable, typeOf) import Data.Vector (Vector) import Data.Vector.Mutable (IOVector) import qualified Data.Vector as V import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo as TI import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI import Database.PostgreSQL.Simple.TypeInfo.Macro as TI import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID import Data.Scientific (Scientific) import GHC.Real (infinity, notANumber) -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. data ResultError = Incompatible { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL and Haskell types are not compatible. | UnexpectedNull { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ A SQL @NULL@ was encountered when the Haskell -- type did not permit it. | ConversionFailed { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL value could not be parsed, or could not -- be represented as a valid Haskell value, or an -- unexpected low-level error occurred (e.g. mismatch -- between metadata and actual data in a row). deriving (Eq, Show, Typeable) instance Exception ResultError left :: Exception a => a -> Conversion b left = conversionError type FieldParser a = Field -> Maybe ByteString -> Conversion a -- | A type that may be converted from a SQL type. class FromField a where fromField :: FieldParser a -- ^ Convert a SQL value to a Haskell value. -- -- Returns a list of exceptions if the conversion fails. In the case of -- library instances, this will usually be a single 'ResultError', but -- may be a 'UnicodeException'. -- -- Note that retaining any reference to the 'Field' argument causes -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations -- of 'fromField' should return results that do not refer to this value -- after the result have been evaluated to WHNF. -- -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has -- been passed to 'fromField'. This is because for short strings, it's -- cheaper to copy the string than to set up a finalizer. -- | Returns the data type name. This is the preferred way of identifying -- types that do not have a stable type oid, such as types provided by -- extensions to PostgreSQL. -- -- More concretely, it returns the @typname@ column associated with the -- type oid in the @pg_type@ table. First, postgresql-simple will check -- the built-in, static table. If the type oid is not there, -- postgresql-simple will check a per-connection cache, and then -- finally query the database's meta-schema. typename :: Field -> Conversion ByteString typename field = typname <$> typeInfo field typeInfo :: Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do Ok <$> (getTypeInfo conn typeOid) typeInfoByOid :: PQ.Oid -> Conversion TypeInfo typeInfoByOid oid = Conversion $ \conn -> do Ok <$> (getTypeInfo conn oid) -- | Returns the name of the column. This is often determined by a table -- definition, but it can be set using an @as@ clause. name :: Field -> Maybe ByteString name Field{..} = unsafeDupablePerformIO (PQ.fname result column) -- | Returns the name of the object id of the @table@ associated with the -- column, if any. Returns 'Nothing' when there is no such table; -- for example a computed column does not have a table associated with it. -- Analogous to libpq's @PQftable@. tableOid :: Field -> Maybe PQ.Oid tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column)) where toMaybeOid x = if x == PQ.invalidOid then Nothing else Just x -- | If the column has a table associated with it, this returns the number -- off the associated table column. Numbering starts from 0. Analogous -- to libpq's @PQftablecol@. tableColumn :: Field -> Int tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column)) where fromCol (PQ.Col x) = fromIntegral x -- | This returns whether the data was returned in a binary or textual format. -- Analogous to libpq's @PQfformat@. format :: Field -> PQ.Format format Field{..} = unsafeDupablePerformIO (PQ.fformat result column) -- | void instance FromField () where fromField f _bs | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f "" | otherwise = pure () -- | For dealing with null values. Compatible with any postgresql type -- compatible with type @a@. Note that the type is not checked if -- the value is null, although it is inadvisable to rely on this -- behavior. instance (FromField a) => FromField (Maybe a) where fromField _ Nothing = pure Nothing fromField f bs = Just <$> fromField f bs -- | compatible with any data type, but the value must be null instance FromField Null where fromField _ Nothing = pure Null fromField f (Just _) = returnError ConversionFailed f "data is not null" -- | bool instance FromField Bool where fromField f bs | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f "" | bs == Nothing = returnError UnexpectedNull f "" | bs == Just "t" = pure True | bs == Just "f" = pure False | otherwise = returnError ConversionFailed f "" -- | \"char\" instance FromField Char where fromField f bs = if typeOid f /= $(inlineTypoid TI.char) then returnError Incompatible f "" else case bs of Nothing -> returnError UnexpectedNull f "" Just bs -> if B.length bs /= 1 then returnError ConversionFailed f "length not 1" else return $! (B.head bs) -- | int2 instance FromField Int16 where fromField = atto ok16 $ signed decimal -- | int2, int4 instance FromField Int32 where fromField = atto ok32 $ signed decimal #if WORD_SIZE_IN_BITS < 64 -- | int2, int4, and if compiled as 64-bit code, int8 as well. -- This library was compiled as 32-bit code. #else -- | int2, int4, and if compiled as 64-bit code, int8 as well. -- This library was compiled as 64-bit code. #endif instance FromField Int where fromField = atto okInt $ signed decimal -- | int2, int4, int8 instance FromField Int64 where fromField = atto ok64 $ signed decimal -- | int2, int4, int8 instance FromField Integer where fromField = atto ok64 $ signed decimal -- | int2, float4 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Float where fromField = atto ok (realToFrac <$> pg_double) where ok = $(mkCompats [TI.float4,TI.int2]) -- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Double where fromField = atto ok pg_double where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4]) -- | int2, int4, int8, float4, float8, numeric instance FromField (Ratio Integer) where fromField = atto ok pg_rational where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) -- | int2, int4, int8, float4, float8, numeric instance FromField Scientific where fromField = atto ok rational where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) unBinary :: Binary t -> t unBinary (Binary x) = x pg_double :: Parser Double pg_double = (string "NaN" *> pure ( 0 / 0)) <|> (string "Infinity" *> pure ( 1 / 0)) <|> (string "-Infinity" *> pure (-1 / 0)) <|> double pg_rational :: Parser Rational pg_rational = (string "NaN" *> pure notANumber ) <|> (string "Infinity" *> pure infinity ) <|> (string "-Infinity" *> pure (-infinity)) <|> rational -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField SB.ByteString where fromField f dat = if typeOid f == $(inlineTypoid TI.bytea) then unBinary <$> fromField f dat else doFromField f okText' pure dat -- | oid instance FromField PQ.Oid where fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat unescapeBytea :: Field -> SB.ByteString -> Conversion (Binary SB.ByteString) unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) -- | bytea instance FromField (Binary SB.ByteString) where fromField f dat = case format f of PQ.Text -> doFromField f okBinary (unescapeBytea f) dat PQ.Binary -> doFromField f okBinary (pure . Binary) dat -- | bytea instance FromField (Binary LB.ByteString) where fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat -- | name, text, \"char\", bpchar, varchar instance FromField ST.Text where fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8') -- FIXME: check character encoding -- | name, text, \"char\", bpchar, varchar instance FromField LT.Text where fromField f dat = LT.fromStrict <$> fromField f dat -- | citext instance FromField (CI ST.Text) where fromField f mdat = do typ <- typename f if typ /= "citext" then returnError Incompatible f "" else case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> either left (pure . CI.mk) (ST.decodeUtf8' dat) -- | citext instance FromField (CI LT.Text) where fromField f mdat = do typ <- typename f if typ /= "citext" then returnError Incompatible f "" else case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> either left (pure . CI.mk . LT.fromStrict) (ST.decodeUtf8' dat) -- | name, text, \"char\", bpchar, varchar instance FromField [Char] where fromField f dat = ST.unpack <$> fromField f dat -- | timestamptz instance FromField UTCTime where fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime -- | timestamptz instance FromField ZonedTime where fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime -- | timestamp instance FromField LocalTime where fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime -- | date instance FromField Day where fromField = ff $(inlineTypoid TI.date) "Day" parseDay -- | time instance FromField TimeOfDay where fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay -- | timestamptz instance FromField UTCTimestamp where fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp -- | timestamptz instance FromField ZonedTimestamp where fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp -- | timestamp instance FromField LocalTimestamp where fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp -- | date instance FromField Date where fromField = ff $(inlineTypoid TI.date) "Date" parseDate ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a) -> Field -> Maybe B8.ByteString -> Conversion a ff compatOid hsType parse f mstr = if typeOid f /= compatOid then err Incompatible "" else case mstr of Nothing -> err UnexpectedNull "" Just str -> case parse str of Left msg -> err ConversionFailed msg Right val -> return val where err errC msg = do typnam <- typename f left $ errC (B8.unpack typnam) (tableOid f) (maybe "" B8.unpack (name f)) hsType msg {-# INLINE ff #-} -- | Compatible with both types. Conversions to type @b@ are -- preferred, the conversion to type @a@ will be tried after -- the 'Right' conversion fails. instance (FromField a, FromField b) => FromField (Either a b) where fromField f dat = (Right <$> fromField f dat) <|> (Left <$> fromField f dat) -- | any postgresql array whose elements are compatible with type @a@ instance (FromField a, Typeable a) => FromField (PGArray a) where fromField = pgArrayFieldParser fromField pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a) pgArrayFieldParser fieldParser f mdat = do info <- typeInfo f case info of TI.Array{} -> case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> do case parseOnly (fromArray fieldParser info f) dat of Left err -> returnError ConversionFailed f err Right conv -> PGArray <$> conv _ -> returnError Incompatible f "" fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a]) fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim where delim = typdelim (typelem typeInfo) fElem = f{ typeOid = typoid (typelem typeInfo) } parseIt item = fieldParser f' $ if item' == "NULL" then Nothing else Just item' where item' = fmt delim item f' | Arrays.Array _ <- item = f | otherwise = fElem instance (FromField a, Typeable a) => FromField (Vector a) where fromField f v = V.fromList . fromPGArray <$> fromField f v instance (FromField a, Typeable a) => FromField (IOVector a) where fromField f v = liftConversion . V.unsafeThaw =<< fromField f v -- | uuid instance FromField UUID where fromField f mbs = if typeOid f /= $(inlineTypoid TI.uuid) then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f "" Just bs -> case UUID.fromASCIIBytes bs of Nothing -> returnError ConversionFailed f "Invalid UUID" Just uuid -> pure uuid -- | json instance FromField JSON.Value where fromField f mbs = if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb) then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f "" Just bs -> case parseOnly (JSON.value' <* endOfInput) bs of Left err -> returnError ConversionFailed f err Right val -> pure val -- | Parse a field to a JSON 'JSON.Value' and convert that into a -- Haskell value using 'JSON.fromJSON'. -- -- This can be used as the default implementation for the 'fromField' -- method for Haskell types that have a JSON representation in -- PostgreSQL. -- -- The 'Typeable' constraint is required to show more informative -- error messages when parsing fails. fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a fromJSONField f mbBs = do value <- fromField f mbBs case JSON.fromJSON value of JSON.Error err -> returnError ConversionFailed f $ "JSON decoding error: " ++ err JSON.Success x -> pure x -- | Compatible with the same set of types as @a@. Note that -- modifying the 'IORef' does not have any effects outside -- the local process on the local machine. instance FromField a => FromField (IORef a) where fromField f v = liftConversion . newIORef =<< fromField f v -- | Compatible with the same set of types as @a@. Note that -- modifying the 'MVar' does not have any effects outside -- the local process on the local machine. instance FromField a => FromField (MVar a) where fromField f v = liftConversion . newMVar =<< fromField f v type Compat = PQ.Oid -> Bool okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat okText = $( mkCompats [ TI.name, TI.text, TI.char, TI.bpchar, TI.varchar ] ) okText' = $( mkCompats [ TI.name, TI.text, TI.char, TI.bpchar, TI.varchar, TI.unknown ] ) okBinary = (== $( inlineTypoid TI.bytea )) ok16 = (== $( inlineTypoid TI.int2 )) ok32 = $( mkCompats [TI.int2,TI.int4] ) ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] ) #if WORD_SIZE_IN_BITS < 64 okInt = ok32 #else okInt = ok64 #endif doFromField :: forall a . (Typeable a) => Field -> Compat -> (ByteString -> Conversion a) -> Maybe ByteString -> Conversion a doFromField f isCompat cvt (Just bs) | isCompat (typeOid f) = cvt bs | otherwise = returnError Incompatible f "types incompatible" doFromField f _ _ _ = returnError UnexpectedNull f "" -- | Given one of the constructors from 'ResultError', the field, -- and an 'errMessage', this fills in the other fields in the -- exception value and returns it in a 'Left . SomeException' -- constructor. returnError :: forall a err . (Typeable a, Exception err) => (String -> Maybe PQ.Oid -> String -> String -> String -> err) -> Field -> String -> Conversion a returnError mkErr f msg = do typnam <- typename f left $ mkErr (B.unpack typnam) (tableOid f) (maybe "" B.unpack (name f)) (show (typeOf (undefined :: a))) msg atto :: forall a. (Typeable a) => Compat -> Parser a -> Field -> Maybe ByteString -> Conversion a atto types p0 f dat = doFromField f types (go p0) dat where go :: Parser a -> ByteString -> Conversion a go p s = case parseOnly p s of Left err -> returnError ConversionFailed f err Right v -> pure v postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToField.hs0000644000000000000000000003043512633616517023165 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToField -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'ToField' typeclass, for rendering a parameter to a SQL query. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.ToField ( Action(..) , ToField(..) , toJSONField , inQuotes ) where import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import Data.ByteString.Builder ( Builder, byteString, char8, stringUtf8 , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec , wordDec, word8Dec, word16Dec, word32Dec, word64Dec , floatDec, doubleDec ) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend) import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64) import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Compat (toByteString) import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time import Data.Scientific (Scientific) #if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) #else import Data.Scientific (scientificBuilder) #endif import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. data Action = Plain Builder -- ^ Render without escaping or quoting. Use for non-text types -- such as numbers, when you are /certain/ that they will not -- introduce formatting vulnerabilities via use of characters such -- as spaces or \"@'@\". | Escape ByteString -- ^ Escape and enclose in quotes before substituting. Use for all -- text-like types, and anything else that may contain unsafe -- characters when rendered. | EscapeByteA ByteString -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding -- quotes. This is used by the 'Binary' newtype wrapper. | EscapeIdentifier ByteString -- ^ Escape before substituting. Use for all sql identifiers like -- table, column names, etc. This is used by the 'Identifier' newtype -- wrapper. | Many [Action] -- ^ Concatenate a series of rendering actions. deriving (Typeable) instance Show Action where show (Plain b) = "Plain " ++ show (toByteString b) show (Escape b) = "Escape " ++ show b show (EscapeByteA b) = "EscapeByteA " ++ show b show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b show (Many b) = "Many " ++ show b -- | A type that may be used as a single parameter to a SQL query. class ToField a where toField :: a -> Action -- ^ Prepare a value for substitution into a query string. instance ToField Action where toField a = a {-# INLINE toField #-} instance (ToField a) => ToField (Maybe a) where toField Nothing = renderNull toField (Just a) = toField a {-# INLINE toField #-} instance (ToField a) => ToField (In [a]) where toField (In []) = Plain $ byteString "(null)" toField (In xs) = Many $ Plain (char8 '(') : (intersperse (Plain (char8 ',')) . map toField $ xs) ++ [Plain (char8 ')')] renderNull :: Action renderNull = Plain (byteString "null") instance ToField Null where toField _ = renderNull {-# INLINE toField #-} instance ToField Default where toField _ = Plain (byteString "default") {-# INLINE toField #-} instance ToField Bool where toField True = Plain (byteString "true") toField False = Plain (byteString "false") {-# INLINE toField #-} instance ToField Int8 where toField = Plain . int8Dec {-# INLINE toField #-} instance ToField Int16 where toField = Plain . int16Dec {-# INLINE toField #-} instance ToField Int32 where toField = Plain . int32Dec {-# INLINE toField #-} instance ToField Int where toField = Plain . intDec {-# INLINE toField #-} instance ToField Int64 where toField = Plain . int64Dec {-# INLINE toField #-} instance ToField Integer where toField = Plain . integerDec {-# INLINE toField #-} instance ToField Word8 where toField = Plain . word8Dec {-# INLINE toField #-} instance ToField Word16 where toField = Plain . word16Dec {-# INLINE toField #-} instance ToField Word32 where toField = Plain . word32Dec {-# INLINE toField #-} instance ToField Word where toField = Plain . wordDec {-# INLINE toField #-} instance ToField Word64 where toField = Plain . word64Dec {-# INLINE toField #-} instance ToField PQ.Oid where toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x {-# INLINE toField #-} instance ToField Float where toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v)) | otherwise = Plain (floatDec v) {-# INLINE toField #-} instance ToField Double where toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v)) | otherwise = Plain (doubleDec v) {-# INLINE toField #-} instance ToField Scientific where toField x = toField (LT.toLazyText (scientificBuilder x)) {-# INLINE toField #-} instance ToField (Binary SB.ByteString) where toField (Binary bs) = EscapeByteA bs {-# INLINE toField #-} instance ToField (Binary LB.ByteString) where toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs {-# INLINE toField #-} instance ToField Identifier where toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs) {-# INLINE toField #-} instance ToField QualifiedIdentifier where toField (QualifiedIdentifier (Just s) t) = Many [ EscapeIdentifier (ST.encodeUtf8 s) , Plain (char8 '.') , EscapeIdentifier (ST.encodeUtf8 t) ] toField (QualifiedIdentifier Nothing t) = EscapeIdentifier (ST.encodeUtf8 t) {-# INLINE toField #-} instance ToField SB.ByteString where toField = Escape {-# INLINE toField #-} instance ToField LB.ByteString where toField = toField . SB.concat . LB.toChunks {-# INLINE toField #-} instance ToField ST.Text where toField = Escape . ST.encodeUtf8 {-# INLINE toField #-} instance ToField [Char] where toField = Escape . toByteString . stringUtf8 {-# INLINE toField #-} instance ToField LT.Text where toField = toField . LT.toStrict {-# INLINE toField #-} instance ToField UTCTime where toField = Plain . inQuotes . utcTimeToBuilder {-# INLINE toField #-} instance ToField ZonedTime where toField = Plain . inQuotes . zonedTimeToBuilder {-# INLINE toField #-} instance ToField LocalTime where toField = Plain . inQuotes . localTimeToBuilder {-# INLINE toField #-} instance ToField Day where toField = Plain . inQuotes . dayToBuilder {-# INLINE toField #-} instance ToField TimeOfDay where toField = Plain . inQuotes . timeOfDayToBuilder {-# INLINE toField #-} instance ToField UTCTimestamp where toField = Plain . inQuotes . utcTimestampToBuilder {-# INLINE toField #-} instance ToField ZonedTimestamp where toField = Plain . inQuotes . zonedTimestampToBuilder {-# INLINE toField #-} instance ToField LocalTimestamp where toField = Plain . inQuotes . localTimestampToBuilder {-# INLINE toField #-} instance ToField Date where toField = Plain . inQuotes . dateToBuilder {-# INLINE toField #-} instance ToField NominalDiffTime where toField = Plain . inQuotes . nominalDiffTimeToBuilder {-# INLINE toField #-} instance (ToField a) => ToField (PGArray a) where toField pgArray = case fromPGArray pgArray of [] -> Plain (byteString "'{}'") xs -> Many $ Plain (byteString "ARRAY[") : (intersperse (Plain (char8 ',')) . map toField $ xs) ++ [Plain (char8 ']')] -- Because the ARRAY[...] input syntax is being used, it is possible -- that the use of type-specific separator characters is unnecessary. instance (ToField a) => ToField (Vector a) where toField = toField . PGArray . V.toList instance ToField UUID where toField = Plain . inQuotes . byteString . UUID.toASCIIBytes instance ToField JSON.Value where toField = toField . JSON.encode -- | Convert a Haskell value to a JSON 'JSON.Value' using -- 'JSON.toJSON' and convert that to a field using 'toField'. -- -- This can be used as the default implementation for the 'toField' -- method for Haskell types that have a JSON representation in -- PostgreSQL. toJSONField :: JSON.ToJSON a => a -> Action toJSONField = toField . JSON.toJSON -- | Surround a string with single-quote characters: \"@'@\" -- -- This function /does not/ perform any other escaping. inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote where quote = char8 '\'' interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as {-# INLINE interleaveFoldr #-} instance ToRow a => ToField (Values a) where toField (Values types rows) = case rows of [] -> case types of [] -> error norows (_:_) -> values $ typedRow (repeat (lit "null")) types [lit " LIMIT 0)"] (_:_) -> case types of [] -> values $ untypedRows rows [litC ')'] (_:_) -> values $ typedRows rows types [litC ')'] where funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action" norows = funcname ++ " either values or types must be non-empty" emptyrow = funcname ++ " each row must contain at least one column" lit = Plain . byteString litC = Plain . char8 values x = Many (lit "(VALUES ": x) typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action] typedField (val,typ) rest = val : lit "::" : toField typ : rest typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action] typedRow (val:vals) (typ:typs) rest = litC '(' : typedField (val,typ) ( interleaveFoldr typedField (litC ',') (litC ')' : rest) (zip vals typs) ) typedRow _ _ _ = error emptyrow untypedRow :: [Action] -> [Action] -> [Action] untypedRow (val:vals) rest = litC '(' : val : interleaveFoldr (:) (litC ',') (litC ')' : rest) vals untypedRow _ _ = error emptyrow typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] typedRows [] _ _ = error funcname typedRows (val:vals) types rest = typedRow (toRow val) types (multiRows vals rest) untypedRows :: ToRow a => [a] -> [Action] -> [Action] untypedRows [] _ = error funcname untypedRows (val:vals) rest = untypedRow (toRow val) (multiRows vals rest) multiRows :: ToRow a => [a] -> [Action] -> [Action] multiRows vals rest = interleaveFoldr (untypedRow . toRow) (litC ',') rest vals postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/LargeObjects.hs0000644000000000000000000000673112633616517024205 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.LargeObjects -- Copyright : (c) 2011-2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- -- Support for PostgreSQL's Large Objects; see -- for more -- information. -- -- Note that Large Object File Descriptors are only valid within a single -- database transaction, so if you are interested in using anything beyond -- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire -- sequence of functions in a transaction. As 'loImport' and 'loExport' -- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and -- 'loWrite', and do not perform any transaction handling themselves, -- they also need to be wrapped in an explicit transaction. -- ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.LargeObjects ( loCreat , loCreate , loImport , loImportWithOid , loExport , loOpen , loWrite , loRead , loSeek , loTell , loTruncate , loClose , loUnlink , Oid(..) , LoFd , IOMode(..) , SeekMode(..) ) where import Control.Applicative ((<$>)) import Control.Exception (throwIO) import qualified Data.ByteString as B import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import System.IO (IOMode(..),SeekMode(..)) liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a liftPQ str conn m = withConnection conn $ \c -> do res <- m c case res of Nothing -> do msg <- maybe str id <$> PQ.errorMessage c throwIO $ fatalError msg Just x -> return x loCreat :: Connection -> IO Oid loCreat conn = liftPQ "loCreat" conn (\c -> PQ.loCreat c) loCreate :: Connection -> Oid -> IO Oid loCreate conn oid = liftPQ "loCreate" conn (\c -> PQ.loCreate c oid) loImport :: Connection -> FilePath -> IO Oid loImport conn path = liftPQ "loImport" conn (\c -> PQ.loImport c path) loImportWithOid :: Connection -> FilePath -> Oid -> IO Oid loImportWithOid conn path oid = liftPQ "loImportWithOid" conn (\c -> PQ.loImportWithOid c path oid) loExport :: Connection -> Oid -> FilePath -> IO () loExport conn oid path = liftPQ "loExport" conn (\c -> PQ.loExport c oid path) loOpen :: Connection -> Oid -> IOMode -> IO LoFd loOpen conn oid mode = liftPQ "loOpen" conn (\c -> PQ.loOpen c oid mode ) loWrite :: Connection -> LoFd -> B.ByteString -> IO Int loWrite conn fd dat = liftPQ "loWrite" conn (\c -> PQ.loWrite c fd dat) loRead :: Connection -> LoFd -> Int -> IO B.ByteString loRead conn fd maxlen = liftPQ "loRead" conn (\c -> PQ.loRead c fd maxlen) loSeek :: Connection -> LoFd -> SeekMode -> Int -> IO Int loSeek conn fd seekmode offset = liftPQ "loSeek" conn (\c -> PQ.loSeek c fd seekmode offset) loTell :: Connection -> LoFd -> IO Int loTell conn fd = liftPQ "loTell" conn (\c -> PQ.loTell c fd) loTruncate :: Connection -> LoFd -> Int -> IO () loTruncate conn fd len = liftPQ "loTruncate" conn (\c -> PQ.loTruncate c fd len) loClose :: Connection -> LoFd -> IO () loClose conn fd = liftPQ "loClose" conn (\c -> PQ.loClose c fd) loUnlink :: Connection -> Oid -> IO () loUnlink conn oid = liftPQ "loUnlink" conn (\c -> PQ.loUnlink c oid) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Internal.hs-boot0000644000000000000000000000010312633616517024341 0ustar0000000000000000module Database.PostgreSQL.Simple.Internal where data RowParser a postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromField.hs-boot0000644000000000000000000000041312633616517024440 0ustar0000000000000000module Database.PostgreSQL.Simple.FromField where import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.Types class FromField a instance FromField Oid instance FromField Char instance FromField ByteString instance FromField a => FromField (Maybe a) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromRow.hs0000644000000000000000000002454312633616517023235 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.FromRow -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'FromRow' typeclass, for converting a row of results -- returned by a SQL query into a more useful Haskell representation. -- -- Predefined instances are provided for tuples containing up to ten -- elements. The instances for 'Maybe' types return 'Nothing' if all -- the columns that would have been otherwise consumed are null, otherwise -- it attempts a regular conversion. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.FromRow ( FromRow(..) , RowParser , field , fieldWith , numFieldsRemaining ) where import Prelude hiding (null) import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Vector (Vector) import qualified Data.Vector as V import Database.PostgreSQL.Simple.Types (Only(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types ((:.)(..), Null) import Database.PostgreSQL.Simple.TypeInfo import GHC.Generics -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. -- -- Note that instances can be defined outside of postgresql-simple, which is -- often useful. For example, here's an instance for a user-defined pair: -- -- @ -- data User = User { name :: String, fileQuota :: Int } -- -- instance 'FromRow' User where -- fromRow = User \<$\> 'field' \<*\> 'field' -- @ -- -- The number of calls to 'field' must match the number of fields returned -- in a single row of the query result. Otherwise, a 'ConversionFailed' -- exception will be thrown. -- -- Note that 'field' evaluates it's result to WHNF, so the caveats listed in -- mysql-simple and very early versions of postgresql-simple no longer apply. -- Instead, look at the caveats associated with user-defined implementations -- of 'fromField'. class FromRow a where fromRow :: RowParser a default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a fromRow = to <$> gfromRow getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col) nfields :: PQ.Result -> PQ.Column nfields result = unsafeDupablePerformIO (PQ.nfields result) getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo getTypeInfoByCol Row{..} col = Conversion $ \conn -> do oid <- PQ.ftype rowresult col Ok <$> getTypeInfo conn oid getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString getTypenameByCol row col = typname <$> getTypeInfoByCol row col fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do let unCol (PQ.Col x) = fromIntegral x :: Int r@Row{..} <- ask column <- lift get lift (put (column + 1)) let ncols = nfields rowresult if (column >= ncols) then lift $ lift $ do vals <- mapM (getTypenameByCol r) [0..ncols-1] let err = ConversionFailed (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals)) Nothing "" ("at least " ++ show (unCol column + 1) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type" conversionError err else do let !result = rowresult !typeOid = unsafeDupablePerformIO (PQ.ftype result column) !field = Field{..} lift (lift (fieldP field (getvalue result row column))) field :: FromField a => RowParser a field = fieldWith fromField ellipsis :: ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs numFieldsRemaining :: RowParser Int numFieldsRemaining = RP $ do Row{..} <- ask column <- lift get return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column) null :: RowParser Null null = field instance (FromField a) => FromRow (Only a) where fromRow = Only <$> field instance (FromField a) => FromRow (Maybe (Only a)) where fromRow = (null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b) => FromRow (a,b) where fromRow = (,) <$> field <*> field instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where fromRow = (null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where fromRow = (,,) <$> field <*> field <*> field instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where fromRow = (null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) where fromRow = (,,,) <$> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d) => FromRow (Maybe (a,b,c,d)) where fromRow = (null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) where fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (Maybe (a,b,c,d,e)) where fromRow = (null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a,b,c,d,e,f) where fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (Maybe (a,b,c,d,e,f)) where fromRow = (null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (a,b,c,d,e,f,g) where fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (Maybe (a,b,c,d,e,f,g)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h) => FromRow (a,b,c,d,e,f,g,h) where fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h) => FromRow (Maybe (a,b,c,d,e,f,g,h)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i) => FromRow (a,b,c,d,e,f,g,h,i) where fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i) => FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j) => FromRow (a,b,c,d,e,f,g,h,i,j) where fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance FromField a => FromRow [a] where fromRow = do n <- numFieldsRemaining replicateM n field instance FromField a => FromRow (Maybe [a]) where fromRow = do n <- numFieldsRemaining (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field) instance FromField a => FromRow (Vector a) where fromRow = do n <- numFieldsRemaining V.replicateM n field instance FromField a => FromRow (Maybe (Vector a)) where fromRow = do n <- numFieldsRemaining (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field) instance (FromRow a, FromRow b) => FromRow (a :. b) where fromRow = (:.) <$> fromRow <*> fromRow -- Type class for default implementation of FromRow using generics class GFromRow f where gfromRow :: RowParser (f p) instance GFromRow f => GFromRow (M1 c i f) where gfromRow = M1 <$> gfromRow instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where gfromRow = liftA2 (:*:) gfromRow gfromRow instance (FromField a) => GFromRow (K1 R a) where gfromRow = K1 <$> field instance GFromRow U1 where gfromRow = pure U1 postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Errors.hs0000644000000000000000000001146212633616517023112 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Errors -- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- | Module for parsing errors from postgresql error messages. -- Currently only parses integrity violation errors (class 23). -- -- /Note: Success of parsing may depend on language settings./ ---------------------------------------------------------- module Database.PostgreSQL.Simple.Errors ( ConstraintViolation(..) , constraintViolation , constraintViolationE , catchViolation , isSerializationError , isNoActiveTransactionError , isFailedTransactionError ) where import Control.Applicative import Control.Exception as E import Data.Attoparsec.ByteString.Char8 import Data.ByteString (ByteString) import Data.Typeable import Database.PostgreSQL.Simple.Internal -- Examples of parsed error messages -- -- `ERROR: new row for relation "users" violates check -- constraint "user_kind_check"` -- -- `ERROR: insert or update on table "user_group_map" violates foreign key -- constraint "user_id"` -- -- `ERROR: null value in column "login" violates not-null constraint` -- -- `ERROR: duplicate key value violates unique constraint "users_login_key"` data ConstraintViolation = NotNullViolation ByteString -- ^ The field is a column name | ForeignKeyViolation ByteString ByteString -- ^ Table name and name of violated constraint | UniqueViolation ByteString -- ^ Name of violated constraint | CheckViolation ByteString ByteString -- ^ Relation name (usually table), constraint name | ExclusionViolation ByteString -- ^ Name of the exclusion violation constraint deriving (Show, Eq, Ord, Typeable) -- Default instance should be enough instance Exception ConstraintViolation -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and -- succeedes only if able to parse sqlErrorMsg. -- -- > createUser = catchJust constraintViolation catcher $ execute conn ... -- > where -- > catcher UniqueViolation "user_login_key" = ... -- > catcher _ = ... constraintViolation :: SqlError -> Maybe ConstraintViolation constraintViolation e = case sqlState e of "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg _ -> Nothing where msg = sqlErrorMsg e -- | Like constraintViolation, but also packs original SqlError. -- -- > createUser = catchJust constraintViolationE catcher $ execute conn ... -- > where -- > catcher (_, UniqueViolation "user_login_key") = ... -- > catcher (e, _) = throwIO e -- constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) constraintViolationE e = fmap ((,) e) $ constraintViolation e -- | Catches SqlError, tries to convert to ConstraintViolation, re-throws -- on fail. Provides alternative interface to catchJust -- -- > createUser = catchViolation catcher $ execute conn ... -- > where -- > catcher _ (UniqueViolation "user_login_key") = ... -- > catcher e _ = throwIO e catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a catchViolation f m = E.catch m (\e -> maybe (throwIO e) (f e) $ constraintViolation e) -- Parsers just try to extract quoted strings from error messages, number -- of quoted strings depend on error type. scanTillQuote :: Parser ByteString scanTillQuote = scan False go where go True _ = Just False -- escaped character go False '"' = Nothing -- end parse go False '\\' = Just True -- next one is escaped go _ _ = Just False parseQ1 :: Parser ByteString parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' parseQ2 :: Parser (ByteString, ByteString) parseQ2 = (,) <$> parseQ1 <*> parseQ1 parseMaybe :: Parser a -> ByteString -> Maybe a parseMaybe p b = either (const Nothing) Just $ parseOnly p b ------------------------------------------------------------------------ -- Error predicates -- -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html isSerializationError :: SqlError -> Bool isSerializationError = isSqlState "40001" isNoActiveTransactionError :: SqlError -> Bool isNoActiveTransactionError = isSqlState "25P01" isFailedTransactionError :: SqlError -> Bool isFailedTransactionError = isSqlState "25P02" isSqlState :: ByteString -> SqlError -> Bool isSqlState s SqlError{..} = sqlState == s postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Types.hs0000644000000000000000000001776412633616517022755 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Types -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Basic types. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Types ( Null(..) , Default(..) , Only(..) , In(..) , Binary(..) , Identifier(..) , QualifiedIdentifier(..) , Query(..) , Oid(..) , (:.)(..) , Savepoint(..) , PGArray(..) , Values(..) ) where import Control.Arrow (first) import Data.ByteString (ByteString) import Data.Hashable (Hashable(hashWithSalt)) import Data.Monoid (Monoid(..)) import Data.String (IsString(..)) import Data.Typeable (Typeable) import Data.ByteString.Builder ( stringUtf8 ) import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T import Database.PostgreSQL.LibPQ (Oid(..)) import Database.PostgreSQL.Simple.Compat (toByteString) -- | A placeholder for the SQL @NULL@ value. data Null = Null deriving (Read, Show, Typeable) instance Eq Null where _ == _ = False _ /= _ = False -- | A placeholder for the PostgreSQL @DEFAULT@ value. data Default = Default deriving (Read, Show, Typeable) -- | A query string. This type is intended to make it difficult to -- construct a SQL query by concatenating string fragments, as that is -- an extremely common way to accidentally introduce SQL injection -- vulnerabilities into an application. -- -- This type is an instance of 'IsString', so the easiest way to -- construct a query is to enable the @OverloadedStrings@ language -- extension and then simply write the query in double quotes. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Database.PostgreSQL.Simple -- > -- > q :: Query -- > q = "select ?" -- -- The underlying type is a 'ByteString', and literal Haskell strings -- that contain Unicode characters will be correctly transformed to -- UTF-8. newtype Query = Query { fromQuery :: ByteString } deriving (Eq, Ord, Typeable) instance Show Query where show = show . fromQuery instance Read Query where readsPrec i = fmap (first Query) . readsPrec i instance IsString Query where fromString = Query . toByteString . stringUtf8 instance Monoid Query where mempty = Query B.empty mappend (Query a) (Query b) = Query (B.append a b) {-# INLINE mappend #-} mconcat xs = Query (B.concat (map fromQuery xs)) -- | A single-value \"collection\". -- -- This is useful if you need to supply a single parameter to a SQL -- query, or extract a single column from a SQL result. -- -- Parameter example: -- -- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@ -- -- Result example: -- -- @xs <- query_ c \"select id from users\" --forM_ xs $ \\('Only' id) -> {- ... -}@ newtype Only a = Only { fromOnly :: a } deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap a list of values for use in an @IN@ clause. Replaces a -- single \"@?@\" character with a parenthesized list of rendered -- values. -- -- Example: -- -- > query c "select * from whatever where id in ?" (Only (In [3,4,5])) newtype In a = In a deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap binary data for use as a @bytea@ value. newtype Binary a = Binary {fromBinary :: a} deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap text for use as sql identifier, i.e. a table or column name. newtype Identifier = Identifier {fromIdentifier :: Text} deriving (Eq, Ord, Read, Show, Typeable, IsString) instance Hashable Identifier where hashWithSalt i (Identifier t) = hashWithSalt i t -- | Wrap text for use as (maybe) qualified identifier, i.e. a table -- with schema, or column with table. data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text deriving (Eq, Ord, Read, Show, Typeable) instance Hashable QualifiedIdentifier where hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t) -- | @\"foo.bar\"@ will get turned into -- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get -- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance -- is for convenience, and does not match postgres syntax. It -- only examines the first period character, and thus cannot be used if the -- qualifying identifier contains a period for example. instance IsString QualifiedIdentifier where fromString str = let (x,y) = T.break (== '.') (fromString str) in if T.null y then QualifiedIdentifier Nothing x else QualifiedIdentifier (Just x) (T.tail y) -- | Wrap a list for use as a PostgreSQL array. newtype PGArray a = PGArray {fromPGArray :: [a]} deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | A composite type to parse your custom data structures without -- having to define dummy newtype wrappers every time. -- -- -- > instance FromRow MyData where ... -- -- > instance FromRow MyData2 where ... -- -- -- then I can do the following for free: -- -- @ -- res <- query' c "..." -- forM res $ \\(MyData{..} :. MyData2{..}) -> do -- .... -- @ data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable) infixr 3 :. newtype Savepoint = Savepoint Query deriving (Eq, Ord, Show, Read, Typeable) -- | Represents a @VALUES@ table literal, usable as an alternative -- to @executeMany@ and @returning@. The main advantage is that -- you can parametrize more than just a single @VALUES@ expression. -- For example, here's a query to insert a thing into one table -- and some attributes of that thing into another, returning the -- new id generated by the database: -- -- -- > query c [sql| -- > WITH new_thing AS ( -- > INSERT INTO thing (name) VALUES (?) RETURNING id -- > ), new_attributes AS ( -- > INSERT INTO thing_attributes -- > SELECT new_thing.id, attrs.* -- > FROM new_thing JOIN ? attrs -- > ) SELECT * FROM new_thing -- > |] ("foo", Values [ "int4", "text" ] -- > [ ( 1 , "hello" ) -- > , ( 2 , "world" ) ]) -- -- (Note this example uses writable common table expressions, -- which were added in PostgreSQL 9.1) -- -- The second parameter gets expanded into the following SQL syntax: -- -- > (VALUES (1::"int4",'hello'::"text"),(2,'world')) -- -- When the list of attributes is empty, the second parameter expands to: -- -- > (VALUES (null::"int4",null::"text") LIMIT 0) -- -- By contrast, @executeMany@ and @returning@ don't issue the query -- in the empty case, and simply return @0@ and @[]@ respectively. -- This behavior is usually correct given their intended use cases, -- but would certainly be wrong in the example above. -- -- The first argument is a list of postgresql type names. Because this -- is turned into a properly quoted identifier, the type name is case -- sensitive and must be as it appears in the @pg_type@ table. Thus, -- you must write @timestamptz@ instead of @timestamp with time zone@, -- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera. -- -- You may omit the type names, however, if you do so the list -- of values must be non-empty, and postgresql must be able to infer -- the types of the columns from the surrounding context. If the first -- condition is not met, postgresql-simple will throw an exception -- without issuing the query. In the second case, the postgres server -- will return an error which will be turned into a @SqlError@ exception. -- -- See for -- more information. data Values a = Values [QualifiedIdentifier] [a] deriving (Eq, Ord, Show, Read, Typeable) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo/0000755000000000000000000000000012633616517023033 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs0000644000000000000000000005754212633616517024633 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This module contains portions of the @pg_type@ table that are relevant -- to postgresql-simple and are believed to not change between PostgreSQL -- versions. -- ------------------------------------------------------------------------------ -- Note that this file is generated by tools/GenTypeInfo.hs, and should -- not be edited directly module Database.PostgreSQL.Simple.TypeInfo.Static ( TypeInfo(..) , staticTypeInfo , bool , bytea , char , name , int8 , int2 , int4 , regproc , text , oid , tid , xid , cid , xml , point , lseg , path , box , polygon , line , cidr , float4 , float8 , unknown , circle , money , macaddr , inet , bpchar , varchar , date , time , timestamp , timestamptz , interval , timetz , bit , varbit , numeric , refcursor , record , void , array_record , regprocedure , regoper , regoperator , regclass , regtype , uuid , json , jsonb , int2vector , oidvector , array_xml , array_json , array_line , array_cidr , array_circle , array_money , array_bool , array_bytea , array_char , array_name , array_int2 , array_int2vector , array_int4 , array_regproc , array_text , array_tid , array_xid , array_cid , array_oidvector , array_bpchar , array_varchar , array_int8 , array_point , array_lseg , array_path , array_box , array_float4 , array_float8 , array_polygon , array_oid , array_macaddr , array_inet , array_timestamp , array_date , array_time , array_timestamptz , array_interval , array_numeric , array_timetz , array_bit , array_varbit , array_refcursor , array_regprocedure , array_regoper , array_regoperator , array_regclass , array_regtype , array_uuid , array_jsonb , int4range , _int4range , numrange , _numrange , tsrange , _tsrange , tstzrange , _tstzrange , daterange , _daterange , int8range , _int8range ) where import Database.PostgreSQL.LibPQ (Oid(..)) import Database.PostgreSQL.Simple.TypeInfo.Types staticTypeInfo :: Oid -> Maybe TypeInfo staticTypeInfo (Oid x) = case x of 16 -> Just bool 17 -> Just bytea 18 -> Just char 19 -> Just name 20 -> Just int8 21 -> Just int2 23 -> Just int4 24 -> Just regproc 25 -> Just text 26 -> Just oid 27 -> Just tid 28 -> Just xid 29 -> Just cid 142 -> Just xml 600 -> Just point 601 -> Just lseg 602 -> Just path 603 -> Just box 604 -> Just polygon 628 -> Just line 650 -> Just cidr 700 -> Just float4 701 -> Just float8 705 -> Just unknown 718 -> Just circle 790 -> Just money 829 -> Just macaddr 869 -> Just inet 1042 -> Just bpchar 1043 -> Just varchar 1082 -> Just date 1083 -> Just time 1114 -> Just timestamp 1184 -> Just timestamptz 1186 -> Just interval 1266 -> Just timetz 1560 -> Just bit 1562 -> Just varbit 1700 -> Just numeric 1790 -> Just refcursor 2249 -> Just record 2278 -> Just void 2287 -> Just array_record 2202 -> Just regprocedure 2203 -> Just regoper 2204 -> Just regoperator 2205 -> Just regclass 2206 -> Just regtype 2950 -> Just uuid 114 -> Just json 3802 -> Just jsonb 22 -> Just int2vector 30 -> Just oidvector 143 -> Just array_xml 199 -> Just array_json 629 -> Just array_line 651 -> Just array_cidr 719 -> Just array_circle 791 -> Just array_money 1000 -> Just array_bool 1001 -> Just array_bytea 1002 -> Just array_char 1003 -> Just array_name 1005 -> Just array_int2 1006 -> Just array_int2vector 1007 -> Just array_int4 1008 -> Just array_regproc 1009 -> Just array_text 1010 -> Just array_tid 1011 -> Just array_xid 1012 -> Just array_cid 1013 -> Just array_oidvector 1014 -> Just array_bpchar 1015 -> Just array_varchar 1016 -> Just array_int8 1017 -> Just array_point 1018 -> Just array_lseg 1019 -> Just array_path 1020 -> Just array_box 1021 -> Just array_float4 1022 -> Just array_float8 1027 -> Just array_polygon 1028 -> Just array_oid 1040 -> Just array_macaddr 1041 -> Just array_inet 1115 -> Just array_timestamp 1182 -> Just array_date 1183 -> Just array_time 1185 -> Just array_timestamptz 1187 -> Just array_interval 1231 -> Just array_numeric 1270 -> Just array_timetz 1561 -> Just array_bit 1563 -> Just array_varbit 2201 -> Just array_refcursor 2207 -> Just array_regprocedure 2208 -> Just array_regoper 2209 -> Just array_regoperator 2210 -> Just array_regclass 2211 -> Just array_regtype 2951 -> Just array_uuid 3807 -> Just array_jsonb 3904 -> Just int4range 3905 -> Just _int4range 3906 -> Just numrange 3907 -> Just _numrange 3908 -> Just tsrange 3909 -> Just _tsrange 3910 -> Just tstzrange 3911 -> Just _tstzrange 3912 -> Just daterange 3913 -> Just _daterange 3926 -> Just int8range 3927 -> Just _int8range _ -> Nothing bool :: TypeInfo bool = Basic { typoid = Oid 16, typcategory = 'B', typdelim = ',', typname = "bool" } bytea :: TypeInfo bytea = Basic { typoid = Oid 17, typcategory = 'U', typdelim = ',', typname = "bytea" } char :: TypeInfo char = Basic { typoid = Oid 18, typcategory = 'S', typdelim = ',', typname = "char" } name :: TypeInfo name = Basic { typoid = Oid 19, typcategory = 'S', typdelim = ',', typname = "name" } int8 :: TypeInfo int8 = Basic { typoid = Oid 20, typcategory = 'N', typdelim = ',', typname = "int8" } int2 :: TypeInfo int2 = Basic { typoid = Oid 21, typcategory = 'N', typdelim = ',', typname = "int2" } int4 :: TypeInfo int4 = Basic { typoid = Oid 23, typcategory = 'N', typdelim = ',', typname = "int4" } regproc :: TypeInfo regproc = Basic { typoid = Oid 24, typcategory = 'N', typdelim = ',', typname = "regproc" } text :: TypeInfo text = Basic { typoid = Oid 25, typcategory = 'S', typdelim = ',', typname = "text" } oid :: TypeInfo oid = Basic { typoid = Oid 26, typcategory = 'N', typdelim = ',', typname = "oid" } tid :: TypeInfo tid = Basic { typoid = Oid 27, typcategory = 'U', typdelim = ',', typname = "tid" } xid :: TypeInfo xid = Basic { typoid = Oid 28, typcategory = 'U', typdelim = ',', typname = "xid" } cid :: TypeInfo cid = Basic { typoid = Oid 29, typcategory = 'U', typdelim = ',', typname = "cid" } xml :: TypeInfo xml = Basic { typoid = Oid 142, typcategory = 'U', typdelim = ',', typname = "xml" } point :: TypeInfo point = Basic { typoid = Oid 600, typcategory = 'G', typdelim = ',', typname = "point" } lseg :: TypeInfo lseg = Basic { typoid = Oid 601, typcategory = 'G', typdelim = ',', typname = "lseg" } path :: TypeInfo path = Basic { typoid = Oid 602, typcategory = 'G', typdelim = ',', typname = "path" } box :: TypeInfo box = Basic { typoid = Oid 603, typcategory = 'G', typdelim = ';', typname = "box" } polygon :: TypeInfo polygon = Basic { typoid = Oid 604, typcategory = 'G', typdelim = ',', typname = "polygon" } line :: TypeInfo line = Basic { typoid = Oid 628, typcategory = 'G', typdelim = ',', typname = "line" } cidr :: TypeInfo cidr = Basic { typoid = Oid 650, typcategory = 'I', typdelim = ',', typname = "cidr" } float4 :: TypeInfo float4 = Basic { typoid = Oid 700, typcategory = 'N', typdelim = ',', typname = "float4" } float8 :: TypeInfo float8 = Basic { typoid = Oid 701, typcategory = 'N', typdelim = ',', typname = "float8" } unknown :: TypeInfo unknown = Basic { typoid = Oid 705, typcategory = 'X', typdelim = ',', typname = "unknown" } circle :: TypeInfo circle = Basic { typoid = Oid 718, typcategory = 'G', typdelim = ',', typname = "circle" } money :: TypeInfo money = Basic { typoid = Oid 790, typcategory = 'N', typdelim = ',', typname = "money" } macaddr :: TypeInfo macaddr = Basic { typoid = Oid 829, typcategory = 'U', typdelim = ',', typname = "macaddr" } inet :: TypeInfo inet = Basic { typoid = Oid 869, typcategory = 'I', typdelim = ',', typname = "inet" } bpchar :: TypeInfo bpchar = Basic { typoid = Oid 1042, typcategory = 'S', typdelim = ',', typname = "bpchar" } varchar :: TypeInfo varchar = Basic { typoid = Oid 1043, typcategory = 'S', typdelim = ',', typname = "varchar" } date :: TypeInfo date = Basic { typoid = Oid 1082, typcategory = 'D', typdelim = ',', typname = "date" } time :: TypeInfo time = Basic { typoid = Oid 1083, typcategory = 'D', typdelim = ',', typname = "time" } timestamp :: TypeInfo timestamp = Basic { typoid = Oid 1114, typcategory = 'D', typdelim = ',', typname = "timestamp" } timestamptz :: TypeInfo timestamptz = Basic { typoid = Oid 1184, typcategory = 'D', typdelim = ',', typname = "timestamptz" } interval :: TypeInfo interval = Basic { typoid = Oid 1186, typcategory = 'T', typdelim = ',', typname = "interval" } timetz :: TypeInfo timetz = Basic { typoid = Oid 1266, typcategory = 'D', typdelim = ',', typname = "timetz" } bit :: TypeInfo bit = Basic { typoid = Oid 1560, typcategory = 'V', typdelim = ',', typname = "bit" } varbit :: TypeInfo varbit = Basic { typoid = Oid 1562, typcategory = 'V', typdelim = ',', typname = "varbit" } numeric :: TypeInfo numeric = Basic { typoid = Oid 1700, typcategory = 'N', typdelim = ',', typname = "numeric" } refcursor :: TypeInfo refcursor = Basic { typoid = Oid 1790, typcategory = 'U', typdelim = ',', typname = "refcursor" } record :: TypeInfo record = Basic { typoid = Oid 2249, typcategory = 'P', typdelim = ',', typname = "record" } void :: TypeInfo void = Basic { typoid = Oid 2278, typcategory = 'P', typdelim = ',', typname = "void" } array_record :: TypeInfo array_record = Array { typoid = Oid 2287, typcategory = 'P', typdelim = ',', typname = "_record", typelem = record } regprocedure :: TypeInfo regprocedure = Basic { typoid = Oid 2202, typcategory = 'N', typdelim = ',', typname = "regprocedure" } regoper :: TypeInfo regoper = Basic { typoid = Oid 2203, typcategory = 'N', typdelim = ',', typname = "regoper" } regoperator :: TypeInfo regoperator = Basic { typoid = Oid 2204, typcategory = 'N', typdelim = ',', typname = "regoperator" } regclass :: TypeInfo regclass = Basic { typoid = Oid 2205, typcategory = 'N', typdelim = ',', typname = "regclass" } regtype :: TypeInfo regtype = Basic { typoid = Oid 2206, typcategory = 'N', typdelim = ',', typname = "regtype" } uuid :: TypeInfo uuid = Basic { typoid = Oid 2950, typcategory = 'U', typdelim = ',', typname = "uuid" } json :: TypeInfo json = Basic { typoid = Oid 114, typcategory = 'U', typdelim = ',', typname = "json" } jsonb :: TypeInfo jsonb = Basic { typoid = Oid 3802, typcategory = 'U', typdelim = ',', typname = "jsonb" } int2vector :: TypeInfo int2vector = Array { typoid = Oid 22, typcategory = 'A', typdelim = ',', typname = "int2vector", typelem = int2 } oidvector :: TypeInfo oidvector = Array { typoid = Oid 30, typcategory = 'A', typdelim = ',', typname = "oidvector", typelem = oid } array_xml :: TypeInfo array_xml = Array { typoid = Oid 143, typcategory = 'A', typdelim = ',', typname = "_xml", typelem = xml } array_json :: TypeInfo array_json = Array { typoid = Oid 199, typcategory = 'A', typdelim = ',', typname = "_json", typelem = json } array_line :: TypeInfo array_line = Array { typoid = Oid 629, typcategory = 'A', typdelim = ',', typname = "_line", typelem = line } array_cidr :: TypeInfo array_cidr = Array { typoid = Oid 651, typcategory = 'A', typdelim = ',', typname = "_cidr", typelem = cidr } array_circle :: TypeInfo array_circle = Array { typoid = Oid 719, typcategory = 'A', typdelim = ',', typname = "_circle", typelem = circle } array_money :: TypeInfo array_money = Array { typoid = Oid 791, typcategory = 'A', typdelim = ',', typname = "_money", typelem = money } array_bool :: TypeInfo array_bool = Array { typoid = Oid 1000, typcategory = 'A', typdelim = ',', typname = "_bool", typelem = bool } array_bytea :: TypeInfo array_bytea = Array { typoid = Oid 1001, typcategory = 'A', typdelim = ',', typname = "_bytea", typelem = bytea } array_char :: TypeInfo array_char = Array { typoid = Oid 1002, typcategory = 'A', typdelim = ',', typname = "_char", typelem = char } array_name :: TypeInfo array_name = Array { typoid = Oid 1003, typcategory = 'A', typdelim = ',', typname = "_name", typelem = name } array_int2 :: TypeInfo array_int2 = Array { typoid = Oid 1005, typcategory = 'A', typdelim = ',', typname = "_int2", typelem = int2 } array_int2vector :: TypeInfo array_int2vector = Array { typoid = Oid 1006, typcategory = 'A', typdelim = ',', typname = "_int2vector", typelem = int2vector } array_int4 :: TypeInfo array_int4 = Array { typoid = Oid 1007, typcategory = 'A', typdelim = ',', typname = "_int4", typelem = int4 } array_regproc :: TypeInfo array_regproc = Array { typoid = Oid 1008, typcategory = 'A', typdelim = ',', typname = "_regproc", typelem = regproc } array_text :: TypeInfo array_text = Array { typoid = Oid 1009, typcategory = 'A', typdelim = ',', typname = "_text", typelem = text } array_tid :: TypeInfo array_tid = Array { typoid = Oid 1010, typcategory = 'A', typdelim = ',', typname = "_tid", typelem = tid } array_xid :: TypeInfo array_xid = Array { typoid = Oid 1011, typcategory = 'A', typdelim = ',', typname = "_xid", typelem = xid } array_cid :: TypeInfo array_cid = Array { typoid = Oid 1012, typcategory = 'A', typdelim = ',', typname = "_cid", typelem = cid } array_oidvector :: TypeInfo array_oidvector = Array { typoid = Oid 1013, typcategory = 'A', typdelim = ',', typname = "_oidvector", typelem = oidvector } array_bpchar :: TypeInfo array_bpchar = Array { typoid = Oid 1014, typcategory = 'A', typdelim = ',', typname = "_bpchar", typelem = bpchar } array_varchar :: TypeInfo array_varchar = Array { typoid = Oid 1015, typcategory = 'A', typdelim = ',', typname = "_varchar", typelem = varchar } array_int8 :: TypeInfo array_int8 = Array { typoid = Oid 1016, typcategory = 'A', typdelim = ',', typname = "_int8", typelem = int8 } array_point :: TypeInfo array_point = Array { typoid = Oid 1017, typcategory = 'A', typdelim = ',', typname = "_point", typelem = point } array_lseg :: TypeInfo array_lseg = Array { typoid = Oid 1018, typcategory = 'A', typdelim = ',', typname = "_lseg", typelem = lseg } array_path :: TypeInfo array_path = Array { typoid = Oid 1019, typcategory = 'A', typdelim = ',', typname = "_path", typelem = path } array_box :: TypeInfo array_box = Array { typoid = Oid 1020, typcategory = 'A', typdelim = ';', typname = "_box", typelem = box } array_float4 :: TypeInfo array_float4 = Array { typoid = Oid 1021, typcategory = 'A', typdelim = ',', typname = "_float4", typelem = float4 } array_float8 :: TypeInfo array_float8 = Array { typoid = Oid 1022, typcategory = 'A', typdelim = ',', typname = "_float8", typelem = float8 } array_polygon :: TypeInfo array_polygon = Array { typoid = Oid 1027, typcategory = 'A', typdelim = ',', typname = "_polygon", typelem = polygon } array_oid :: TypeInfo array_oid = Array { typoid = Oid 1028, typcategory = 'A', typdelim = ',', typname = "_oid", typelem = oid } array_macaddr :: TypeInfo array_macaddr = Array { typoid = Oid 1040, typcategory = 'A', typdelim = ',', typname = "_macaddr", typelem = macaddr } array_inet :: TypeInfo array_inet = Array { typoid = Oid 1041, typcategory = 'A', typdelim = ',', typname = "_inet", typelem = inet } array_timestamp :: TypeInfo array_timestamp = Array { typoid = Oid 1115, typcategory = 'A', typdelim = ',', typname = "_timestamp", typelem = timestamp } array_date :: TypeInfo array_date = Array { typoid = Oid 1182, typcategory = 'A', typdelim = ',', typname = "_date", typelem = date } array_time :: TypeInfo array_time = Array { typoid = Oid 1183, typcategory = 'A', typdelim = ',', typname = "_time", typelem = time } array_timestamptz :: TypeInfo array_timestamptz = Array { typoid = Oid 1185, typcategory = 'A', typdelim = ',', typname = "_timestamptz", typelem = timestamptz } array_interval :: TypeInfo array_interval = Array { typoid = Oid 1187, typcategory = 'A', typdelim = ',', typname = "_interval", typelem = interval } array_numeric :: TypeInfo array_numeric = Array { typoid = Oid 1231, typcategory = 'A', typdelim = ',', typname = "_numeric", typelem = numeric } array_timetz :: TypeInfo array_timetz = Array { typoid = Oid 1270, typcategory = 'A', typdelim = ',', typname = "_timetz", typelem = timetz } array_bit :: TypeInfo array_bit = Array { typoid = Oid 1561, typcategory = 'A', typdelim = ',', typname = "_bit", typelem = bit } array_varbit :: TypeInfo array_varbit = Array { typoid = Oid 1563, typcategory = 'A', typdelim = ',', typname = "_varbit", typelem = varbit } array_refcursor :: TypeInfo array_refcursor = Array { typoid = Oid 2201, typcategory = 'A', typdelim = ',', typname = "_refcursor", typelem = refcursor } array_regprocedure :: TypeInfo array_regprocedure = Array { typoid = Oid 2207, typcategory = 'A', typdelim = ',', typname = "_regprocedure", typelem = regprocedure } array_regoper :: TypeInfo array_regoper = Array { typoid = Oid 2208, typcategory = 'A', typdelim = ',', typname = "_regoper", typelem = regoper } array_regoperator :: TypeInfo array_regoperator = Array { typoid = Oid 2209, typcategory = 'A', typdelim = ',', typname = "_regoperator", typelem = regoperator } array_regclass :: TypeInfo array_regclass = Array { typoid = Oid 2210, typcategory = 'A', typdelim = ',', typname = "_regclass", typelem = regclass } array_regtype :: TypeInfo array_regtype = Array { typoid = Oid 2211, typcategory = 'A', typdelim = ',', typname = "_regtype", typelem = regtype } array_uuid :: TypeInfo array_uuid = Array { typoid = Oid 2951, typcategory = 'A', typdelim = ',', typname = "_uuid", typelem = uuid } array_jsonb :: TypeInfo array_jsonb = Array { typoid = Oid 3807, typcategory = 'A', typdelim = ',', typname = "_jsonb", typelem = jsonb } int4range :: TypeInfo int4range = Range { typoid = Oid 3904, typcategory = 'R', typdelim = ',', typname = "int4range", rngsubtype = int4 } _int4range :: TypeInfo _int4range = Array { typoid = Oid 3905, typcategory = 'A', typdelim = ',', typname = "_int4range", typelem = int4range } numrange :: TypeInfo numrange = Range { typoid = Oid 3906, typcategory = 'R', typdelim = ',', typname = "numrange", rngsubtype = numeric } _numrange :: TypeInfo _numrange = Array { typoid = Oid 3907, typcategory = 'A', typdelim = ',', typname = "_numrange", typelem = numrange } tsrange :: TypeInfo tsrange = Range { typoid = Oid 3908, typcategory = 'R', typdelim = ',', typname = "tsrange", rngsubtype = timestamp } _tsrange :: TypeInfo _tsrange = Array { typoid = Oid 3909, typcategory = 'A', typdelim = ',', typname = "_tsrange", typelem = tsrange } tstzrange :: TypeInfo tstzrange = Range { typoid = Oid 3910, typcategory = 'R', typdelim = ',', typname = "tstzrange", rngsubtype = timestamptz } _tstzrange :: TypeInfo _tstzrange = Array { typoid = Oid 3911, typcategory = 'A', typdelim = ',', typname = "_tstzrange", typelem = tstzrange } daterange :: TypeInfo daterange = Range { typoid = Oid 3912, typcategory = 'R', typdelim = ',', typname = "daterange", rngsubtype = date } _daterange :: TypeInfo _daterange = Array { typoid = Oid 3913, typcategory = 'A', typdelim = ',', typname = "_daterange", typelem = daterange } int8range :: TypeInfo int8range = Range { typoid = Oid 3926, typcategory = 'R', typdelim = ',', typname = "int8range", rngsubtype = int8 } _int8range :: TypeInfo _int8range = Array { typoid = Oid 3927, typcategory = 'A', typdelim = ',', typname = "_int8range", typelem = int8range } postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs0000644000000000000000000000305212633616517024430 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo.Macro -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A Template Haskell macro for efficiently checking membership in -- a set of type oids. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo.Macro ( mkCompats , inlineTypoid ) where import Database.PostgreSQL.Simple.TypeInfo.Static import Database.PostgreSQL.Simple.Types (Oid(..)) import Language.Haskell.TH -- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the -- oid is equal to any one of the 'typoid's of the given 'TypeInfo's. mkCompats :: [TypeInfo] -> ExpQ mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |] where alt :: TypeInfo -> MatchQ alt ty = match (inlineTypoidP ty) (normalB [| True |]) [] catchAll :: MatchQ catchAll = match wildP (normalB [| False |]) [] -- | Literally substitute the 'typoid' of a 'TypeInfo' expression. -- Returns an expression of type 'Oid'. Useful because GHC tends -- not to fold constants. inlineTypoid :: TypeInfo -> ExpQ inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |] inlineTypoidP :: TypeInfo -> PatQ inlineTypoidP ty = litP (getTypoid ty) getTypoid :: TypeInfo -> Lit getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs0000644000000000000000000000340212633616517024472 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo.Types -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo.Types where import Data.ByteString(ByteString) import Database.PostgreSQL.LibPQ(Oid) import Data.Vector(Vector) -- | A structure representing some of the metadata regarding a PostgreSQL -- type, mostly taken from the @pg_type@ table. data TypeInfo = Basic { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString } | Array { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , typelem :: !TypeInfo } | Range { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , rngsubtype :: !TypeInfo } | Composite { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , typrelid :: {-# UNPACK #-} !Oid , attributes :: !(Vector Attribute) } deriving (Show) data Attribute = Attribute { attname :: !ByteString , atttype :: !TypeInfo } deriving (Show) postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/0000755000000000000000000000000012633616517022174 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal.hs0000644000000000000000000000136112633616517024305 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Internal -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Time.Internal ( getDay , getDate , getTimeOfDay , getLocalTime , getLocalTimestamp , getTimeZone , getZonedTime , getZonedTimestamp , getUTCTime , getUTCTimestamp , TimeZoneHMS , getTimeZoneHMS , localToUTCTimeOfDayHMS ) where import Database.PostgreSQL.Simple.Time.Implementation postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Implementation.hs0000644000000000000000000001262112633616517025517 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Implementation -- Copyright: (c) 2012-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} module Database.PostgreSQL.Simple.Time.Implementation where import Prelude hiding (take) import Data.ByteString.Builder(Builder, byteString) import Data.ByteString.Builder.Prim(primBounded) import Control.Arrow((***)) import Control.Applicative import qualified Data.ByteString as B import Data.Time hiding (getTimeZone, getZonedTime) import Data.Typeable import Data.Maybe (fromMaybe) import qualified Data.Attoparsec.ByteString.Char8 as A import Database.PostgreSQL.Simple.Compat ((<>)) import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP data Unbounded a = NegInfinity | Finite !a | PosInfinity deriving (Eq, Ord, Typeable, Functor) instance Show a => Show (Unbounded a) where showsPrec prec x rest = case x of NegInfinity -> "-infinity" <> rest Finite time -> showsPrec prec time rest PosInfinity -> "infinity" <> rest instance Read a => Read (Unbounded a) where readsPrec prec = readParen False $ \str -> case str of ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(NegInfinity,xs)] ( 'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(PosInfinity,xs)] xs -> map (Finite *** id) (readsPrec prec xs) type LocalTimestamp = Unbounded LocalTime type UTCTimestamp = Unbounded UTCTime type ZonedTimestamp = Unbounded ZonedTime type Date = Unbounded Day parseUTCTime :: B.ByteString -> Either String UTCTime parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) parseZonedTime :: B.ByteString -> Either String ZonedTime parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput) parseLocalTime :: B.ByteString -> Either String LocalTime parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput) parseDay :: B.ByteString -> Either String Day parseDay = A.parseOnly (getDay <* A.endOfInput) parseTimeOfDay :: B.ByteString -> Either String TimeOfDay parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput) parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput) parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput) parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput) parseDate :: B.ByteString -> Either String Date parseDate = A.parseOnly (getDate <* A.endOfInput) getUnbounded :: A.Parser a -> A.Parser (Unbounded a) getUnbounded getFinite = (pure NegInfinity <* A.string "-infinity") <|> (pure PosInfinity <* A.string "infinity") <|> (Finite <$> getFinite) getDay :: A.Parser Day getDay = TP.day getDate :: A.Parser Date getDate = getUnbounded getDay getTimeOfDay :: A.Parser TimeOfDay getTimeOfDay = TP.timeOfDay getLocalTime :: A.Parser LocalTime getLocalTime = TP.localTime getLocalTimestamp :: A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime getTimeZone :: A.Parser TimeZone getTimeZone = fromMaybe utc <$> TP.timeZone type TimeZoneHMS = (Int,Int,Int) getTimeZoneHMS :: A.Parser TimeZoneHMS getTimeZoneHMS = munge <$> TP.timeZoneHMS where munge Nothing = (0,0,0) munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s) localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) localToUTCTimeOfDayHMS (dh, dm, ds) tod = TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod getZonedTime :: A.Parser ZonedTime getZonedTime = TP.zonedTime getZonedTimestamp :: A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime getUTCTime :: A.Parser UTCTime getUTCTime = TP.utcTime getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime dayToBuilder :: Day -> Builder dayToBuilder = primBounded TPP.day timeOfDayToBuilder :: TimeOfDay -> Builder timeOfDayToBuilder = primBounded TPP.timeOfDay timeZoneToBuilder :: TimeZone -> Builder timeZoneToBuilder = primBounded TPP.timeZone utcTimeToBuilder :: UTCTime -> Builder utcTimeToBuilder = primBounded TPP.utcTime zonedTimeToBuilder :: ZonedTime -> Builder zonedTimeToBuilder = primBounded TPP.zonedTime localTimeToBuilder :: LocalTime -> Builder localTimeToBuilder = primBounded TPP.localTime unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) unboundedToBuilder finiteToBuilder unbounded = case unbounded of NegInfinity -> byteString "-infinity" Finite a -> finiteToBuilder a PosInfinity -> byteString "infinity" utcTimestampToBuilder :: UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder zonedTimestampToBuilder :: ZonedTimestamp -> Builder zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder localTimestampToBuilder :: LocalTimestamp -> Builder localTimestampToBuilder = unboundedToBuilder localTimeToBuilder dateToBuilder :: Date -> Builder dateToBuilder = unboundedToBuilder dayToBuilder nominalDiffTimeToBuilder :: NominalDiffTime -> Builder nominalDiffTimeToBuilder = TPP.nominalDiffTime postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/0000755000000000000000000000000012633616517023750 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs0000644000000000000000000001001612633616517025725 0ustar0000000000000000{-# LANGUAGE BangPatterns, ViewPatterns #-} ------------------------------------------------------------------------------ -- Module: Database.PostgreSQL.Simple.Time.Internal.Printer -- Copyright: (c) 2012-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Time.Internal.Printer ( day , timeOfDay , timeZone , utcTime , localTime , zonedTime , nominalDiffTime ) where import Control.Arrow ((>>>)) import Data.ByteString.Builder (Builder, integerDec) import Data.ByteString.Builder.Prim ( liftFixedToBounded, (>$<), (>*<) , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) import Data.Char ( chr ) import Data.Int ( Int32, Int64 ) import Data.Time ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay , TimeZone, timeZoneMinutes ) import Database.PostgreSQL.Simple.Compat ((<>), fromPico) import Unsafe.Coerce (unsafeCoerce) liftB :: FixedPrim a -> BoundedPrim a liftB = liftFixedToBounded digit :: FixedPrim Int digit = (\x -> chr (x + 48)) >$< char8 digits2 :: FixedPrim Int digits2 = (`quotRem` 10) >$< (digit >*< digit) digits3 :: FixedPrim Int digits3 = (`quotRem` 10) >$< (digits2 >*< digit) digits4 :: FixedPrim Int digits4 = (`quotRem` 10) >$< (digits3 >*< digit) frac :: BoundedPrim Int64 frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) where trunc12 :: BoundedPrim Int64 trunc12 = (`quotRem` 1000000) >$< condB (\(_,y) -> y == 0) (fst >$< trunc6) (liftB digits6 >*< trunc6) digitB = liftB digit digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit) digits5 = (`quotRem` 10) >$< (digits4 >*< digit) trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5) trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4)) trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3)) trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2)) trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1)) trunc1 = condB (== 0) emptyB digitB year :: BoundedPrim Int32 year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4) where checkBCE :: Int32 -> Int checkBCE y | y > 0 = fromIntegral y | otherwise = error msg msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported" day :: BoundedPrim Day day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) where toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d)))) timeOfDay :: BoundedPrim TimeOfDay timeOfDay = f >$< (hh_mm_ >*< ss) where f (TimeOfDay h m s) = ((h,(':',(m,':'))),s) hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8) ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$< (liftB (fromIntegral >$< digits2) >*< frac) timeZone :: BoundedPrim TimeZone timeZone = ((`quotRem` 60) . timeZoneMinutes) >$< (liftB tzh >*< tzm) where f h = if h >= 0 then ('+', h) else (,) '-' $! (-h) tzh = f >$< (char8 >*< digits2) tzm = condB (==0) emptyB ((,) ':' . abs >$< liftB (char8 >*< digits2)) utcTime :: BoundedPrim UTCTime utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z'))) localTime :: BoundedPrim LocalTime localTime = f >$< (day >*< liftB char8 >*< timeOfDay) where f (LocalTime d tod) = (d, (' ', tod)) zonedTime :: BoundedPrim ZonedTime zonedTime = f >$< (localTime >*< timeZone) where f (ZonedTime lt tz) = (lt, tz) nominalDiffTime :: NominalDiffTime -> Builder nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) where (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs0000644000000000000000000001405512633616517025545 0ustar0000000000000000{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -- | -- Module: Database.PostgreSQL.Simple.Time.Internal.Parser -- Copyright: (c) 2012-2015 Leon P Smith -- (c) 2015 Bryan O'Sullivan -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Parsers for parsing dates and times. module Database.PostgreSQL.Simple.Time.Internal.Parser ( day , localTime , timeOfDay , timeZone , UTCOffsetHMS(..) , timeZoneHMS , localToUTCTimeOfDayHMS , utcTime , zonedTime ) where import Control.Applicative ((<$>), (<*>), (<*), (*>)) import Database.PostgreSQL.Simple.Compat (toPico) import Data.Attoparsec.ByteString.Char8 as A import Data.Bits ((.&.)) import Data.Char (ord) import Data.Fixed (Pico) import Data.Int (Int64) import Data.Maybe (fromMaybe) import Data.Time.Calendar (Day, fromGregorianValid, addDays) import Data.Time.Clock (UTCTime(..)) import qualified Data.ByteString.Char8 as B8 import qualified Data.Time.LocalTime as Local -- | Parse a date of the form @YYYY-MM-DD@. day :: Parser Day day = do y <- decimal <* char '-' m <- twoDigits <* char '-' d <- twoDigits maybe (fail "invalid date") return (fromGregorianValid y m d) -- | Parse a two-digit integer (e.g. day of month, hour). twoDigits :: Parser Int twoDigits = do a <- digit b <- digit let c2d c = ord c .&. 15 return $! c2d a * 10 + c2d b -- | Parse a time of the form @HH:MM:SS[.SSS]@. timeOfDay :: Parser Local.TimeOfDay timeOfDay = do h <- twoDigits <* char ':' m <- twoDigits <* char ':' s <- seconds if h < 24 && m < 60 && s <= 60 then return (Local.TimeOfDay h m s) else fail "invalid time" -- | Parse a count of seconds, with the integer part being two digits -- long. seconds :: Parser Pico seconds = do real <- twoDigits mc <- peekChar case mc of Just '.' -> do t <- anyChar *> takeWhile1 isDigit return $! parsePicos (fromIntegral real) t _ -> return $! fromIntegral real where parsePicos :: Int64 -> B8.ByteString -> Pico parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) where n = max 0 (12 - B8.length t) t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 (B8.take 12 t) -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) timeZone :: Parser (Maybe Local.TimeZone) timeZone = do ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' if ch == 'Z' then return Nothing else do h <- twoDigits mm <- peekChar m <- case mm of Just ':' -> anyChar *> twoDigits _ -> return 0 let off | ch == '-' = negate off0 | otherwise = off0 off0 = h * 60 + m case undefined of _ | off == 0 -> return Nothing | h > 23 || m > 59 -> fail "invalid time zone offset" | otherwise -> let !tz = Local.minutesToTimeZone off in return (Just tz) data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) timeZoneHMS :: Parser (Maybe UTCOffsetHMS) timeZoneHMS = do ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' if ch == 'Z' then return Nothing else do h <- twoDigits m <- maybeTwoDigits s <- maybeTwoDigits case undefined of _ | h == 0 && m == 0 && s == 0 -> return Nothing | h > 23 || m >= 60 || s >= 60 -> fail "invalid time zone offset" | otherwise -> if ch == '+' then let !tz = UTCOffsetHMS h m s in return (Just tz) else let !tz = UTCOffsetHMS (-h) (-m) (-s) in return (Just tz) where maybeTwoDigits = do ch <- peekChar case ch of Just ':' -> anyChar *> twoDigits _ -> return 0 localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'') where s' = s - fromIntegral ds (!s'', m') | s' < 0 = (s' + 60, m - dm - 1) | s' >= 60 = (s' - 60, m - dm + 1) | otherwise = (s' , m - dm ) (!m'', h') | m' < 0 = (m' + 60, h - dh - 1) | m' >= 60 = (m' - 60, h - dh + 1) | otherwise = (m' , h - dh ) (!h'', dday) | h' < 0 = (h' + 24, -1) | h' >= 24 = (h' - 24, 1) | otherwise = (h' , 0) -- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. -- The space may be replaced with a @T@. The number of seconds may be -- followed by a fractional component. localTime :: Parser Local.LocalTime localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay where daySep = satisfy (\c -> c == ' ' || c == 'T') -- | Behaves as 'zonedTime', but converts any time zone offset into a -- UTC time. utcTime :: Parser UTCTime utcTime = do (Local.LocalTime d t) <- localTime mtz <- timeZoneHMS case mtz of Nothing -> let !tt = Local.timeOfDayToTime t in return (UTCTime d tt) Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t !d' = addDays dd d !tt = Local.timeOfDayToTime t' in return (UTCTime d' tt) -- | Parse a date with time zone info. Acceptable formats: -- -- @YYYY-MM-DD HH:MM:SS Z@ -- -- The first space may instead be a @T@, and the second space is -- optional. The @Z@ represents UTC. The @Z@ may be replaced with a -- time zone offset of the form @+0000@ or @-08:00@, where the first -- two digits are hours, the @:@ is optional and the second two digits -- (also optional) are minutes. zonedTime :: Parser Local.ZonedTime zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) utc :: Local.TimeZone utc = Local.TimeZone 0 False "" postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/0000755000000000000000000000000012633616517022502 5ustar0000000000000000postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/Internal.hs0000644000000000000000000000113312633616517024610 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Internal -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore.Internal ( HStoreBuilder(..) , HStoreText(..) , parseHStore , parseHStoreKeyVal , parseHStoreText ) where import Database.PostgreSQL.Simple.HStore.Implementation postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/Implementation.hs0000644000000000000000000001606712633616517026035 0ustar0000000000000000{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Implementation -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This code has yet to be profiled and optimized. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore.Implementation where import Control.Applicative import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder, byteString, char8) import qualified Data.ByteString.Builder as BU import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BL #if !MIN_VERSION_bytestring(0,10,0) import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks) #endif import Data.Map(Map) import qualified Data.Map as Map import Data.Text(Text) import qualified Data.Text as TS import qualified Data.Text.Encoding as TS import Data.Text.Encoding.Error(UnicodeException) import qualified Data.Text.Lazy as TL import Data.Typeable import Data.Monoid(Monoid(..)) import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField class ToHStore a where toHStore :: a -> HStoreBuilder -- | Represents valid hstore syntax. data HStoreBuilder = Empty | Comma !Builder deriving (Typeable) instance ToHStore HStoreBuilder where toHStore = id toBuilder :: HStoreBuilder -> Builder toBuilder x = case x of Empty -> mempty Comma x -> x toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty Comma x -> BU.toLazyByteString x instance Monoid HStoreBuilder where mempty = Empty mappend Empty x = x mappend (Comma a) x = Comma (a `mappend` case x of Empty -> mempty Comma b -> char8 ',' `mappend` b) class ToHStoreText a where toHStoreText :: a -> HStoreText -- | Represents escape text, ready to be the key or value to a hstore value newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid) instance ToHStoreText HStoreText where toHStoreText = id -- | Assumed to be UTF-8 encoded instance ToHStoreText BS.ByteString where toHStoreText str = HStoreText (escapeAppend str mempty) -- | Assumed to be UTF-8 encoded instance ToHStoreText BL.ByteString where toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty instance ToHStoreText TS.Text where toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty) instance ToHStoreText TL.Text where toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty escapeAppend :: BS.ByteString -> Builder -> Builder escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest = byteString a `mappend` case BS.uncons b of Nothing -> rest Just (c,d) -> quoteChar c `mappend` loop d rest quoteNeeded c = c == c2w '\"' || c == c2w '\\' quoteChar c | c == c2w '\"' = byteString "\\\"" | otherwise = byteString "\\\\" hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\"" `mappend` val `mappend` char8 '"') instance ToField HStoreBuilder where toField Empty = toField (BS.empty) toField (Comma x) = toField (BU.toLazyByteString x) newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show) -- | hstore instance ToHStore HStoreList where toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs) instance ToField HStoreList where toField xs = toField (toHStore xs) -- | hstore instance FromField HStoreList where fromField f mdat = do typ <- typename f if typ /= "hstore" then returnError Incompatible f "" else case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> case P.parseOnly (parseHStore <* P.endOfInput) dat of Left err -> returnError ConversionFailed f err Right (Left err) -> returnError ConversionFailed f "unicode exception" <|> conversionError err Right (Right val) -> return val newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show) instance ToHStore HStoreMap where toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs where f k v xs = hstore k v `mappend` xs instance ToField HStoreMap where toField xs = toField (toHStore xs) instance FromField HStoreMap where fromField f mdat = convert <$> fromField f mdat where convert (HStoreList xs) = HStoreMap (Map.fromList xs) parseHStoreList :: BS.ByteString -> Either String HStoreList parseHStoreList dat = case P.parseOnly (parseHStore <* P.endOfInput) dat of Left err -> Left (show err) Right (Left err) -> Left (show err) Right (Right val) -> Right val parseHStore :: P.Parser (Either UnicodeException HStoreList) parseHStore = do kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal) (skipWhiteSpace *> P.word8 (c2w ',')) return $ HStoreList <$> sequence kvs parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text)) parseHStoreKeyVal = do mkey <- parseHStoreText case mkey of Left err -> return (Left err) Right key -> do skipWhiteSpace _ <- P.string "=>" skipWhiteSpace mval <- parseHStoreText case mval of Left err -> return (Left err) Right val -> return (Right (key,val)) skipWhiteSpace :: P.Parser () skipWhiteSpace = P.skipWhile P.isSpace_w8 parseHStoreText :: P.Parser (Either UnicodeException Text) parseHStoreText = do _ <- P.word8 (c2w '"') mtexts <- parseHStoreTexts id case mtexts of Left err -> return (Left err) Right texts -> do _ <- P.word8 (c2w '"') return (Right (TS.concat texts)) parseHStoreTexts :: ([Text] -> [Text]) -> P.Parser (Either UnicodeException [Text]) parseHStoreTexts acc = do mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar) case mchunk of Left err -> return (Left err) Right chunk -> (do _ <- P.word8 (c2w '\\') c <- TS.singleton . w2c <$> P.satisfy isSpecialChar parseHStoreTexts (acc . (chunk:) . (c:)) ) <|> return (Right (acc [chunk])) where isSpecialChar c = c == c2w '\\' || c == c2w '"'