git.iko.soy/squeal
on dev help sign in
0.4 exceptions
420c457Eitan Chatav
squeal-postgresql/squeal-postgresql.cabal+1
compare with dev
unifiedsplit
@@ -76,6 +76,7 @@ test-suite squeal-postgresql-specs
76 hs-source-dirs: test/Specs
76 hs-source-dirs: test/Specs
77 ghc-options: -Wall -main-is Specs
77 ghc-options: -Wall -main-is Specs
78 main-is: Specs.hs
78 main-is: Specs.hs
79+ other-modules: ExceptionHandling
79 build-depends:
80 build-depends:
80 base >= 4.10.0.0
81 base >= 4.10.0.0
81 , bytestring >= 0.10.8.2
82 , bytestring >= 0.10.8.2
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+46−19
@@ -62,6 +62,8 @@ module Squeal.PostgreSQL.PQ
62 , LibPQ.ExecStatus (..)
62 , LibPQ.ExecStatus (..)
63 , resultStatus
63 , resultStatus
64 , resultErrorMessage
64 , resultErrorMessage
65+ , resultErrorCode
66+ , SquealException (..)
65 ) where
67 ) where
66
68
67import Control.Exception.Lifted
69import Control.Exception.Lifted
@@ -400,7 +402,9 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
400 case resultMaybe of
402 case resultMaybe of
401 Nothing -> error
403 Nothing -> error
402 "manipulateParams: LibPQ.execParams returned no results"
404 "manipulateParams: LibPQ.execParams returned no results"
405+ Just result -> do
406+ tryResult result
403− Just result -> return $ K (K result)
407+ return $ K (K result)
404
408
405 traversePrepared
409 traversePrepared
406 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
410 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
@@ -410,10 +414,7 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
410 case prepResultMaybe of
414 case prepResultMaybe of
411 Nothing -> error
415 Nothing -> error
412 "traversePrepared: LibPQ.prepare returned no results"
416 "traversePrepared: LibPQ.prepare returned no results"
413− Just prepResult -> do
417+ Just prepResult -> tryResult prepResult
414− status <- LibPQ.resultStatus prepResult
415− unless (status == LibPQ.CommandOk) . error $
416− "traversePrepared: LibPQ.prepare status " <> show status
417 results <- for list $ \ params -> do
418 results <- for list $ \ params -> do
418 let
419 let
419 toParam' bytes = (bytes,LibPQ.Binary)
420 toParam' bytes = (bytes,LibPQ.Binary)
@@ -422,15 +423,14 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
422 case resultMaybe of
423 case resultMaybe of
423 Nothing -> error
424 Nothing -> error
424 "traversePrepared: LibPQ.execParams returned no results"
425 "traversePrepared: LibPQ.execParams returned no results"
426+ Just result -> do
427+ tryResult result
425− Just result -> return $ K result
428+ return $ K result
426 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
429 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
427 case deallocResultMaybe of
430 case deallocResultMaybe of
428 Nothing -> error
431 Nothing -> error
429 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
432 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
430− Just deallocResult -> do
433+ Just deallocResult -> tryResult deallocResult
431− status <- LibPQ.resultStatus deallocResult
432− unless (status == LibPQ.CommandOk) . error $
433− "traversePrepared: DEALLOCATE status " <> show status
434 return (K results)
434 return (K results)
435
435
436 traversePrepared_
436 traversePrepared_
@@ -441,10 +441,7 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
441 case prepResultMaybe of
441 case prepResultMaybe of
442 Nothing -> error
442 Nothing -> error
443 "traversePrepared_: LibPQ.prepare returned no results"
443 "traversePrepared_: LibPQ.prepare returned no results"
444− Just prepResult -> do
444+ Just prepResult -> tryResult prepResult
445− status <- LibPQ.resultStatus prepResult
446− unless (status == LibPQ.CommandOk) . error $
447− "traversePrepared: LibPQ.prepare status " <> show status
448 for_ list $ \ params -> do
445 for_ list $ \ params -> do
449 let
446 let
450 toParam' bytes = (bytes,LibPQ.Binary)
447 toParam' bytes = (bytes,LibPQ.Binary)
@@ -453,15 +450,12 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
453 case resultMaybe of
450 case resultMaybe of
454 Nothing -> error
451 Nothing -> error
455 "traversePrepared_: LibPQ.execParams returned no results"
452 "traversePrepared_: LibPQ.execParams returned no results"
456− Just _result -> return ()
453+ Just result -> tryResult result
457 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
454 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
458 case deallocResultMaybe of
455 case deallocResultMaybe of
459 Nothing -> error
456 Nothing -> error
460 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
457 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
461− Just deallocResult -> do
458+ Just deallocResult -> tryResult deallocResult
462− status <- LibPQ.resultStatus deallocResult
463− unless (status == LibPQ.CommandOk) . error $
464− "traversePrepared: DEALLOCATE status " <> show status
465 return (K ())
459 return (K ())
466
460
467 liftPQ pq = PQ $ \ (K conn) -> do
461 liftPQ pq = PQ $ \ (K conn) -> do
@@ -609,3 +603,36 @@ resultStatus = liftResult LibPQ.resultStatus
609resultErrorMessage
603resultErrorMessage
610 :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
604 :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
611resultErrorMessage = liftResult LibPQ.resultErrorMessage
605resultErrorMessage = liftResult LibPQ.resultErrorMessage
606+
607+-- | Returns the error code most recently generated by an operation
608+-- on the connection.
609+--
610+-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
611+resultErrorCode
612+ :: MonadBase IO io
613+ => K LibPQ.Result results
614+ -> io (Maybe ByteString)
615+resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
616+
617+data SquealException
618+ = SquealException
619+ { sqlExecStatus :: LibPQ.ExecStatus
620+ , sqlStateCode :: Maybe ByteString
621+ -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
622+ , sqlErrorMessage :: Maybe ByteString
623+ } deriving (Eq, Show)
624+instance Exception SquealException
625+
626+tryResult
627+ :: MonadBase IO io
628+ => LibPQ.Result
629+ -> io ()
630+tryResult result = liftBase $ do
631+ status <- LibPQ.resultStatus result
632+ case status of
633+ LibPQ.CommandOk -> return ()
634+ LibPQ.TuplesOk -> return ()
635+ _ -> do
636+ stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
637+ msg <- LibPQ.resultErrorMessage result
638+ throw $ SquealException status stateCode msg
squeal-postgresql/test/Specs/ExceptionHandling.hs+3−3
@@ -86,7 +86,7 @@ migration = Migration { name = "test"
86
86
87setupDB :: IO ()
87setupDB :: IO ()
88setupDB = void . withConnection connectionString $
88setupDB = void . withConnection connectionString $
89− manipulate (UnsafeManipulation "SET client_min_messages = error;")
89+ manipulate (UnsafeManipulation "SET client_min_messages = warning;")
90 & pqThen $ migrateUp $ single migration
90 & pqThen $ migrateUp $ single migration
91
91
92dropDB :: IO ()
92dropDB :: IO ()
@@ -111,8 +111,8 @@ specs = before_ setupDB $ after_ dropDB $
111 describe "Exceptions" $ do
111 describe "Exceptions" $ do
112 it "Should be raised in transactions and cause rollback" $
112 it "Should be raised in transactions and cause rollback" $
113 withConnection connectionString insertUserTwice
113 withConnection connectionString insertUserTwice
114− `shouldThrow` anyErrorCall
114+ `shouldThrow` (const True :: Selector SquealException)
115
115
116 it "Should be raised outside of transactions" $
116 it "Should be raised outside of transactions" $
117 withConnection connectionString (transactionally_ insertUserTwice)
117 withConnection connectionString (transactionally_ insertUserTwice)
118− `shouldThrow` anyErrorCall
118+ `shouldThrow` (const True :: Selector SquealException)