diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 index 00000000..b4d14ca1 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Criterion.Main +import Database.PostgreSQL.Simple +import qualified Data.Map as Map +import Data.Text +import Data.Time +import Data.Aeson as Aeson +import Database.PostgreSQL.Simple.HStore +import Control.Exception +import Control.DeepSeq + +instance NFData HStoreMap where + rnf (HStoreMap m) = rnf m + +instance NFData SomeException where + rnf e = rnf (show e) + +main :: IO () +main = do + t <- getCurrentTime + bracket (connectPostgreSQL "host=localhost port=5432 user=opaleye password=opaleye") close $ \conn -> do + defaultMain + [ bgroup "complicatedQuery" + [ bench "without error" $ nfIO $ complicatedQuery conn + , bench "with error" $ nfIO $ catch (complicatedQueryWithError conn) (\ (e :: SomeException) -> e `deepseq` pure [(t, HStoreMap mempty, Aeson.String "")]) + ] + ] + +complicatedQuery :: Connection -> IO [(UTCTime, Value, HStoreMap)] +complicatedQuery conn = do + let j = Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map.Map Text Text + query conn "SELECT current_timestamp, ?::json, ?::hstore" (toJSON j, HStoreMap j) + +complicatedQueryWithError :: Connection -> IO [(UTCTime, HStoreMap, Value)] +complicatedQueryWithError conn = do + let j = Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map.Map Text Text + query conn "SELECT current_timestamp, ?::json, ?::hstore" (toJSON j, HStoreMap j) diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal index 5619414c..f774b334 100644 --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -131,3 +131,16 @@ test-suite test if !impl(ghc >= 7.6) build-depends: ghc-prim + +test-suite benchmark + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: Main.hs + build-depends: postgresql-simple + , criterion + , deepseq + , text + , time + , aeson + , containers + , base diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs index 684a8399..278f31c3 100644 --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -138,6 +138,7 @@ import Database.PostgreSQL.Simple.Internal.PQResultUtils import Database.PostgreSQL.Simple.Transaction import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B +import GHC.Stack -- | Format a query string. @@ -150,7 +151,7 @@ import qualified Data.ByteString.Char8 as B -- -- Throws 'FormatError' if the query string could not be formatted -- correctly. -formatQuery :: ToRow q => Connection -> Query -> q -> IO ByteString +formatQuery :: (HasCallStack, 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 @@ -169,7 +170,7 @@ formatQuery conn q@(Query template) qs -- -- Throws 'FormatError' if the query string could not be formatted -- correctly. -formatMany :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString +formatMany :: (HasCallStack, 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 @@ -194,7 +195,7 @@ formatMany conn q@(Query template) qs = do -- 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 :: (HasCallStack) => ByteString -> Maybe (ByteString, ByteString, ByteString) parseTemplate template = -- Convert input string to uppercase, to facilitate searching. search $ B.map toUpper_ascii template @@ -277,7 +278,7 @@ parseTemplate template = -buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder +buildQuery :: (HasCallStack) => Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s = @@ -299,7 +300,7 @@ buildQuery conn q template xs = -- -- 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 :: (HasCallStack, ToRow q) => Connection -> Query -> q -> IO Int64 execute conn template qs = do result <- exec conn =<< formatQuery conn template qs finishExecute conn template result @@ -334,7 +335,7 @@ execute conn template qs = do -- |] [(1, \"hello\"),(2, \"world\")] -- @ -executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 +executeMany :: (HasCallStack, ToRow q) => Connection -> Query -> [q] -> IO Int64 executeMany _ _ [] = return 0 executeMany conn q qs = do result <- exec conn =<< formatMany conn q qs @@ -352,10 +353,10 @@ executeMany conn q qs = do -- 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 :: (HasCallStack, ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] returning = returningWith fromRow -returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] +returningWith :: (HasCallStack, ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] returningWith _ _ _ [] = return [] returningWith parser conn q qs = do result <- exec conn =<< formatMany conn q qs @@ -379,21 +380,21 @@ returningWith parser conn q qs = do -- -- * '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 :: (HasCallStack, 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_ :: (HasCallStack, 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 :: (HasCallStack, 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_ :: (HasCallStack) => RowParser r -> Connection -> Query -> IO [r] queryWith_ parser conn q@(Query que) = do result <- exec conn que finishQueryWith parser conn q result @@ -425,7 +426,7 @@ queryWith_ parser conn q@(Query que) = do -- -- * '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 ) +fold :: ( FromRow row, ToRow params, HasCallStack ) => Connection -> Query -> params @@ -435,7 +436,7 @@ fold :: ( FromRow row, ToRow params ) fold = foldWithOptions defaultFoldOptions -- | A version of 'fold' taking a parser as an argument -foldWith :: ( ToRow params ) +foldWith :: ( ToRow params, HasCallStack ) => RowParser row -> Connection -> Query @@ -471,7 +472,7 @@ defaultFoldOptions = FoldOptions { -- 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 ) +foldWithOptions :: ( FromRow row, ToRow params, HasCallStack ) => FoldOptions -> Connection -> Query @@ -482,7 +483,7 @@ foldWithOptions :: ( FromRow row, ToRow params ) foldWithOptions opts = foldWithOptionsAndParser opts fromRow -- | A version of 'foldWithOptions' taking a parser as an argument -foldWithOptionsAndParser :: (ToRow params) +foldWithOptionsAndParser :: (ToRow params, HasCallStack) => FoldOptions -> RowParser row -> Connection @@ -496,7 +497,7 @@ foldWithOptionsAndParser opts parser conn template qs a f = do doFold opts parser conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. -fold_ :: (FromRow r) => +fold_ :: (FromRow r, HasCallStack) => Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. @@ -505,7 +506,7 @@ fold_ :: (FromRow r) => fold_ = foldWithOptions_ defaultFoldOptions -- | A version of 'fold_' taking a parser as an argument -foldWith_ :: RowParser r +foldWith_ :: (HasCallStack) => RowParser r -> Connection -> Query -> a @@ -513,7 +514,7 @@ foldWith_ :: RowParser r -> IO a foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions -foldWithOptions_ :: (FromRow r) => +foldWithOptions_ :: (HasCallStack, FromRow r) => FoldOptions -> Connection -> Query -- ^ Query. @@ -532,7 +533,7 @@ foldWithOptionsAndParser_ :: FoldOptions -> IO a foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f -doFold :: FoldOptions +doFold :: (HasCallStack) => FoldOptions -> RowParser row -> Connection -> Query @@ -581,7 +582,7 @@ doFold FoldOptions{..} parser conn _template q a0 f = do Fixed n -> n -- | A version of 'fold' that does not transform a state value. -forEach :: (ToRow q, FromRow r) => +forEach :: (HasCallStack, ToRow q, FromRow r) => Connection -> Query -- ^ Query template. -> q -- ^ Query parameters. @@ -591,7 +592,7 @@ forEach = forEachWith fromRow {-# INLINE forEach #-} -- | A version of 'forEach' taking a parser as an argument -forEachWith :: ( ToRow q ) +forEachWith :: ( HasCallStack, ToRow q ) => RowParser r -> Connection -> Query @@ -602,7 +603,7 @@ forEachWith parser conn template qs = foldWith parser conn template qs () . cons {-# INLINE forEachWith #-} -- | A version of 'forEach' that does not perform query substitution. -forEach_ :: (FromRow r) => +forEach_ :: (HasCallStack, FromRow r) => Connection -> Query -- ^ Query template. -> (r -> IO ()) -- ^ Result consumer. @@ -610,7 +611,7 @@ forEach_ :: (FromRow r) => forEach_ = forEachWith_ fromRow {-# INLINE forEach_ #-} -forEachWith_ :: RowParser r +forEachWith_ :: (HasCallStack) => RowParser r -> Connection -> Query -> (r -> IO ()) diff --git a/src/Database/PostgreSQL/Simple.hs-boot b/src/Database/PostgreSQL/Simple.hs-boot index f4c38d21..a686de05 100644 --- a/src/Database/PostgreSQL/Simple.hs-boot +++ b/src/Database/PostgreSQL/Simple.hs-boot @@ -13,11 +13,12 @@ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow +import GHC.Stack -query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] +query :: (HasCallStack, ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] -query_ :: FromRow r => Connection -> Query -> IO [r] +query_ :: (HasCallStack, FromRow r) => Connection -> Query -> IO [r] -execute :: ToRow q => Connection -> Query -> q -> IO Int64 +execute :: (HasCallStack, ToRow q) => Connection -> Query -> q -> IO Int64 -executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 +executeMany :: (HasCallStack, ToRow q) => Connection -> Query -> [q] -> IO Int64 diff --git a/src/Database/PostgreSQL/Simple/Arrays.hs b/src/Database/PostgreSQL/Simple/Arrays.hs index a7ef5c4f..1235597c 100644 --- a/src/Database/PostgreSQL/Simple/Arrays.hs +++ b/src/Database/PostgreSQL/Simple/Arrays.hs @@ -18,10 +18,11 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Monoid import Data.Attoparsec.ByteString.Char8 +import GHC.Stack -- | Parse one of three primitive field formats: array, quoted and plain. -arrayFormat :: Char -> Parser ArrayFormat +arrayFormat :: (HasCallStack) => Char -> Parser ArrayFormat arrayFormat delim = Array <$> array delim <|> Plain <$> plain delim <|> Quoted <$> quoted @@ -31,7 +32,7 @@ data ArrayFormat = Array [ArrayFormat] | Quoted ByteString deriving (Eq, Show, Ord) -array :: Char -> Parser [ArrayFormat] +array :: (HasCallStack) => Char -> Parser [ArrayFormat] array delim = char '{' *> option [] (arrays <|> strings) <* char '}' where strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) @@ -39,7 +40,7 @@ array delim = char '{' *> option [] (arrays <|> strings) <* char '}' -- NB: Arrays seem to always be delimited by commas. -- | Recognizes a quoted string. -quoted :: Parser ByteString +quoted :: (HasCallStack) => Parser ByteString quoted = char '"' *> option "" contents <* char '"' where esc = char '\\' *> (char '\\' <|> char '"') @@ -48,7 +49,7 @@ quoted = char '"' *> option "" contents <* char '"' -- | Recognizes a plain string literal, not containing quotes or brackets and -- not containing the delimiter character. -plain :: Char -> Parser ByteString +plain :: (HasCallStack) => Char -> Parser ByteString plain delim = takeWhile1 (notInClass (delim:"\"{}")) -- Mutually recursive 'fmt' and 'delimit' separate out value formatting @@ -56,13 +57,13 @@ plain delim = takeWhile1 (notInClass (delim:"\"{}")) -- | Format an array format item, using the delimiter character if the item is -- itself an array. -fmt :: Char -> ArrayFormat -> ByteString +fmt :: (HasCallStack) => 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 :: (HasCallStack) => 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) @@ -73,7 +74,7 @@ delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) -- | 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' :: (HasCallStack) => Bool -> Char -> ArrayFormat -> ByteString fmt' quoting c x = case x of Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') @@ -83,7 +84,7 @@ fmt' quoting c x = -- NB: The 'snoc' and 'cons' functions always copy. -- | Escape a string according to Postgres double-quoted string format. -esc :: ByteString -> ByteString +esc :: (HasCallStack) => ByteString -> ByteString esc = B.concatMap f where f '"' = "\\\"" diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs index 9cae4d5c..3a97eabf 100644 --- a/src/Database/PostgreSQL/Simple/Compat.hs +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -11,6 +11,7 @@ module Database.PostgreSQL.Simple.Compat , fromPico ) where +import GHC.Stack import qualified Control.Exception as E import Data.Monoid import Data.ByteString (ByteString) @@ -50,7 +51,7 @@ import Unsafe.Coerce (unsafeCoerce) -- 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 +mask :: (HasCallStack) => ((IO a -> IO a) -> IO b) -> IO b #if MIN_VERSION_base(4,3,0) mask io = E.mask $ \restore -> io restore #else @@ -63,12 +64,12 @@ mask io = do #if !MIN_VERSION_base(4,5,0) infixr 6 <> -(<>) :: Monoid m => m -> m -> m +(<>) :: (HasCallStack) => Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif -toByteString :: Builder -> ByteString +toByteString :: (HasCallStack) => Builder -> ByteString #if MIN_VERSION_bytestring(0,10,0) toByteString x = toStrict (toLazyByteString x) #else @@ -77,18 +78,18 @@ toByteString x = B.concat (toChunks (toLazyByteString x)) #if MIN_VERSION_base(4,7,0) -toPico :: Integer -> Pico +toPico :: (HasCallStack) => Integer -> Pico toPico = MkFixed -fromPico :: Pico -> Integer +fromPico :: (HasCallStack) => Pico -> Integer fromPico (MkFixed i) = i #else -toPico :: Integer -> Pico +toPico :: (HasCallStack) => Integer -> Pico toPico = unsafeCoerce -fromPico :: Pico -> Integer +fromPico :: (HasCallStack) => Pico -> Integer fromPico = unsafeCoerce #endif diff --git a/src/Database/PostgreSQL/Simple/Copy.hs b/src/Database/PostgreSQL/Simple/Copy.hs index e6ebd1e3..4ec5d129 100644 --- a/src/Database/PostgreSQL/Simple/Copy.hs +++ b/src/Database/PostgreSQL/Simple/Copy.hs @@ -38,6 +38,7 @@ module Database.PostgreSQL.Simple.Copy , putCopyError ) where +import GHC.Stack import Control.Applicative import Control.Concurrent import Control.Exception ( throwIO ) @@ -56,7 +57,7 @@ import Database.PostgreSQL.Simple.Internal -- @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 :: (HasCallStack, 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 @@ -67,11 +68,11 @@ copy conn template qs = do -- @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_ :: (HasCallStack) => 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 :: (HasCallStack) => B.ByteString -> Connection -> Query -> B.ByteString -> IO () doCopy funcName conn template q = do result <- exec conn q status <- PQ.resultStatus result @@ -110,7 +111,7 @@ data CopyOutResult -- if it returns 'CopyOutDone', then the connection has reverted to the -- ready state. -getCopyData :: Connection -> IO CopyOutResult +getCopyData :: (HasCallStack) => Connection -> IO CopyOutResult getCopyData conn = withConnection conn loop where funcName = "Database.PostgreSQL.Simple.Copy.getCopyData" @@ -158,7 +159,7 @@ getCopyData conn = withConnection conn loop -- connection remains in the @CopyIn@ state after this function -- is called. -putCopyData :: Connection -> B.ByteString -> IO () +putCopyData :: (HasCallStack) => Connection -> B.ByteString -> IO () putCopyData conn dat = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn where @@ -173,7 +174,7 @@ putCopyData conn dat = withConnection conn $ \pqconn -> do -- connection's state changes back to ready after this function -- is called. -putCopyEnd :: Connection -> IO Int64 +putCopyEnd :: (HasCallStack) => Connection -> IO Int64 putCopyEnd conn = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn getCopyCommandTag funcName pqconn @@ -190,7 +191,7 @@ putCopyEnd conn = withConnection conn $ \pqconn -> do -- connection's state changes back to ready after this function -- is called. -putCopyError :: Connection -> B.ByteString -> IO () +putCopyError :: (HasCallStack) => Connection -> B.ByteString -> IO () putCopyError conn err = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn consumeResults pqconn @@ -198,7 +199,7 @@ putCopyError conn err = withConnection conn $ \pqconn -> do funcName = "Database.PostgreSQL.Simple.Copy.putCopyError" -doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult) +doCopyIn :: (HasCallStack) => B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult) -> PQ.Connection -> IO () doCopyIn funcName action = loop where @@ -224,7 +225,7 @@ doCopyIn funcName action = loop loop pqconn {-# INLINE doCopyIn #-} -getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64 +getCopyCommandTag :: (HasCallStack) => 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 @@ -240,7 +241,7 @@ getCopyCommandTag funcName pqconn = do errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status" -consumeResults :: PQ.Connection -> IO () +consumeResults :: (HasCallStack) => PQ.Connection -> IO () consumeResults pqconn = do mres <- PQ.getResult pqconn case mres of diff --git a/src/Database/PostgreSQL/Simple/Cursor.hs b/src/Database/PostgreSQL/Simple/Cursor.hs index d077739c..f1011ff5 100644 --- a/src/Database/PostgreSQL/Simple/Cursor.hs +++ b/src/Database/PostgreSQL/Simple/Cursor.hs @@ -22,6 +22,7 @@ module Database.PostgreSQL.Simple.Cursor , foldForwardWithParser ) where +import GHC.Stack import Data.ByteString.Builder (intDec) import Control.Applicative ((<$>)) import Control.Exception as E @@ -40,14 +41,14 @@ data Cursor = Cursor !Query !Connection -- | Declare a temporary cursor. The cursor is given a -- unique name for the given connection. -declareCursor :: Connection -> Query -> IO Cursor +declareCursor :: (HasCallStack) => Connection -> Query -> IO Cursor declareCursor conn q = do name <- newTempName conn void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q] return $ Cursor name conn -- | Close the given cursor. -closeCursor :: Cursor -> IO () +closeCursor :: (HasCallStack) => Cursor -> IO () closeCursor (Cursor name conn) = (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex -> -- Don't throw exception if CLOSE failed because the transaction is @@ -58,7 +59,7 @@ closeCursor (Cursor name conn) = -- supplied fold-like function on each row as it is received. In case -- the cursor is exhausted, a 'Left' value is returned, otherwise a -- 'Right' value is returned. -foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) +foldForwardWithParser :: (HasCallStack) => Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do let q = "FETCH FORWARD " <> (toByteString $ intDec chunkSize) @@ -83,11 +84,11 @@ foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do -- | Fold over a chunk of rows, calling the supplied fold-like function -- on each row as it is received. In case the cursor is exhausted, -- a 'Left' value is returned, otherwise a 'Right' value is returned. -foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) +foldForward :: (HasCallStack) => FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) foldForward cursor = foldForwardWithParser cursor fromRow -foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a +foldM' :: (HasCallStack, 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 diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs index 9023a807..4b454778 100644 --- a/src/Database/PostgreSQL/Simple/Errors.hs +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -25,6 +25,7 @@ module Database.PostgreSQL.Simple.Errors ) where +import GHC.Stack import Control.Applicative import Control.Exception as E @@ -70,7 +71,7 @@ instance Exception ConstraintViolation -- > where -- > handler (UniqueViolation "user_login_key") = ... -- > handler _ = ... -constraintViolation :: SqlError -> Maybe ConstraintViolation +constraintViolation :: (HasCallStack) => SqlError -> Maybe ConstraintViolation constraintViolation e = case sqlState e of "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg @@ -89,7 +90,7 @@ constraintViolation e = -- > handler (_, UniqueViolation "user_login_key") = ... -- > handler (e, _) = throwIO e -- -constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) +constraintViolationE :: (HasCallStack) => SqlError -> Maybe (SqlError, ConstraintViolation) constraintViolationE e = fmap ((,) e) $ constraintViolation e -- | Catches SqlError, tries to convert to ConstraintViolation, re-throws @@ -99,26 +100,26 @@ constraintViolationE e = fmap ((,) e) $ constraintViolation e -- > where -- > catcher _ (UniqueViolation "user_login_key") = ... -- > catcher e _ = throwIO e -catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a +catchViolation :: (HasCallStack) => (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 :: (HasCallStack) => 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 :: (HasCallStack) => Parser ByteString parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' -parseQ2 :: Parser (ByteString, ByteString) +parseQ2 :: (HasCallStack) => Parser (ByteString, ByteString) parseQ2 = (,) <$> parseQ1 <*> parseQ1 -parseMaybe :: Parser a -> ByteString -> Maybe a +parseMaybe :: (HasCallStack) => Parser a -> ByteString -> Maybe a parseMaybe p b = either (const Nothing) Just $ parseOnly p b ------------------------------------------------------------------------ @@ -126,14 +127,14 @@ parseMaybe p b = either (const Nothing) Just $ parseOnly p b -- -- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html -isSerializationError :: SqlError -> Bool +isSerializationError :: (HasCallStack) => SqlError -> Bool isSerializationError = isSqlState "40001" -isNoActiveTransactionError :: SqlError -> Bool +isNoActiveTransactionError :: (HasCallStack) => SqlError -> Bool isNoActiveTransactionError = isSqlState "25P01" -isFailedTransactionError :: SqlError -> Bool +isFailedTransactionError :: (HasCallStack) => SqlError -> Bool isFailedTransactionError = isSqlState "25P02" -isSqlState :: ByteString -> SqlError -> Bool +isSqlState :: (HasCallStack) => ByteString -> SqlError -> Bool isSqlState s SqlError{..} = sqlState == s diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs index 2868ce33..3da31457 100644 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -113,6 +113,7 @@ module Database.PostgreSQL.Simple.FromField #include "MachDeps.h" +import GHC.Stack import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) @@ -180,7 +181,7 @@ data ResultError = Incompatible { errSQLType :: String instance Exception ResultError -left :: Exception a => a -> Conversion b +left :: (HasCallStack, Exception a) => a -> Conversion b left = conversionError type FieldParser a = Field -> Maybe ByteString -> Conversion a @@ -214,21 +215,21 @@ class FromField a where -- postgresql-simple will check a per-connection cache, and then -- finally query the database's meta-schema. -typename :: Field -> Conversion ByteString +typename :: (HasCallStack) => Field -> Conversion ByteString typename field = typname <$> typeInfo field -typeInfo :: Field -> Conversion TypeInfo +typeInfo :: (HasCallStack) => Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do Ok <$> (getTypeInfo conn typeOid) -typeInfoByOid :: PQ.Oid -> Conversion TypeInfo +typeInfoByOid :: (HasCallStack) => 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 :: (HasCallStack) => Field -> Maybe ByteString name Field{..} = unsafeDupablePerformIO (PQ.fname result column) -- | Returns the name of the object id of the @table@ associated with the @@ -236,7 +237,7 @@ name Field{..} = unsafeDupablePerformIO (PQ.fname result column) -- for example a computed column does not have a table associated with it. -- Analogous to libpq's @PQftable@. -tableOid :: Field -> Maybe PQ.Oid +tableOid :: (HasCallStack) => Field -> Maybe PQ.Oid tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column)) where toMaybeOid x @@ -248,7 +249,7 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column -- off the associated table column. Numbering starts from 0. Analogous -- to libpq's @PQftablecol@. -tableColumn :: Field -> Int +tableColumn :: (HasCallStack) => Field -> Int tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column)) where fromCol (PQ.Col x) = fromIntegral x @@ -256,7 +257,7 @@ tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result col -- | This returns whether the data was returned in a binary or textual format. -- Analogous to libpq's @PQfformat@. -format :: Field -> PQ.Format +format :: (HasCallStack) => Field -> PQ.Format format Field{..} = unsafeDupablePerformIO (PQ.fformat result column) -- | void @@ -277,7 +278,7 @@ instance FromField a => FromField (Maybe a) where -- also turns type and conversion errors into 'Nothing', whereas this is -- more specific and turns only @null@ values into 'Nothing'. -optionalField :: FieldParser a -> FieldParser (Maybe a) +optionalField :: (HasCallStack) => FieldParser a -> FieldParser (Maybe a) optionalField p f mv = case mv of Nothing -> pure Nothing @@ -357,17 +358,17 @@ 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 :: (HasCallStack) => Binary t -> t unBinary (Binary x) = x -pg_double :: Parser Double +pg_double :: (HasCallStack) => 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 :: (HasCallStack) => Parser Rational pg_rational = (string "NaN" *> pure notANumber ) <|> (string "Infinity" *> pure infinity ) @@ -388,7 +389,7 @@ instance FromField PQ.Oid where instance FromField LB.ByteString where fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat -unescapeBytea :: Field -> SB.ByteString +unescapeBytea :: (HasCallStack) => Field -> SB.ByteString -> Conversion (Binary SB.ByteString) unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of Nothing -> returnError ConversionFailed f "unescapeBytea failed" @@ -475,7 +476,7 @@ instance FromField LocalTimestamp where instance FromField Date where fromField = ff $(inlineTypoid TI.date) "Date" parseDate -ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a) +ff :: (HasCallStack) => PQ.Oid -> String -> (B8.ByteString -> Either String a) -> Field -> Maybe B8.ByteString -> Conversion a ff compatOid hsType parse f mstr = if typeOid f /= compatOid @@ -506,7 +507,7 @@ instance (FromField a, FromField b) => FromField (Either a b) where instance (FromField a, Typeable a) => FromField (PGArray a) where fromField = pgArrayFieldParser fromField -pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a) +pgArrayFieldParser :: (HasCallStack, Typeable a) => FieldParser a -> FieldParser (PGArray a) pgArrayFieldParser fieldParser f mdat = do info <- typeInfo f case info of @@ -519,7 +520,7 @@ pgArrayFieldParser fieldParser f mdat = do Right conv -> PGArray <$> conv _ -> returnError Incompatible f "" -fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a]) +fromArray :: (HasCallStack) => FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a]) fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim where delim = typdelim (typelem typeInfo) @@ -581,7 +582,7 @@ instance FromField JSON.Value where -- like to return @Nothing@ on both the SQL @null@ and json @null@ values, -- one way to do it would be to write -- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@ -fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a +fromJSONField :: (HasCallStack) => (JSON.FromJSON a, Typeable a) => FieldParser a fromJSONField f mbBs = do value <- fromField f mbBs case JSON.fromJSON value of @@ -618,7 +619,7 @@ okInt = ok32 okInt = ok64 #endif -doFromField :: forall a . (Typeable a) +doFromField :: forall a . (Typeable a, HasCallStack) => Field -> Compat -> (ByteString -> Conversion a) -> Maybe ByteString -> Conversion a doFromField f isCompat cvt (Just bs) @@ -631,7 +632,7 @@ doFromField f _ _ _ = returnError UnexpectedNull f "" -- 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) +returnError :: forall a err . (Typeable a, Exception err, HasCallStack) => (String -> Maybe PQ.Oid -> String -> String -> String -> err) -> Field -> String -> Conversion a returnError mkErr f msg = do @@ -642,7 +643,7 @@ returnError mkErr f msg = do (show (typeOf (undefined :: a))) msg -atto :: forall a. (Typeable a) +atto :: forall a. (Typeable a, HasCallStack) => Compat -> Parser a -> Field -> Maybe ByteString -> Conversion a atto types p0 f dat = doFromField f types (go p0) dat diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs index b38f06e4..24b4ef90 100644 --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -28,6 +28,7 @@ module Database.PostgreSQL.Simple.FromRow , numFieldsRemaining ) where +import GHC.Stack import Prelude hiding (null) import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) @@ -77,22 +78,22 @@ class FromRow a where default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a fromRow = to <$> gfromRow -getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString +getvalue :: (HasCallStack) => PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col) -nfields :: PQ.Result -> PQ.Column +nfields :: (HasCallStack) => PQ.Result -> PQ.Column nfields result = unsafeDupablePerformIO (PQ.nfields result) -getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo +getTypeInfoByCol :: (HasCallStack) => 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 :: (HasCallStack) => Row -> PQ.Column -> Conversion ByteString getTypenameByCol row col = typname <$> getTypeInfoByCol row col -fieldWith :: FieldParser a -> RowParser a +fieldWith :: (HasCallStack) => FieldParser a -> RowParser a fieldWith fieldP = RP $ do let unCol (PQ.Col x) = fromIntegral x :: Int r@Row{..} <- ask @@ -117,21 +118,21 @@ fieldWith fieldP = RP $ do !field = Field{..} lift (lift (fieldP field (getvalue result row column))) -field :: FromField a => RowParser a +field :: (HasCallStack) => FromField a => RowParser a field = fieldWith fromField -ellipsis :: ByteString -> ByteString +ellipsis :: (HasCallStack) => ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs -numFieldsRemaining :: RowParser Int +numFieldsRemaining :: (HasCallStack) => RowParser Int numFieldsRemaining = RP $ do Row{..} <- ask column <- lift get return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column) -null :: RowParser Null +null :: (HasCallStack) => RowParser Null null = field instance (FromField a) => FromRow (Only a) where diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs index ee393822..50a57993 100644 --- a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -14,6 +14,7 @@ module Database.PostgreSQL.Simple.HStore.Implementation where +import GHC.Stack import Control.Applicative import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) @@ -36,6 +37,7 @@ import Data.Typeable import Data.Monoid(Monoid(..)) import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField +import qualified Data.List as DL class ToHStore a where toHStore :: a -> HStoreBuilder @@ -90,7 +92,7 @@ instance ToHStoreText TS.Text where instance ToHStoreText TL.Text where toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty -escapeAppend :: BS.ByteString -> Builder -> Builder +escapeAppend :: (HasCallStack) => BS.ByteString -> Builder -> Builder escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest @@ -104,7 +106,7 @@ escapeAppend = loop | c == c2w '\"' = byteString "\\\"" | otherwise = byteString "\\\\" -hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder +hstore :: (HasCallStack, ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\"" `mappend` val `mappend` char8 '"') @@ -153,20 +155,26 @@ 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 :: (HasCallStack) => 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 :: (HasCallStack) => 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)) + return $ (HStoreList . (DL.foldl' removeNull [])) <$> sequence kvs + where + removeNull :: (HasCallStack) => [(Text, Text)] -> (Text, Maybe Text) -> [(Text, Text)] + removeNull memo (k, Nothing) = memo + removeNull memo (k, Just v) = memo ++ [(k, v)] + +-- NOTE: The Right value is a (Maybe (Text, Text)) to be able to handle +-- key-value pairs where the value is NULL in the DB. +parseHStoreKeyVal :: (HasCallStack) => P.Parser (Either UnicodeException (Text, Maybe Text)) parseHStoreKeyVal = do mkey <- parseHStoreText case mkey of @@ -175,16 +183,22 @@ parseHStoreKeyVal = do skipWhiteSpace _ <- P.string "=>" skipWhiteSpace - mval <- parseHStoreText + mval <- parseHStoreNullableText case mval of Left err -> return (Left err) - Right val -> return (Right (key,val)) + Right Nothing -> return (Right (key, Nothing)) + Right (Just val) -> return (Right (key, Just val)) -skipWhiteSpace :: P.Parser () +skipWhiteSpace :: (HasCallStack) => P.Parser () skipWhiteSpace = P.skipWhile P.isSpace_w8 -parseHStoreText :: P.Parser (Either UnicodeException Text) +parseHStoreNullableText :: (HasCallStack) => P.Parser (Either UnicodeException (Maybe Text)) +parseHStoreNullableText = nullParser <|> (fmap . fmap) Just parseHStoreText + where + nullParser = (P.string "NULL" <|> P.string "null") >> return (Right Nothing) + +parseHStoreText :: (HasCallStack) => P.Parser (Either UnicodeException Text) parseHStoreText = do _ <- P.word8 (c2w '"') mtexts <- parseHStoreTexts id @@ -194,7 +208,7 @@ parseHStoreText = do _ <- P.word8 (c2w '"') return (Right (TS.concat texts)) -parseHStoreTexts :: ([Text] -> [Text]) +parseHStoreTexts :: (HasCallStack) => ([Text] -> [Text]) -> P.Parser (Either UnicodeException [Text]) parseHStoreTexts acc = do mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar) diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs index a5eafa97..85bc0231 100644 --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -20,6 +20,7 @@ module Database.PostgreSQL.Simple.Internal where +import GHC.Stack import Control.Applicative import Control.Exception import Control.Concurrent.MVar @@ -88,7 +89,7 @@ data SqlError = SqlError { , sqlErrorHint :: ByteString } deriving (Eq, Show, Typeable) -fatalError :: ByteString -> SqlError +fatalError :: (HasCallStack) => ByteString -> SqlError fatalError msg = SqlError "" FatalError msg "" "" instance Exception SqlError @@ -139,7 +140,7 @@ data ConnectInfo = ConnectInfo { -- -- > connect defaultConnectInfo { connectHost = "db.example.com" } -defaultConnectInfo :: ConnectInfo +defaultConnectInfo :: (HasCallStack) => ConnectInfo defaultConnectInfo = ConnectInfo { connectHost = "127.0.0.1" , connectPort = 5432 @@ -150,7 +151,7 @@ defaultConnectInfo = ConnectInfo { -- | Connect with the given username to the given database. Will throw -- an exception if it cannot connect. -connect :: ConnectInfo -> IO Connection +connect :: (HasCallStack) => ConnectInfo -> IO Connection connect = connectPostgreSQL . postgreSQLConnectionString -- | Attempt to make a connection based on a libpq connection string. @@ -222,7 +223,7 @@ connect = connectPostgreSQL . postgreSQLConnectionString -- -- for detailed information regarding libpq and SSL. -connectPostgreSQL :: ByteString -> IO Connection +connectPostgreSQL :: (HasCallStack) => ByteString -> IO Connection connectPostgreSQL connstr = do conn <- connectdb connstr stat <- PQ.status conn @@ -242,7 +243,7 @@ connectPostgreSQL connstr = do msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn throwIO $ fatalError msg -connectdb :: ByteString -> IO PQ.Connection +connectdb :: (HasCallStack) => ByteString -> IO PQ.Connection #if defined(mingw32_HOST_OS) connectdb = PQ.connectdb #else @@ -275,7 +276,7 @@ connectdb conninfo = do -- | Turns a 'ConnectInfo' data structure into a libpq connection string. -postgreSQLConnectionString :: ConnectInfo -> ByteString +postgreSQLConnectionString :: (HasCallStack) => ConnectInfo -> ByteString postgreSQLConnectionString connectInfo = fromString connstr where connstr = str "host=" connectHost @@ -307,11 +308,11 @@ postgreSQLConnectionString connectInfo = fromString connstr -oid2int :: Oid -> Int +oid2int :: (HasCallStack) => Oid -> Int oid2int (Oid x) = fromIntegral x {-# INLINE oid2int #-} -exec :: Connection +exec :: (HasCallStack) => Connection -> ByteString -> IO PQ.Result #if defined(mingw32_HOST_OS) @@ -363,12 +364,12 @@ exec conn sql = #endif -- | A version of 'execute' that does not perform query substitution. -execute_ :: Connection -> Query -> IO Int64 +execute_ :: (HasCallStack) => 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 :: (HasCallStack) => Connection -> Query -> PQ.Result -> IO Int64 finishExecute _conn q result = do status <- PQ.resultStatus result case status of @@ -403,7 +404,7 @@ finishExecute _conn q result = do 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 :: (HasCallStack) => ByteString -> PQ.Result -> PQ.ExecStatus -> IO a throwResultError _ result status = do errormsg <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessagePrimary @@ -418,18 +419,18 @@ throwResultError _ result status = do , sqlErrorDetail = detail , sqlErrorHint = hint } -disconnectedError :: SqlError +disconnectedError :: (HasCallStack) => 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 :: (HasCallStack) => 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 :: (HasCallStack) => Connection -> IO () close Connection{..} = mask $ \restore -> (do conn <- takeMVar connectionHandle @@ -438,7 +439,7 @@ close Connection{..} = putMVar connectionHandle =<< PQ.newNullConnection ) -newNullConnection :: IO Connection +newNullConnection :: (HasCallStack) => IO Connection newNullConnection = do connectionHandle <- newMVar =<< PQ.newNullConnection connectionObjects <- newMVar IntMap.empty @@ -453,12 +454,12 @@ data Row = Row { newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a } deriving ( Functor, Applicative, Alternative, Monad ) -liftRowParser :: IO a -> RowParser a +liftRowParser :: (HasCallStack) => IO a -> RowParser a liftRowParser = RP . lift . lift . liftConversion newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } -liftConversion :: IO a -> Conversion a +liftConversion :: (HasCallStack) => IO a -> Conversion a liftConversion m = Conversion (\_ -> Ok <$> m) instance Functor Conversion where @@ -494,20 +495,20 @@ instance MonadPlus Conversion where mzero = empty mplus = (<|>) -conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b +conversionMap :: (HasCallStack) => (Ok a -> Ok b) -> Conversion a -> Conversion b conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn -conversionError :: Exception err => err -> Conversion a +conversionError :: (HasCallStack) => Exception err => err -> Conversion a conversionError err = Conversion $ \_ -> return (Errors [toException err]) -newTempName :: Connection -> IO Query +newTempName :: (HasCallStack) => 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 :: (HasCallStack) => ByteString -> IOError fdError funcName = IOError { ioe_handle = Nothing, ioe_type = ResourceVanished, @@ -518,7 +519,7 @@ fdError funcName = IOError { } -libPQError :: ByteString -> IOError +libPQError :: (HasCallStack) => ByteString -> IOError libPQError desc = IOError { ioe_handle = Nothing, ioe_type = OtherError, @@ -528,13 +529,13 @@ libPQError desc = IOError { ioe_filename = Nothing } -throwLibPQError :: PQ.Connection -> ByteString -> IO a +throwLibPQError :: (HasCallStack) => 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 :: (HasCallStack) => String -> Query -> [Action] -> a fmtError msg q xs = throw FormatError { fmtMessage = msg , fmtQuery = q @@ -546,14 +547,14 @@ fmtError msg q xs = throw FormatError { twiddle (EscapeIdentifier s) = s twiddle (Many ys) = B.concat (map twiddle ys) -fmtErrorBs :: Query -> [Action] -> ByteString -> a +fmtErrorBs :: (HasCallStack) => 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 :: (HasCallStack) => Query -> [Action] -> Either ByteString ByteString -> Builder quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString) -buildAction :: Connection -- ^ Connection for string escaping +buildAction :: (HasCallStack) => Connection -- ^ Connection for string escaping -> Query -- ^ Query for message error -> [Action] -- ^ List of parameters for message error -> Action -- ^ Action to build @@ -566,11 +567,11 @@ buildAction conn q xs (EscapeIdentifier s) = buildAction conn q xs (Many ys) = mconcat <$> mapM (buildAction conn q xs) ys -checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a) +checkError :: (HasCallStack) => 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)) +escapeWrap :: (HasCallStack) => (PQ.Connection -> ByteString -> IO (Maybe ByteString)) -> Connection -> ByteString -> IO (Either ByteString ByteString) @@ -578,11 +579,11 @@ escapeWrap f conn s = withConnection conn $ \c -> f c s >>= checkError c -escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeStringConn :: (HasCallStack) => Connection -> ByteString -> IO (Either ByteString ByteString) escapeStringConn = escapeWrap PQ.escapeStringConn -escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeIdentifier :: (HasCallStack) => Connection -> ByteString -> IO (Either ByteString ByteString) escapeIdentifier = escapeWrap PQ.escapeIdentifier -escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeByteaConn :: (HasCallStack) => Connection -> ByteString -> IO (Either ByteString ByteString) escapeByteaConn = escapeWrap PQ.escapeByteaConn diff --git a/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs index 59dc81c5..b4a50952 100644 --- a/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs +++ b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs @@ -17,6 +17,7 @@ module Database.PostgreSQL.Simple.Internal.PQResultUtils , getRowWith ) where +import GHC.Stack import Control.Exception as E import Data.ByteString (ByteString) import Database.PostgreSQL.Simple.FromField (ResultError(..)) @@ -29,7 +30,7 @@ import qualified Data.ByteString.Char8 as B import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Strict -finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] +finishQueryWith :: (HasCallStack) => RowParser r -> Connection -> Query -> PQ.Result -> IO [r] finishQueryWith parser conn q result = do status <- PQ.resultStatus result case status of @@ -54,7 +55,7 @@ finishQueryWith parser conn q result = do where queryErr msg = throwIO $ QueryError msg q -getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r +getRowWith :: (HasCallStack) => 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 @@ -77,12 +78,12 @@ getRowWith parser row ncols conn result = do Errors [x] -> throwIO x Errors xs -> throwIO $ ManyErrors xs -ellipsis :: ByteString -> ByteString +ellipsis :: (HasCallStack) => ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs -forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] +forM' :: (HasCallStack, Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] forM' lo hi m = loop hi [] where loop !n !as diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs index 26ede609..fec879fd 100644 --- a/src/Database/PostgreSQL/Simple/LargeObjects.hs +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -40,6 +40,7 @@ module Database.PostgreSQL.Simple.LargeObjects , SeekMode(..) ) where +import GHC.Stack import Control.Applicative ((<$>)) import Control.Exception (throwIO) import qualified Data.ByteString as B @@ -48,7 +49,7 @@ 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 :: (HasCallStack) => B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a liftPQ str conn m = withConnection conn $ \c -> do res <- m c case res of @@ -57,41 +58,41 @@ liftPQ str conn m = withConnection conn $ \c -> do throwIO $ fatalError msg Just x -> return x -loCreat :: Connection -> IO Oid +loCreat :: (HasCallStack) => Connection -> IO Oid loCreat conn = liftPQ "loCreat" conn (\c -> PQ.loCreat c) -loCreate :: Connection -> Oid -> IO Oid +loCreate :: (HasCallStack) => Connection -> Oid -> IO Oid loCreate conn oid = liftPQ "loCreate" conn (\c -> PQ.loCreate c oid) -loImport :: Connection -> FilePath -> IO Oid +loImport :: (HasCallStack) => Connection -> FilePath -> IO Oid loImport conn path = liftPQ "loImport" conn (\c -> PQ.loImport c path) -loImportWithOid :: Connection -> FilePath -> Oid -> IO Oid +loImportWithOid :: (HasCallStack) => Connection -> FilePath -> Oid -> IO Oid loImportWithOid conn path oid = liftPQ "loImportWithOid" conn (\c -> PQ.loImportWithOid c path oid) -loExport :: Connection -> Oid -> FilePath -> IO () +loExport :: (HasCallStack) => Connection -> Oid -> FilePath -> IO () loExport conn oid path = liftPQ "loExport" conn (\c -> PQ.loExport c oid path) -loOpen :: Connection -> Oid -> IOMode -> IO LoFd +loOpen :: (HasCallStack) => 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 :: (HasCallStack) => 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 :: (HasCallStack) => 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 :: (HasCallStack) => 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 :: (HasCallStack) => Connection -> LoFd -> IO Int loTell conn fd = liftPQ "loTell" conn (\c -> PQ.loTell c fd) -loTruncate :: Connection -> LoFd -> Int -> IO () +loTruncate :: (HasCallStack) => Connection -> LoFd -> Int -> IO () loTruncate conn fd len = liftPQ "loTruncate" conn (\c -> PQ.loTruncate c fd len) -loClose :: Connection -> LoFd -> IO () +loClose :: (HasCallStack) => Connection -> LoFd -> IO () loClose conn fd = liftPQ "loClose" conn (\c -> PQ.loClose c fd) -loUnlink :: Connection -> Oid -> IO () +loUnlink :: (HasCallStack) => Connection -> Oid -> IO () loUnlink conn oid = liftPQ "loUnlink" conn (\c -> PQ.loUnlink c oid) diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs index 5ffda980..fdb8c269 100644 --- a/src/Database/PostgreSQL/Simple/Notification.hs +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -44,6 +44,7 @@ import Database.PostgreSQL.Simple.Internal import qualified Database.PostgreSQL.LibPQ as PQ import System.Posix.Types ( CPid ) import GHC.IO.Exception ( ioe_location ) +import GHC.Stack #if defined(mingw32_HOST_OS) import Control.Concurrent ( threadDelay ) @@ -60,7 +61,7 @@ data Notification = Notification , notificationData :: {-# UNPACK #-} !B.ByteString } deriving (Show, Eq) -convertNotice :: PQ.Notify -> Notification +convertNotice :: (HasCallStack) => PQ.Notify -> Notification convertNotice PQ.Notify{..} = Notification { notificationPid = notifyBePid , notificationChannel = notifyRelname @@ -73,7 +74,7 @@ convertNotice PQ.Notify{..} -- being used for other purposes, note however that PostgreSQL does not -- deliver notifications while a connection is inside a transaction. -getNotification :: Connection -> IO Notification +getNotification :: (HasCallStack) => Connection -> IO Notification getNotification conn = join $ withConnection conn fetch where funcName = "Database.PostgreSQL.Simple.Notification.getNotification" @@ -130,14 +131,14 @@ getNotification conn = join $ withConnection conn fetch void $ PQ.consumeInput c fetch c - setIOErrorLocation :: IOError -> IOError + setIOErrorLocation :: (HasCallStack) => IOError -> IOError setIOErrorLocation err = err { ioe_location = B8.unpack funcName } -- | Non-blocking variant of 'getNotification'. Returns a single notification, -- if available. If no notifications are available, returns 'Nothing'. -getNotificationNonBlocking :: Connection -> IO (Maybe Notification) +getNotificationNonBlocking :: (HasCallStack) => Connection -> IO (Maybe Notification) getNotificationNonBlocking conn = withConnection conn $ \c -> do mmsg <- PQ.notifies c @@ -158,5 +159,5 @@ getNotificationNonBlocking conn = -- process). Note that the PID belongs to a process executing on the -- database server host, not the local host! -getBackendPID :: Connection -> IO CPid +getBackendPID :: (HasCallStack) => Connection -> IO CPid getBackendPID conn = withConnection conn PQ.backendPID diff --git a/src/Database/PostgreSQL/Simple/Range.hs b/src/Database/PostgreSQL/Simple/Range.hs index 2ad2a68b..34e25ea0 100644 --- a/src/Database/PostgreSQL/Simple/Range.hs +++ b/src/Database/PostgreSQL/Simple/Range.hs @@ -21,6 +21,7 @@ module Database.PostgreSQL.Simple.Range , contains, containsBy ) where +import GHC.Stack import Control.Applicative hiding (empty) import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) import qualified Data.Attoparsec.ByteString.Char8 as A @@ -64,14 +65,14 @@ data RangeBound a = NegInfinity data PGRange a = PGRange !(RangeBound a) !(RangeBound a) deriving (Show, Typeable, Functor) -empty :: PGRange a +empty :: (HasCallStack) => 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 :: (HasCallStack) => (a -> a -> Ordering) -> PGRange a -> Bool isEmptyBy cmp v = case v of (PGRange PosInfinity _) -> True @@ -89,7 +90,7 @@ isEmptyBy cmp v = -- which 'contains' returns 'True'. -- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@, -- for example. -isEmpty :: Ord a => PGRange a -> Bool +isEmpty :: (HasCallStack, Ord a) => PGRange a -> Bool isEmpty = isEmptyBy compare @@ -100,10 +101,10 @@ isEmpty = isEmptyBy compare -- 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 :: (HasCallStack, Ord a) => PGRange a -> (a -> Bool) contains = containsBy compare -containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool) +containsBy :: (HasCallStack) => (a -> a -> Ordering) -> PGRange a -> (a -> Bool) containsBy cmp rng x = case rng of PGRange _lb NegInfinity -> False @@ -123,16 +124,16 @@ containsBy cmp rng x = Inclusive z -> cmp x z /= GT Exclusive z -> cmp x z == LT -lowerBound :: Parser (a -> RangeBound a) +lowerBound :: (HasCallStack) => Parser (a -> RangeBound a) lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive) {-# INLINE lowerBound #-} -upperBound :: Parser (a -> RangeBound a) +upperBound :: (HasCallStack) => 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 :: (HasCallStack) => Parser (RangeBound B.ByteString, RangeBound B.ByteString) pgrange = do lb <- lowerBound v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',') @@ -143,13 +144,13 @@ pgrange = do up = if B.null v2 then PosInfinity else ub v2 return (low, up) -rangeElem :: (Char -> Bool) -> Parser B.ByteString +rangeElem :: (HasCallStack) => (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 :: (HasCallStack) => Parser B.ByteString doubleQuoted = toByteString <$> go mempty where go acc = do @@ -165,11 +166,11 @@ doubleQuoted = toByteString <$> go mempty _ -> error "impossible in doubleQuoted" rest -rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder +rangeToBuilder :: (HasCallStack, 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 :: (HasCallStack) => (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder rangeToBuilderBy cmp f x = if isEmptyBy cmp x then byteString "'empty'" @@ -274,7 +275,7 @@ instance ToField (PGRange ZonedTime) where toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder {-# INLINE toField #-} -cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering +cmpZonedTime :: (HasCallStack) => ZonedTime -> ZonedTime -> Ordering cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize instance ToField (PGRange LocalTime) where @@ -297,7 +298,7 @@ instance ToField (PGRange ZonedTimestamp) where toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder {-# INLINE toField #-} -cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering +cmpZonedTimestamp :: (HasCallStack) => ZonedTimestamp -> ZonedTimestamp -> Ordering cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>) instance ToField (PGRange LocalTimestamp) where diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs index b105fb4e..ceef50b0 100644 --- a/src/Database/PostgreSQL/Simple/SqlQQ.hs +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -15,6 +15,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Quote import Data.Char import Data.String +import GHC.Stack -- | 'sql' is a quasiquoter that eases the syntactic burden -- of writing big sql statements in Haskell source code. For example: @@ -50,7 +51,7 @@ import Data.String -- Also note that this will not work if the substring @|]@ is contained -- in the query. -sql :: QuasiQuoter +sql :: (HasCallStack) => QuasiQuoter sql = QuasiQuoter { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ quasiquoter used in pattern context" @@ -61,10 +62,10 @@ sql = QuasiQuoter \ quasiquoter used in declaration context" } -sqlExp :: String -> Q Exp +sqlExp :: (HasCallStack) => String -> Q Exp sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace -minimizeSpace :: String -> String +minimizeSpace :: (HasCallStack) => String -> String minimizeSpace = drop 1 . reduceSpace where needsReduced [] = False diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs index 59fed837..59e2e078 100644 --- a/src/Database/PostgreSQL/Simple/Time/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -25,6 +25,7 @@ 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 +import GHC.Stack data Unbounded a = NegInfinity @@ -50,117 +51,117 @@ type UTCTimestamp = Unbounded UTCTime type ZonedTimestamp = Unbounded ZonedTime type Date = Unbounded Day -parseUTCTime :: B.ByteString -> Either String UTCTime +parseUTCTime :: (HasCallStack) => B.ByteString -> Either String UTCTime parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) -parseZonedTime :: B.ByteString -> Either String ZonedTime +parseZonedTime :: (HasCallStack) => B.ByteString -> Either String ZonedTime parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput) -parseLocalTime :: B.ByteString -> Either String LocalTime +parseLocalTime :: (HasCallStack) => B.ByteString -> Either String LocalTime parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput) -parseDay :: B.ByteString -> Either String Day +parseDay :: (HasCallStack) => B.ByteString -> Either String Day parseDay = A.parseOnly (getDay <* A.endOfInput) -parseTimeOfDay :: B.ByteString -> Either String TimeOfDay +parseTimeOfDay :: (HasCallStack) => B.ByteString -> Either String TimeOfDay parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput) -parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp +parseUTCTimestamp :: (HasCallStack) => B.ByteString -> Either String UTCTimestamp parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput) -parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp +parseZonedTimestamp :: (HasCallStack) => B.ByteString -> Either String ZonedTimestamp parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput) -parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp +parseLocalTimestamp :: (HasCallStack) => B.ByteString -> Either String LocalTimestamp parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput) -parseDate :: B.ByteString -> Either String Date +parseDate :: (HasCallStack) => B.ByteString -> Either String Date parseDate = A.parseOnly (getDate <* A.endOfInput) -getUnbounded :: A.Parser a -> A.Parser (Unbounded a) +getUnbounded :: (HasCallStack) => 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 :: (HasCallStack) => A.Parser Day getDay = TP.day -getDate :: A.Parser Date +getDate :: (HasCallStack) => A.Parser Date getDate = getUnbounded getDay -getTimeOfDay :: A.Parser TimeOfDay +getTimeOfDay :: (HasCallStack) => A.Parser TimeOfDay getTimeOfDay = TP.timeOfDay -getLocalTime :: A.Parser LocalTime +getLocalTime :: (HasCallStack) => A.Parser LocalTime getLocalTime = TP.localTime -getLocalTimestamp :: A.Parser LocalTimestamp +getLocalTimestamp :: (HasCallStack) => A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime -getTimeZone :: A.Parser TimeZone +getTimeZone :: (HasCallStack) => A.Parser TimeZone getTimeZone = fromMaybe utc <$> TP.timeZone type TimeZoneHMS = (Int,Int,Int) -getTimeZoneHMS :: A.Parser TimeZoneHMS +getTimeZoneHMS :: (HasCallStack) => 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 :: (HasCallStack) => TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) localToUTCTimeOfDayHMS (dh, dm, ds) tod = TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod -getZonedTime :: A.Parser ZonedTime +getZonedTime :: (HasCallStack) => A.Parser ZonedTime getZonedTime = TP.zonedTime -getZonedTimestamp :: A.Parser ZonedTimestamp +getZonedTimestamp :: (HasCallStack) => A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime -getUTCTime :: A.Parser UTCTime +getUTCTime :: (HasCallStack) => A.Parser UTCTime getUTCTime = TP.utcTime -getUTCTimestamp :: A.Parser UTCTimestamp +getUTCTimestamp :: (HasCallStack) => A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime -dayToBuilder :: Day -> Builder +dayToBuilder :: (HasCallStack) => Day -> Builder dayToBuilder = primBounded TPP.day -timeOfDayToBuilder :: TimeOfDay -> Builder +timeOfDayToBuilder :: (HasCallStack) => TimeOfDay -> Builder timeOfDayToBuilder = primBounded TPP.timeOfDay -timeZoneToBuilder :: TimeZone -> Builder +timeZoneToBuilder :: (HasCallStack) => TimeZone -> Builder timeZoneToBuilder = primBounded TPP.timeZone -utcTimeToBuilder :: UTCTime -> Builder +utcTimeToBuilder :: (HasCallStack) => UTCTime -> Builder utcTimeToBuilder = primBounded TPP.utcTime -zonedTimeToBuilder :: ZonedTime -> Builder +zonedTimeToBuilder :: (HasCallStack) => ZonedTime -> Builder zonedTimeToBuilder = primBounded TPP.zonedTime -localTimeToBuilder :: LocalTime -> Builder +localTimeToBuilder :: (HasCallStack) => LocalTime -> Builder localTimeToBuilder = primBounded TPP.localTime -unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) +unboundedToBuilder :: (HasCallStack) => (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 :: (HasCallStack) => UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder -zonedTimestampToBuilder :: ZonedTimestamp -> Builder +zonedTimestampToBuilder :: (HasCallStack) => ZonedTimestamp -> Builder zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder -localTimestampToBuilder :: LocalTimestamp -> Builder +localTimestampToBuilder :: (HasCallStack) => LocalTimestamp -> Builder localTimestampToBuilder = unboundedToBuilder localTimeToBuilder -dateToBuilder :: Date -> Builder +dateToBuilder :: (HasCallStack) => Date -> Builder dateToBuilder = unboundedToBuilder dayToBuilder -nominalDiffTimeToBuilder :: NominalDiffTime -> Builder +nominalDiffTimeToBuilder :: (HasCallStack) => NominalDiffTime -> Builder nominalDiffTimeToBuilder = TPP.nominalDiffTime diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs index 47f292b3..25768481 100644 --- a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs @@ -35,9 +35,10 @@ 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 +import GHC.Stack -- | Parse a date of the form @YYYY-MM-DD@. -day :: Parser Day +day :: (HasCallStack) => Parser Day day = do y <- decimal <* char '-' m <- twoDigits <* char '-' @@ -45,7 +46,7 @@ day = do maybe (fail "invalid date") return (fromGregorianValid y m d) -- | Parse a two-digit integer (e.g. day of month, hour). -twoDigits :: Parser Int +twoDigits :: (HasCallStack) => Parser Int twoDigits = do a <- digit b <- digit @@ -53,7 +54,7 @@ twoDigits = do return $! c2d a * 10 + c2d b -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. -timeOfDay :: Parser Local.TimeOfDay +timeOfDay :: (HasCallStack) => Parser Local.TimeOfDay timeOfDay = do h <- twoDigits <* char ':' m <- twoDigits @@ -67,7 +68,7 @@ timeOfDay = do -- | Parse a count of seconds, with the integer part being two digits -- long. -seconds :: Parser Pico +seconds :: (HasCallStack) => Parser Pico seconds = do real <- twoDigits mc <- peekChar @@ -77,7 +78,7 @@ seconds = do return $! parsePicos (fromIntegral real) t _ -> return $! fromIntegral real where - parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos :: (HasCallStack) => 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 @@ -85,7 +86,7 @@ seconds = do -- | 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 :: (HasCallStack) => Parser (Maybe Local.TimeZone) timeZone = do ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' if ch == 'Z' @@ -112,7 +113,7 @@ data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNP -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) -timeZoneHMS :: Parser (Maybe UTCOffsetHMS) +timeZoneHMS :: (HasCallStack) => Parser (Maybe UTCOffsetHMS) timeZoneHMS = do ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' if ch == 'Z' @@ -139,7 +140,7 @@ timeZoneHMS = do Just ':' -> anyChar *> twoDigits _ -> return 0 -localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) +localToUTCTimeOfDayHMS :: (HasCallStack) => 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 @@ -161,13 +162,13 @@ localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = -- | 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 :: (HasCallStack) => 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 :: (HasCallStack) => Parser UTCTime utcTime = do (Local.LocalTime d t) <- localTime mtz <- timeZoneHMS @@ -188,8 +189,8 @@ utcTime = do -- 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 :: (HasCallStack) => Parser Local.ZonedTime zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) -utc :: Local.TimeZone +utc :: (HasCallStack) => Local.TimeZone utc = Local.TimeZone 0 False "" diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs index dc15e0c3..d3579e71 100644 --- a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs @@ -32,26 +32,27 @@ import Data.Time , TimeZone, timeZoneMinutes ) import Database.PostgreSQL.Simple.Compat ((<>), fromPico) import Unsafe.Coerce (unsafeCoerce) +import GHC.Stack -liftB :: FixedPrim a -> BoundedPrim a +liftB :: (HasCallStack) => FixedPrim a -> BoundedPrim a liftB = liftFixedToBounded -digit :: FixedPrim Int +digit :: (HasCallStack) => FixedPrim Int digit = (\x -> chr (x + 48)) >$< char8 -digits2 :: FixedPrim Int +digits2 :: (HasCallStack) => FixedPrim Int digits2 = (`quotRem` 10) >$< (digit >*< digit) -digits3 :: FixedPrim Int +digits3 :: (HasCallStack) => FixedPrim Int digits3 = (`quotRem` 10) >$< (digits2 >*< digit) -digits4 :: FixedPrim Int +digits4 :: (HasCallStack) => FixedPrim Int digits4 = (`quotRem` 10) >$< (digits3 >*< digit) -frac :: BoundedPrim Int64 +frac :: (HasCallStack) => BoundedPrim Int64 frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) where - trunc12 :: BoundedPrim Int64 + trunc12 :: (HasCallStack) => BoundedPrim Int64 trunc12 = (`quotRem` 1000000) >$< condB (\(_,y) -> y == 0) (fst >$< trunc6) @@ -70,22 +71,22 @@ frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) trunc1 = condB (== 0) emptyB digitB -year :: BoundedPrim Int32 +year :: (HasCallStack) => BoundedPrim Int32 year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4) where - checkBCE :: Int32 -> Int + checkBCE :: (HasCallStack) => 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 :: (HasCallStack) => BoundedPrim Day day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) where toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d)))) -timeOfDay :: BoundedPrim TimeOfDay +timeOfDay :: (HasCallStack) => BoundedPrim TimeOfDay timeOfDay = f >$< (hh_mm_ >*< ss) where f (TimeOfDay h m s) = ((h,(':',(m,':'))),s) @@ -95,7 +96,7 @@ timeOfDay = f >$< (hh_mm_ >*< ss) ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$< (liftB (fromIntegral >$< digits2) >*< frac) -timeZone :: BoundedPrim TimeZone +timeZone :: (HasCallStack) => BoundedPrim TimeZone timeZone = timeZoneMinutes >$< tz where tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh) @@ -104,20 +105,20 @@ timeZone = timeZoneMinutes >$< tz tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2)) -utcTime :: BoundedPrim UTCTime +utcTime :: (HasCallStack) => BoundedPrim UTCTime utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z'))) -localTime :: BoundedPrim LocalTime +localTime :: (HasCallStack) => BoundedPrim LocalTime localTime = f >$< (day >*< liftB char8 >*< timeOfDay) where f (LocalTime d tod) = (d, (' ', tod)) -zonedTime :: BoundedPrim ZonedTime +zonedTime :: (HasCallStack) => BoundedPrim ZonedTime zonedTime = f >$< (localTime >*< timeZone) where f (ZonedTime lt tz) = (lt, tz) -nominalDiffTime :: NominalDiffTime -> Builder +nominalDiffTime :: (HasCallStack) => NominalDiffTime -> Builder nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) where (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs index cf1ace18..337af3f9 100644 --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -59,6 +59,7 @@ import Data.Text.Lazy.Builder.Scientific (scientificBuilder) import Data.Scientific (scientificBuilder) #endif import Foreign.C.Types (CUInt(..)) +import GHC.Stack -- | How to render an element when substituting it into a query. data Action = @@ -110,7 +111,7 @@ instance (ToField a) => ToField (In [a]) where (intersperse (Plain (char8 ',')) . map toField $ xs) ++ [Plain (char8 ')')] -renderNull :: Action +renderNull :: (HasCallStack) => Action renderNull = Plain (byteString "null") instance ToField Null where @@ -297,17 +298,17 @@ instance ToField JSON.Value where -- 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 :: (HasCallStack, 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 :: (HasCallStack) => Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote where quote = char8 '\'' -interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] +interleaveFoldr :: (HasCallStack) => (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as {-# INLINE interleaveFoldr #-} @@ -330,10 +331,10 @@ instance ToRow a => ToField (Values a) where litC = Plain . char8 values x = Many (lit "(VALUES ": x) - typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action] + typedField :: (HasCallStack) => (Action, QualifiedIdentifier) -> [Action] -> [Action] typedField (val,typ) rest = val : lit "::" : toField typ : rest - typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action] + typedRow :: (HasCallStack) => [Action] -> [QualifiedIdentifier] -> [Action] -> [Action] typedRow (val:vals) (typ:typs) rest = litC '(' : typedField (val,typ) ( interleaveFoldr @@ -343,7 +344,7 @@ instance ToRow a => ToField (Values a) where (zip vals typs) ) typedRow _ _ _ = error emptyrow - untypedRow :: [Action] -> [Action] -> [Action] + untypedRow :: (HasCallStack) => [Action] -> [Action] -> [Action] untypedRow (val:vals) rest = litC '(' : val : interleaveFoldr @@ -353,17 +354,17 @@ instance ToRow a => ToField (Values a) where vals untypedRow _ _ = error emptyrow - typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] + typedRows :: (HasCallStack) => 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 :: (HasCallStack) => 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 :: (HasCallStack) => ToRow a => [a] -> [Action] -> [Action] multiRows vals rest = interleaveFoldr (untypedRow . toRow) (litC ',') diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs index bd26f942..c66ac12d 100644 --- a/src/Database/PostgreSQL/Simple/Transaction.hs +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -51,6 +51,7 @@ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Errors import Database.PostgreSQL.Simple.Compat (mask, (<>)) +import GHC.Stack -- | Of the four isolation levels defined by the SQL standard, @@ -87,15 +88,15 @@ data TransactionMode = TransactionMode { readWriteMode :: !ReadWriteMode } deriving (Show, Eq) -defaultTransactionMode :: TransactionMode +defaultTransactionMode :: (HasCallStack) => TransactionMode defaultTransactionMode = TransactionMode defaultIsolationLevel defaultReadWriteMode -defaultIsolationLevel :: IsolationLevel +defaultIsolationLevel :: (HasCallStack) => IsolationLevel defaultIsolationLevel = DefaultIsolationLevel -defaultReadWriteMode :: ReadWriteMode +defaultReadWriteMode :: (HasCallStack) => ReadWriteMode defaultReadWriteMode = DefaultReadWriteMode -- | Execute an action inside a SQL transaction. @@ -110,7 +111,7 @@ defaultReadWriteMode = DefaultReadWriteMode -- 'rollback', then the exception will be rethrown. -- -- For nesting transactions, see 'withSavepoint'. -withTransaction :: Connection -> IO a -> IO a +withTransaction :: (HasCallStack) => Connection -> IO a -> IO a withTransaction = withTransactionMode defaultTransactionMode -- | Execute an action inside of a 'Serializable' transaction. If a @@ -123,7 +124,7 @@ withTransaction = withTransactionMode defaultTransactionMode -- what might happen between one statement and the next. -- -- Think of it as STM, but without @retry@. -withTransactionSerializable :: Connection -> IO a -> IO a +withTransactionSerializable :: (HasCallStack) => Connection -> IO a -> IO a withTransactionSerializable = withTransactionModeRetry TransactionMode @@ -133,12 +134,12 @@ withTransactionSerializable = isSerializationError -- | Execute an action inside a SQL transaction with a given isolation level. -withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a +withTransactionLevel :: (HasCallStack) => 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 :: (HasCallStack) => TransactionMode -> Connection -> IO a -> IO a withTransactionMode mode conn act = mask $ \restore -> do beginMode mode conn @@ -153,7 +154,7 @@ withTransactionMode mode conn act = -- 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 :: (HasCallStack) => TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a withTransactionModeRetry mode shouldRetry conn act = mask $ \restore -> retryLoop $ E.try $ do @@ -161,7 +162,7 @@ withTransactionModeRetry mode shouldRetry conn act = commit conn return a where - retryLoop :: IO (Either E.SomeException a) -> IO a + retryLoop :: (HasCallStack) => IO (Either E.SomeException a) -> IO a retryLoop act' = do beginMode mode conn r <- act' @@ -175,27 +176,27 @@ withTransactionModeRetry mode shouldRetry conn act = return a -- | Rollback a transaction. -rollback :: Connection -> IO () +rollback :: (HasCallStack) => Connection -> IO () rollback conn = execute_ conn "ABORT" >> return () -- | Rollback a transaction, ignoring any @IOErrors@ -rollback_ :: Connection -> IO () +rollback_ :: (HasCallStack) => Connection -> IO () rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return () -- | Commit a transaction. -commit :: Connection -> IO () +commit :: (HasCallStack) => Connection -> IO () commit conn = execute_ conn "COMMIT" >> return () -- | Begin a transaction. -begin :: Connection -> IO () +begin :: (HasCallStack) => Connection -> IO () begin = beginMode defaultTransactionMode -- | Begin a transaction with a given isolation level -beginLevel :: IsolationLevel -> Connection -> IO () +beginLevel :: (HasCallStack) => IsolationLevel -> Connection -> IO () beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } -- | Begin a transaction with a given transaction mode -beginMode :: TransactionMode -> Connection -> IO () +beginMode :: (HasCallStack) => TransactionMode -> Connection -> IO () beginMode mode conn = do _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) return () @@ -218,7 +219,7 @@ beginMode mode conn = do -- \"nested transaction\". -- -- See -withSavepoint :: Connection -> IO a -> IO a +withSavepoint :: (HasCallStack) => Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do sp <- newSavepoint conn @@ -230,7 +231,7 @@ withSavepoint conn body = return r -- | Create a new savepoint. This may only be used inside of a transaction. -newSavepoint :: Connection -> IO Savepoint +newSavepoint :: (HasCallStack) => Connection -> IO Savepoint newSavepoint conn = do name <- newTempName conn _ <- execute_ conn ("SAVEPOINT " <> name) @@ -241,19 +242,19 @@ newSavepoint conn = do -- 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 :: (HasCallStack) => 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 :: (HasCallStack) => 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 :: (HasCallStack) => Connection -> Savepoint -> IO () rollbackToAndReleaseSavepoint conn (Savepoint name) = execute_ conn sql >> return () where diff --git a/src/Database/PostgreSQL/Simple/TypeInfo.hs b/src/Database/PostgreSQL/Simple/TypeInfo.hs index 641a09b5..71dc8c21 100644 --- a/src/Database/PostgreSQL/Simple/TypeInfo.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo.hs @@ -41,6 +41,7 @@ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo.Types import Database.PostgreSQL.Simple.TypeInfo.Static +import GHC.Stack -- | Returns the metadata of the type with a particular oid. To find -- this data, 'getTypeInfo' first consults postgresql-simple's @@ -49,13 +50,13 @@ import Database.PostgreSQL.Simple.TypeInfo.Static -- be queried only if necessary, and the result will be stored -- in the connections's cache. -getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo +getTypeInfo :: (HasCallStack) => 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 +getTypeInfo' :: (HasCallStack) => Connection -> PQ.Oid -> TypeInfoCache -> IO (TypeInfoCache, TypeInfo) getTypeInfo' conn oid oidmap = case IntMap.lookup (oid2int oid) oidmap of @@ -107,7 +108,7 @@ getTypeInfo' conn oid oidmap = let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap' return $! (oidmap'', typeInfo) -getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache +getAttInfos :: (HasCallStack) => Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache -> MV.IOVector Attribute -> Int -> IO (TypeInfoCache, V.Vector Attribute) getAttInfos conn cols oidmap vec n = diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs index e7ca250f..5348a005 100644 --- a/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs @@ -21,27 +21,28 @@ module Database.PostgreSQL.Simple.TypeInfo.Macro import Database.PostgreSQL.Simple.TypeInfo.Static import Database.PostgreSQL.Simple.Types (Oid(..)) import Language.Haskell.TH +import GHC.Stack -- | 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 :: (HasCallStack) => [TypeInfo] -> ExpQ mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |] where - alt :: TypeInfo -> MatchQ + alt :: (HasCallStack) => TypeInfo -> MatchQ alt ty = match (inlineTypoidP ty) (normalB [| True |]) [] - catchAll :: MatchQ + catchAll :: (HasCallStack) => 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 :: (HasCallStack) => TypeInfo -> ExpQ inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |] -inlineTypoidP :: TypeInfo -> PatQ +inlineTypoidP :: (HasCallStack) => TypeInfo -> PatQ inlineTypoidP ty = litP (getTypoid ty) -getTypoid :: TypeInfo -> Lit +getTypoid :: (HasCallStack) => TypeInfo -> Lit getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs index 8db176b3..83735a07 100644 --- a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs @@ -136,8 +136,9 @@ module Database.PostgreSQL.Simple.TypeInfo.Static import Database.PostgreSQL.LibPQ (Oid(..)) import Database.PostgreSQL.Simple.TypeInfo.Types +import GHC.Stack -staticTypeInfo :: Oid -> Maybe TypeInfo +staticTypeInfo :: (HasCallStack) => Oid -> Maybe TypeInfo staticTypeInfo (Oid x) = case x of 16 -> Just bool 17 -> Just bytea @@ -255,7 +256,7 @@ staticTypeInfo (Oid x) = case x of 3927 -> Just _int8range _ -> Nothing -bool :: TypeInfo +bool :: (HasCallStack) => TypeInfo bool = Basic { typoid = Oid 16, typcategory = 'B', @@ -263,7 +264,7 @@ bool = Basic { typname = "bool" } -bytea :: TypeInfo +bytea :: (HasCallStack) => TypeInfo bytea = Basic { typoid = Oid 17, typcategory = 'U', @@ -271,7 +272,7 @@ bytea = Basic { typname = "bytea" } -char :: TypeInfo +char :: (HasCallStack) => TypeInfo char = Basic { typoid = Oid 18, typcategory = 'S', @@ -279,7 +280,7 @@ char = Basic { typname = "char" } -name :: TypeInfo +name :: (HasCallStack) => TypeInfo name = Basic { typoid = Oid 19, typcategory = 'S', @@ -287,7 +288,7 @@ name = Basic { typname = "name" } -int8 :: TypeInfo +int8 :: (HasCallStack) => TypeInfo int8 = Basic { typoid = Oid 20, typcategory = 'N', @@ -295,7 +296,7 @@ int8 = Basic { typname = "int8" } -int2 :: TypeInfo +int2 :: (HasCallStack) => TypeInfo int2 = Basic { typoid = Oid 21, typcategory = 'N', @@ -303,7 +304,7 @@ int2 = Basic { typname = "int2" } -int4 :: TypeInfo +int4 :: (HasCallStack) => TypeInfo int4 = Basic { typoid = Oid 23, typcategory = 'N', @@ -311,7 +312,7 @@ int4 = Basic { typname = "int4" } -regproc :: TypeInfo +regproc :: (HasCallStack) => TypeInfo regproc = Basic { typoid = Oid 24, typcategory = 'N', @@ -319,7 +320,7 @@ regproc = Basic { typname = "regproc" } -text :: TypeInfo +text :: (HasCallStack) => TypeInfo text = Basic { typoid = Oid 25, typcategory = 'S', @@ -327,7 +328,7 @@ text = Basic { typname = "text" } -oid :: TypeInfo +oid :: (HasCallStack) => TypeInfo oid = Basic { typoid = Oid 26, typcategory = 'N', @@ -335,7 +336,7 @@ oid = Basic { typname = "oid" } -tid :: TypeInfo +tid :: (HasCallStack) => TypeInfo tid = Basic { typoid = Oid 27, typcategory = 'U', @@ -343,7 +344,7 @@ tid = Basic { typname = "tid" } -xid :: TypeInfo +xid :: (HasCallStack) => TypeInfo xid = Basic { typoid = Oid 28, typcategory = 'U', @@ -351,7 +352,7 @@ xid = Basic { typname = "xid" } -cid :: TypeInfo +cid :: (HasCallStack) => TypeInfo cid = Basic { typoid = Oid 29, typcategory = 'U', @@ -359,7 +360,7 @@ cid = Basic { typname = "cid" } -xml :: TypeInfo +xml :: (HasCallStack) => TypeInfo xml = Basic { typoid = Oid 142, typcategory = 'U', @@ -367,7 +368,7 @@ xml = Basic { typname = "xml" } -point :: TypeInfo +point :: (HasCallStack) => TypeInfo point = Basic { typoid = Oid 600, typcategory = 'G', @@ -375,7 +376,7 @@ point = Basic { typname = "point" } -lseg :: TypeInfo +lseg :: (HasCallStack) => TypeInfo lseg = Basic { typoid = Oid 601, typcategory = 'G', @@ -383,7 +384,7 @@ lseg = Basic { typname = "lseg" } -path :: TypeInfo +path :: (HasCallStack) => TypeInfo path = Basic { typoid = Oid 602, typcategory = 'G', @@ -391,7 +392,7 @@ path = Basic { typname = "path" } -box :: TypeInfo +box :: (HasCallStack) => TypeInfo box = Basic { typoid = Oid 603, typcategory = 'G', @@ -399,7 +400,7 @@ box = Basic { typname = "box" } -polygon :: TypeInfo +polygon :: (HasCallStack) => TypeInfo polygon = Basic { typoid = Oid 604, typcategory = 'G', @@ -407,7 +408,7 @@ polygon = Basic { typname = "polygon" } -line :: TypeInfo +line :: (HasCallStack) => TypeInfo line = Basic { typoid = Oid 628, typcategory = 'G', @@ -415,7 +416,7 @@ line = Basic { typname = "line" } -cidr :: TypeInfo +cidr :: (HasCallStack) => TypeInfo cidr = Basic { typoid = Oid 650, typcategory = 'I', @@ -423,7 +424,7 @@ cidr = Basic { typname = "cidr" } -float4 :: TypeInfo +float4 :: (HasCallStack) => TypeInfo float4 = Basic { typoid = Oid 700, typcategory = 'N', @@ -431,7 +432,7 @@ float4 = Basic { typname = "float4" } -float8 :: TypeInfo +float8 :: (HasCallStack) => TypeInfo float8 = Basic { typoid = Oid 701, typcategory = 'N', @@ -439,7 +440,7 @@ float8 = Basic { typname = "float8" } -unknown :: TypeInfo +unknown :: (HasCallStack) => TypeInfo unknown = Basic { typoid = Oid 705, typcategory = 'X', @@ -447,7 +448,7 @@ unknown = Basic { typname = "unknown" } -circle :: TypeInfo +circle :: (HasCallStack) => TypeInfo circle = Basic { typoid = Oid 718, typcategory = 'G', @@ -455,7 +456,7 @@ circle = Basic { typname = "circle" } -money :: TypeInfo +money :: (HasCallStack) => TypeInfo money = Basic { typoid = Oid 790, typcategory = 'N', @@ -463,7 +464,7 @@ money = Basic { typname = "money" } -macaddr :: TypeInfo +macaddr :: (HasCallStack) => TypeInfo macaddr = Basic { typoid = Oid 829, typcategory = 'U', @@ -471,7 +472,7 @@ macaddr = Basic { typname = "macaddr" } -inet :: TypeInfo +inet :: (HasCallStack) => TypeInfo inet = Basic { typoid = Oid 869, typcategory = 'I', @@ -479,7 +480,7 @@ inet = Basic { typname = "inet" } -bpchar :: TypeInfo +bpchar :: (HasCallStack) => TypeInfo bpchar = Basic { typoid = Oid 1042, typcategory = 'S', @@ -487,7 +488,7 @@ bpchar = Basic { typname = "bpchar" } -varchar :: TypeInfo +varchar :: (HasCallStack) => TypeInfo varchar = Basic { typoid = Oid 1043, typcategory = 'S', @@ -495,7 +496,7 @@ varchar = Basic { typname = "varchar" } -date :: TypeInfo +date :: (HasCallStack) => TypeInfo date = Basic { typoid = Oid 1082, typcategory = 'D', @@ -503,7 +504,7 @@ date = Basic { typname = "date" } -time :: TypeInfo +time :: (HasCallStack) => TypeInfo time = Basic { typoid = Oid 1083, typcategory = 'D', @@ -511,7 +512,7 @@ time = Basic { typname = "time" } -timestamp :: TypeInfo +timestamp :: (HasCallStack) => TypeInfo timestamp = Basic { typoid = Oid 1114, typcategory = 'D', @@ -519,7 +520,7 @@ timestamp = Basic { typname = "timestamp" } -timestamptz :: TypeInfo +timestamptz :: (HasCallStack) => TypeInfo timestamptz = Basic { typoid = Oid 1184, typcategory = 'D', @@ -527,7 +528,7 @@ timestamptz = Basic { typname = "timestamptz" } -interval :: TypeInfo +interval :: (HasCallStack) => TypeInfo interval = Basic { typoid = Oid 1186, typcategory = 'T', @@ -535,7 +536,7 @@ interval = Basic { typname = "interval" } -timetz :: TypeInfo +timetz :: (HasCallStack) => TypeInfo timetz = Basic { typoid = Oid 1266, typcategory = 'D', @@ -543,7 +544,7 @@ timetz = Basic { typname = "timetz" } -bit :: TypeInfo +bit :: (HasCallStack) => TypeInfo bit = Basic { typoid = Oid 1560, typcategory = 'V', @@ -551,7 +552,7 @@ bit = Basic { typname = "bit" } -varbit :: TypeInfo +varbit :: (HasCallStack) => TypeInfo varbit = Basic { typoid = Oid 1562, typcategory = 'V', @@ -559,7 +560,7 @@ varbit = Basic { typname = "varbit" } -numeric :: TypeInfo +numeric :: (HasCallStack) => TypeInfo numeric = Basic { typoid = Oid 1700, typcategory = 'N', @@ -567,7 +568,7 @@ numeric = Basic { typname = "numeric" } -refcursor :: TypeInfo +refcursor :: (HasCallStack) => TypeInfo refcursor = Basic { typoid = Oid 1790, typcategory = 'U', @@ -575,7 +576,7 @@ refcursor = Basic { typname = "refcursor" } -record :: TypeInfo +record :: (HasCallStack) => TypeInfo record = Basic { typoid = Oid 2249, typcategory = 'P', @@ -583,7 +584,7 @@ record = Basic { typname = "record" } -void :: TypeInfo +void :: (HasCallStack) => TypeInfo void = Basic { typoid = Oid 2278, typcategory = 'P', @@ -591,7 +592,7 @@ void = Basic { typname = "void" } -array_record :: TypeInfo +array_record :: (HasCallStack) => TypeInfo array_record = Array { typoid = Oid 2287, typcategory = 'P', @@ -600,7 +601,7 @@ array_record = Array { typelem = record } -regprocedure :: TypeInfo +regprocedure :: (HasCallStack) => TypeInfo regprocedure = Basic { typoid = Oid 2202, typcategory = 'N', @@ -608,7 +609,7 @@ regprocedure = Basic { typname = "regprocedure" } -regoper :: TypeInfo +regoper :: (HasCallStack) => TypeInfo regoper = Basic { typoid = Oid 2203, typcategory = 'N', @@ -616,7 +617,7 @@ regoper = Basic { typname = "regoper" } -regoperator :: TypeInfo +regoperator :: (HasCallStack) => TypeInfo regoperator = Basic { typoid = Oid 2204, typcategory = 'N', @@ -624,7 +625,7 @@ regoperator = Basic { typname = "regoperator" } -regclass :: TypeInfo +regclass :: (HasCallStack) => TypeInfo regclass = Basic { typoid = Oid 2205, typcategory = 'N', @@ -632,7 +633,7 @@ regclass = Basic { typname = "regclass" } -regtype :: TypeInfo +regtype :: (HasCallStack) => TypeInfo regtype = Basic { typoid = Oid 2206, typcategory = 'N', @@ -640,7 +641,7 @@ regtype = Basic { typname = "regtype" } -uuid :: TypeInfo +uuid :: (HasCallStack) => TypeInfo uuid = Basic { typoid = Oid 2950, typcategory = 'U', @@ -648,7 +649,7 @@ uuid = Basic { typname = "uuid" } -json :: TypeInfo +json :: (HasCallStack) => TypeInfo json = Basic { typoid = Oid 114, typcategory = 'U', @@ -656,7 +657,7 @@ json = Basic { typname = "json" } -jsonb :: TypeInfo +jsonb :: (HasCallStack) => TypeInfo jsonb = Basic { typoid = Oid 3802, typcategory = 'U', @@ -664,7 +665,7 @@ jsonb = Basic { typname = "jsonb" } -int2vector :: TypeInfo +int2vector :: (HasCallStack) => TypeInfo int2vector = Array { typoid = Oid 22, typcategory = 'A', @@ -673,7 +674,7 @@ int2vector = Array { typelem = int2 } -oidvector :: TypeInfo +oidvector :: (HasCallStack) => TypeInfo oidvector = Array { typoid = Oid 30, typcategory = 'A', @@ -682,7 +683,7 @@ oidvector = Array { typelem = oid } -array_xml :: TypeInfo +array_xml :: (HasCallStack) => TypeInfo array_xml = Array { typoid = Oid 143, typcategory = 'A', @@ -691,7 +692,7 @@ array_xml = Array { typelem = xml } -array_json :: TypeInfo +array_json :: (HasCallStack) => TypeInfo array_json = Array { typoid = Oid 199, typcategory = 'A', @@ -700,7 +701,7 @@ array_json = Array { typelem = json } -array_line :: TypeInfo +array_line :: (HasCallStack) => TypeInfo array_line = Array { typoid = Oid 629, typcategory = 'A', @@ -709,7 +710,7 @@ array_line = Array { typelem = line } -array_cidr :: TypeInfo +array_cidr :: (HasCallStack) => TypeInfo array_cidr = Array { typoid = Oid 651, typcategory = 'A', @@ -718,7 +719,7 @@ array_cidr = Array { typelem = cidr } -array_circle :: TypeInfo +array_circle :: (HasCallStack) => TypeInfo array_circle = Array { typoid = Oid 719, typcategory = 'A', @@ -727,7 +728,7 @@ array_circle = Array { typelem = circle } -array_money :: TypeInfo +array_money :: (HasCallStack) => TypeInfo array_money = Array { typoid = Oid 791, typcategory = 'A', @@ -736,7 +737,7 @@ array_money = Array { typelem = money } -array_bool :: TypeInfo +array_bool :: (HasCallStack) => TypeInfo array_bool = Array { typoid = Oid 1000, typcategory = 'A', @@ -745,7 +746,7 @@ array_bool = Array { typelem = bool } -array_bytea :: TypeInfo +array_bytea :: (HasCallStack) => TypeInfo array_bytea = Array { typoid = Oid 1001, typcategory = 'A', @@ -754,7 +755,7 @@ array_bytea = Array { typelem = bytea } -array_char :: TypeInfo +array_char :: (HasCallStack) => TypeInfo array_char = Array { typoid = Oid 1002, typcategory = 'A', @@ -763,7 +764,7 @@ array_char = Array { typelem = char } -array_name :: TypeInfo +array_name :: (HasCallStack) => TypeInfo array_name = Array { typoid = Oid 1003, typcategory = 'A', @@ -772,7 +773,7 @@ array_name = Array { typelem = name } -array_int2 :: TypeInfo +array_int2 :: (HasCallStack) => TypeInfo array_int2 = Array { typoid = Oid 1005, typcategory = 'A', @@ -781,7 +782,7 @@ array_int2 = Array { typelem = int2 } -array_int2vector :: TypeInfo +array_int2vector :: (HasCallStack) => TypeInfo array_int2vector = Array { typoid = Oid 1006, typcategory = 'A', @@ -790,7 +791,7 @@ array_int2vector = Array { typelem = int2vector } -array_int4 :: TypeInfo +array_int4 :: (HasCallStack) => TypeInfo array_int4 = Array { typoid = Oid 1007, typcategory = 'A', @@ -799,7 +800,7 @@ array_int4 = Array { typelem = int4 } -array_regproc :: TypeInfo +array_regproc :: (HasCallStack) => TypeInfo array_regproc = Array { typoid = Oid 1008, typcategory = 'A', @@ -808,7 +809,7 @@ array_regproc = Array { typelem = regproc } -array_text :: TypeInfo +array_text :: (HasCallStack) => TypeInfo array_text = Array { typoid = Oid 1009, typcategory = 'A', @@ -817,7 +818,7 @@ array_text = Array { typelem = text } -array_tid :: TypeInfo +array_tid :: (HasCallStack) => TypeInfo array_tid = Array { typoid = Oid 1010, typcategory = 'A', @@ -826,7 +827,7 @@ array_tid = Array { typelem = tid } -array_xid :: TypeInfo +array_xid :: (HasCallStack) => TypeInfo array_xid = Array { typoid = Oid 1011, typcategory = 'A', @@ -835,7 +836,7 @@ array_xid = Array { typelem = xid } -array_cid :: TypeInfo +array_cid :: (HasCallStack) => TypeInfo array_cid = Array { typoid = Oid 1012, typcategory = 'A', @@ -844,7 +845,7 @@ array_cid = Array { typelem = cid } -array_oidvector :: TypeInfo +array_oidvector :: (HasCallStack) => TypeInfo array_oidvector = Array { typoid = Oid 1013, typcategory = 'A', @@ -853,7 +854,7 @@ array_oidvector = Array { typelem = oidvector } -array_bpchar :: TypeInfo +array_bpchar :: (HasCallStack) => TypeInfo array_bpchar = Array { typoid = Oid 1014, typcategory = 'A', @@ -862,7 +863,7 @@ array_bpchar = Array { typelem = bpchar } -array_varchar :: TypeInfo +array_varchar :: (HasCallStack) => TypeInfo array_varchar = Array { typoid = Oid 1015, typcategory = 'A', @@ -871,7 +872,7 @@ array_varchar = Array { typelem = varchar } -array_int8 :: TypeInfo +array_int8 :: (HasCallStack) => TypeInfo array_int8 = Array { typoid = Oid 1016, typcategory = 'A', @@ -880,7 +881,7 @@ array_int8 = Array { typelem = int8 } -array_point :: TypeInfo +array_point :: (HasCallStack) => TypeInfo array_point = Array { typoid = Oid 1017, typcategory = 'A', @@ -889,7 +890,7 @@ array_point = Array { typelem = point } -array_lseg :: TypeInfo +array_lseg :: (HasCallStack) => TypeInfo array_lseg = Array { typoid = Oid 1018, typcategory = 'A', @@ -898,7 +899,7 @@ array_lseg = Array { typelem = lseg } -array_path :: TypeInfo +array_path :: (HasCallStack) => TypeInfo array_path = Array { typoid = Oid 1019, typcategory = 'A', @@ -907,7 +908,7 @@ array_path = Array { typelem = path } -array_box :: TypeInfo +array_box :: (HasCallStack) => TypeInfo array_box = Array { typoid = Oid 1020, typcategory = 'A', @@ -916,7 +917,7 @@ array_box = Array { typelem = box } -array_float4 :: TypeInfo +array_float4 :: (HasCallStack) => TypeInfo array_float4 = Array { typoid = Oid 1021, typcategory = 'A', @@ -925,7 +926,7 @@ array_float4 = Array { typelem = float4 } -array_float8 :: TypeInfo +array_float8 :: (HasCallStack) => TypeInfo array_float8 = Array { typoid = Oid 1022, typcategory = 'A', @@ -934,7 +935,7 @@ array_float8 = Array { typelem = float8 } -array_polygon :: TypeInfo +array_polygon :: (HasCallStack) => TypeInfo array_polygon = Array { typoid = Oid 1027, typcategory = 'A', @@ -943,7 +944,7 @@ array_polygon = Array { typelem = polygon } -array_oid :: TypeInfo +array_oid :: (HasCallStack) => TypeInfo array_oid = Array { typoid = Oid 1028, typcategory = 'A', @@ -952,7 +953,7 @@ array_oid = Array { typelem = oid } -array_macaddr :: TypeInfo +array_macaddr :: (HasCallStack) => TypeInfo array_macaddr = Array { typoid = Oid 1040, typcategory = 'A', @@ -961,7 +962,7 @@ array_macaddr = Array { typelem = macaddr } -array_inet :: TypeInfo +array_inet :: (HasCallStack) => TypeInfo array_inet = Array { typoid = Oid 1041, typcategory = 'A', @@ -970,7 +971,7 @@ array_inet = Array { typelem = inet } -array_timestamp :: TypeInfo +array_timestamp :: (HasCallStack) => TypeInfo array_timestamp = Array { typoid = Oid 1115, typcategory = 'A', @@ -979,7 +980,7 @@ array_timestamp = Array { typelem = timestamp } -array_date :: TypeInfo +array_date :: (HasCallStack) => TypeInfo array_date = Array { typoid = Oid 1182, typcategory = 'A', @@ -988,7 +989,7 @@ array_date = Array { typelem = date } -array_time :: TypeInfo +array_time :: (HasCallStack) => TypeInfo array_time = Array { typoid = Oid 1183, typcategory = 'A', @@ -997,7 +998,7 @@ array_time = Array { typelem = time } -array_timestamptz :: TypeInfo +array_timestamptz :: (HasCallStack) => TypeInfo array_timestamptz = Array { typoid = Oid 1185, typcategory = 'A', @@ -1006,7 +1007,7 @@ array_timestamptz = Array { typelem = timestamptz } -array_interval :: TypeInfo +array_interval :: (HasCallStack) => TypeInfo array_interval = Array { typoid = Oid 1187, typcategory = 'A', @@ -1015,7 +1016,7 @@ array_interval = Array { typelem = interval } -array_numeric :: TypeInfo +array_numeric :: (HasCallStack) => TypeInfo array_numeric = Array { typoid = Oid 1231, typcategory = 'A', @@ -1024,7 +1025,7 @@ array_numeric = Array { typelem = numeric } -array_timetz :: TypeInfo +array_timetz :: (HasCallStack) => TypeInfo array_timetz = Array { typoid = Oid 1270, typcategory = 'A', @@ -1033,7 +1034,7 @@ array_timetz = Array { typelem = timetz } -array_bit :: TypeInfo +array_bit :: (HasCallStack) => TypeInfo array_bit = Array { typoid = Oid 1561, typcategory = 'A', @@ -1042,7 +1043,7 @@ array_bit = Array { typelem = bit } -array_varbit :: TypeInfo +array_varbit :: (HasCallStack) => TypeInfo array_varbit = Array { typoid = Oid 1563, typcategory = 'A', @@ -1051,7 +1052,7 @@ array_varbit = Array { typelem = varbit } -array_refcursor :: TypeInfo +array_refcursor :: (HasCallStack) => TypeInfo array_refcursor = Array { typoid = Oid 2201, typcategory = 'A', @@ -1060,7 +1061,7 @@ array_refcursor = Array { typelem = refcursor } -array_regprocedure :: TypeInfo +array_regprocedure :: (HasCallStack) => TypeInfo array_regprocedure = Array { typoid = Oid 2207, typcategory = 'A', @@ -1069,7 +1070,7 @@ array_regprocedure = Array { typelem = regprocedure } -array_regoper :: TypeInfo +array_regoper :: (HasCallStack) => TypeInfo array_regoper = Array { typoid = Oid 2208, typcategory = 'A', @@ -1078,7 +1079,7 @@ array_regoper = Array { typelem = regoper } -array_regoperator :: TypeInfo +array_regoperator :: (HasCallStack) => TypeInfo array_regoperator = Array { typoid = Oid 2209, typcategory = 'A', @@ -1087,7 +1088,7 @@ array_regoperator = Array { typelem = regoperator } -array_regclass :: TypeInfo +array_regclass :: (HasCallStack) => TypeInfo array_regclass = Array { typoid = Oid 2210, typcategory = 'A', @@ -1096,7 +1097,7 @@ array_regclass = Array { typelem = regclass } -array_regtype :: TypeInfo +array_regtype :: (HasCallStack) => TypeInfo array_regtype = Array { typoid = Oid 2211, typcategory = 'A', @@ -1105,7 +1106,7 @@ array_regtype = Array { typelem = regtype } -array_uuid :: TypeInfo +array_uuid :: (HasCallStack) => TypeInfo array_uuid = Array { typoid = Oid 2951, typcategory = 'A', @@ -1114,7 +1115,7 @@ array_uuid = Array { typelem = uuid } -array_jsonb :: TypeInfo +array_jsonb :: (HasCallStack) => TypeInfo array_jsonb = Array { typoid = Oid 3807, typcategory = 'A', @@ -1123,7 +1124,7 @@ array_jsonb = Array { typelem = jsonb } -int4range :: TypeInfo +int4range :: (HasCallStack) => TypeInfo int4range = Range { typoid = Oid 3904, typcategory = 'R', @@ -1132,7 +1133,7 @@ int4range = Range { rngsubtype = int4 } -_int4range :: TypeInfo +_int4range :: (HasCallStack) => TypeInfo _int4range = Array { typoid = Oid 3905, typcategory = 'A', @@ -1141,7 +1142,7 @@ _int4range = Array { typelem = int4range } -numrange :: TypeInfo +numrange :: (HasCallStack) => TypeInfo numrange = Range { typoid = Oid 3906, typcategory = 'R', @@ -1150,7 +1151,7 @@ numrange = Range { rngsubtype = numeric } -_numrange :: TypeInfo +_numrange :: (HasCallStack) => TypeInfo _numrange = Array { typoid = Oid 3907, typcategory = 'A', @@ -1159,7 +1160,7 @@ _numrange = Array { typelem = numrange } -tsrange :: TypeInfo +tsrange :: (HasCallStack) => TypeInfo tsrange = Range { typoid = Oid 3908, typcategory = 'R', @@ -1168,7 +1169,7 @@ tsrange = Range { rngsubtype = timestamp } -_tsrange :: TypeInfo +_tsrange :: (HasCallStack) => TypeInfo _tsrange = Array { typoid = Oid 3909, typcategory = 'A', @@ -1177,7 +1178,7 @@ _tsrange = Array { typelem = tsrange } -tstzrange :: TypeInfo +tstzrange :: (HasCallStack) => TypeInfo tstzrange = Range { typoid = Oid 3910, typcategory = 'R', @@ -1186,7 +1187,7 @@ tstzrange = Range { rngsubtype = timestamptz } -_tstzrange :: TypeInfo +_tstzrange :: (HasCallStack) => TypeInfo _tstzrange = Array { typoid = Oid 3911, typcategory = 'A', @@ -1195,7 +1196,7 @@ _tstzrange = Array { typelem = tstzrange } -daterange :: TypeInfo +daterange :: (HasCallStack) => TypeInfo daterange = Range { typoid = Oid 3912, typcategory = 'R', @@ -1204,7 +1205,7 @@ daterange = Range { rngsubtype = date } -_daterange :: TypeInfo +_daterange :: (HasCallStack) => TypeInfo _daterange = Array { typoid = Oid 3913, typcategory = 'A', @@ -1213,7 +1214,7 @@ _daterange = Array { typelem = daterange } -int8range :: TypeInfo +int8range :: (HasCallStack) => TypeInfo int8range = Range { typoid = Oid 3926, typcategory = 'R', @@ -1222,7 +1223,7 @@ int8range = Range { rngsubtype = int8 } -_int8range :: TypeInfo +_int8range :: (HasCallStack) => TypeInfo _int8range = Array { typoid = Oid 3927, typcategory = 'A', diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 00000000..6e5a13e6 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-9.12 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Main.hs b/test/Main.hs index d71a9d0a..2fbc535c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -50,6 +50,7 @@ tests env = testGroup "tests" , testCase "Array" . testArray , testCase "Array of nullables" . testNullableArray , testCase "HStore" . testHStore + , testCase "HStore with nulls" . testHStoreWithNulls , testCase "JSON" . testJSON , testCase "Savepoint" . testSavepoint , testCase "Unicode" . testUnicode @@ -203,6 +204,12 @@ testHStore TestEnv{..} = do m' <- query conn "SELECT ?::hstore" m [m] @?= m' +testHStoreWithNulls :: TestEnv -> Assertion +testHStoreWithNulls TestEnv{..} = do + execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore" + res <- query_ conn "SELECT '\"foo\" => \"bar\", \"fooNull\" => NULL, \"fooNull2\" => null' :: hstore" + res @?= [Only $ HStoreMap $ Map.fromList [("foo", "bar")]] + testJSON :: TestEnv -> Assertion testJSON TestEnv{..} = do roundTrip (Map.fromList [] :: Map Text Text) @@ -469,6 +476,7 @@ isSyntaxError SqlError{..} = sqlState == "42601" -- 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 "host=localhost port=5432 user=pgsimple password=pgsimple" testConnect = connectPostgreSQL "" withTestEnv :: (TestEnv -> IO a) -> IO a