git.iko.soy/typeable/octopod
on master help sign in
add special handling of unique violation in database
commit83c9a9285aac46ddd61e96b1b9abcc33a9d787ac authorAndrei Orlov <aaorlov1@gmail.com> dateThu 11 Jun 2020, 18:14 (6 years ago) parente519ca1
3 files changed+26−18
default.nix+16−16 dm.cabal+4 src/DMS.hs+6−2
default.nix+16−16
@@ -2,10 +2,10 @@
22, data-default-class, deriving-aeson, directory, fast-logger
33, filepath, generic-lens, http-api-data, http-client
44, http-client-tls, lens, mtl, network-uri, optparse-generic
5−, postgresql-simple, resource-pool, servant, servant-client
6−, servant-client-core, servant-server, stdenv, temporary, text, tls
7−, transformers, typed-process, warp, warp-tls, x509, x509-store
8−, x509-validation
5+, postgresql-error-codes, postgresql-simple, resource-pool, servant
6+, servant-client, servant-client-core, servant-server, stdenv
7+, temporary, text, tls, transformers, typed-process, warp, warp-tls
8+, x509, x509-store, x509-validation
99}:
1010mkDerivation {
1111 pname = "dm";
@@ -17,26 +17,26 @@ mkDerivation {
1717 aeson async base bytestring chronos connection data-default-class
1818 deriving-aeson directory fast-logger filepath generic-lens
1919 http-api-data http-client http-client-tls lens mtl network-uri
20− optparse-generic postgresql-simple resource-pool servant
21− servant-client servant-client-core servant-server temporary text
22− tls transformers typed-process warp warp-tls x509 x509-store
23− x509-validation
20+ optparse-generic postgresql-error-codes postgresql-simple
21+ resource-pool servant servant-client servant-client-core
22+ servant-server temporary text tls transformers typed-process warp
23+ warp-tls x509 x509-store x509-validation
2424 ];
2525 executableHaskellDepends = [
2626 aeson async base bytestring chronos connection data-default-class
2727 directory fast-logger filepath http-client http-client-tls mtl
28− network-uri optparse-generic postgresql-simple resource-pool
29− servant servant-client servant-client-core servant-server temporary
30− text tls transformers typed-process warp warp-tls x509 x509-store
31− x509-validation
28+ network-uri optparse-generic postgresql-error-codes
29+ postgresql-simple resource-pool servant servant-client
30+ servant-client-core servant-server temporary text tls transformers
31+ typed-process warp warp-tls x509 x509-store x509-validation
3232 ];
3333 testHaskellDepends = [
3434 aeson async base bytestring chronos connection data-default-class
3535 directory fast-logger filepath http-client http-client-tls mtl
36− network-uri optparse-generic postgresql-simple resource-pool
37− servant servant-client servant-client-core servant-server temporary
38− text tls transformers typed-process warp warp-tls x509 x509-store
39− x509-validation
36+ network-uri optparse-generic postgresql-error-codes
37+ postgresql-simple resource-pool servant servant-client
38+ servant-client-core servant-server temporary text tls transformers
39+ typed-process warp warp-tls x509 x509-store x509-validation
4040 ];
4141 homepage = "https://github.com/https://github.com/Aviora/dm#readme";
4242 license = stdenv.lib.licenses.bsd3;
dm.cabal+4
@@ -69,6 +69,7 @@ library
6969 , mtl
7070 , network-uri
7171 , optparse-generic
72+ , postgresql-error-codes
7273 , postgresql-simple
7374 , resource-pool
7475 , servant
@@ -113,6 +114,7 @@ executable dmc-exe
113114 , mtl
114115 , network-uri
115116 , optparse-generic
117+ , postgresql-error-codes
116118 , postgresql-simple
117119 , resource-pool
118120 , servant
@@ -156,6 +158,7 @@ executable dms-exe
156158 , mtl
157159 , network-uri
158160 , optparse-generic
161+ , postgresql-error-codes
159162 , postgresql-simple
160163 , resource-pool
161164 , servant
@@ -199,6 +202,7 @@ test-suite dm-test
199202 , mtl
200203 , network-uri
201204 , optparse-generic
205+ , postgresql-error-codes
202206 , postgresql-simple
203207 , resource-pool
204208 , servant
src/DMS.hs+6−2
@@ -18,6 +18,7 @@ import Database.PostgreSQL.Simple
1818import Network.Wai.Handler.Warp
1919import Network.Wai.Handler.WarpTLS
2020import Options.Generic
21+import PostgreSQL.ErrorCodes (unique_violation)
2122import Prelude hiding (lines, unlines, unwords, log)
2223import Servant
2324import System.Environment (lookupEnv)
@@ -157,8 +158,11 @@ createH dep = do
157158 (n, t, formatEnvPairs e)
158159 res :: Either SqlError Int64 <- liftIO . try $ createDep pgPool dep
159160 case res of
160− Right _ -> pure ()
161− Left _ -> throwError err400 { errBody = "deployment already exists" }
161+ Right _ -> pure ()
162+ Left (SqlError code _ _ _ _) | code == unique_violation ->
163+ throwError err400 { errBody = "deployment already exists" }
164+ Left (SqlError _ _ _ _ _) ->
165+ throwError err409 { errBody = "some database error" }
162166 ec <- createDeployment dep st
163167 void $ liftIO $ do
164168 createDeploymentLog pgPool dep "create" ec $ ArchivedFlag False