gingersnap 0.2.2.3 → 0.3.0.0

raw patch · 4 files changed

+198/−41 lines, 4 filesdep +containersdep +gingersnapdep +microspecdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, gingersnap, microspec

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +3/−3
• gingersnap.cabal +37/−9
• src/Gingersnap/Core.hs +83/−29
• test/Tests.hs +75/−0

@@ -2,7 +2,7 @@  Gingersnap's not a web framework: that's `snap-core`'s job. More a set of lightweight idioms for building a resource-safe JSON API with-`postgresql-simple`.+(by default) `postgresql-simple`.  As it's just a set of idioms, it's easy to only use 'em where you need 'em. An app could have only a single endpoint that uses Gingersnap, with the rest@@ -24,7 +24,7 @@  -- For our automatic JSON instance: import GHC.Generics (Generic) import Gingersnap.Core-import Network.HTTP.Types.Status (internalServerError500, unprocessableEntity422)+import Network.HTTP.Types.Status import Snap.Core -- From the 'snap-server' package: import Snap.Http.Server (quickHttpServe)@@ -50,7 +50,7 @@ You can run the code from this file with      $ cabal update-    $ cabal install gingersnap snap-server+    $ cabal install gingersnap snap-server markdown-unlit     $ ghci -pgmL markdown-unlit README.lhs   # The "-pgmL" is just for this README  And calling "main". In another window, if you call:

@@ -1,16 +1,27 @@ name:                gingersnap-version:             0.2.2.3+version:             0.3.0.0 synopsis:-  Tools for consistent and safe JSON APIs with snap-core and postgresql-simple+  Consistent and safe JSON APIs with snap-core and (by default) postgresql-simple description:-  Straightforward JSON API idioms for snap-core and postgresql-simple, that-  prevent DB connection leaks.+  Straightforward JSON API tools and idioms for snap-core and datastore access+  (by default PostgreSQL via postgresql-simple), that provide:+  .+    - Safe access to pools of DB connections (preventing connection leaks)+    - Simple and consistent JSON responses for successes and failures+      (including unexpected failures)+    - An optional read-only/maintenance mode for keeping services up during+      e.g. database migrations+  .   See the README for a tutorial and example use.++--   The goal is to provide \"simplicity at scale\" for developers who value not+--   needing to reinvent the wheel.+--   . license:             BSD3 license-file:        LICENSE author:              Tinybop Labs, tom-bop-maintainer:          tom@tinybop.com-homepage:            https://github.com/Tinybop/gingersnap+-- maintainer:          tom@tinybop.com+-- homepage:            https://github.com/Tinybop/gingersnap -- copyright:            category:            Web build-type:          Simple@@ -19,9 +30,9 @@   README.md cabal-version:       >=1.10 -source-repository head-  type:     git-  location: https://github.com/Tinybop/gingersnap+-- source-repository head+--   type:     git+--   location: https://github.com/Tinybop/gingersnap  library   exposed-modules:@@ -43,3 +54,20 @@     , unordered-containers   hs-source-dirs:      src   default-language:    Haskell2010++test-suite gingersnap-tests+  hs-source-dirs: test+  main-is: Tests.hs+  type: exitcode-stdio-1.0+  build-depends:+      base+    , bytestring+    , containers+    , gingersnap+    , microspec+    , postgresql-simple+    , snap-core+    , transformers++  default-language:    Haskell2010+

@@ -1,5 +1,6 @@ {-# LANGUAGE      BangPatterns+   , DefaultSignatures    , DeriveGeneric    , ExistentialQuantification    , FlexibleContexts@@ -27,9 +28,12 @@     -- * DB Transactions    , inTransaction+   , inTransactionWithMode    , inTransactionMode    , inTransaction_readOnly+   , inTransaction_readWrite    , inTransaction_override+   , inTransaction_internal    , rspIsGood     -- * IsCtx@@ -93,7 +97,7 @@ -- | Don't be daunted! The only thing you need to provide (i.e. that doesn't --     have a default value) is 'ctxConnectionPool' class ApiErr (CtxErrType ctx) => IsCtx ctx where-   ctxConnectionPool :: ctx -> Pool Connection+   ctxConnectionPool :: ctx -> Pool (ConnType ctx)     ctxGetReadOnlyMode :: ctx -> IO Bool    ctxGetReadOnlyMode _ = pure False@@ -104,6 +108,44 @@    type CtxErrType ctx    type instance CtxErrType ctx = DefaultApiErr ++   type ConnType ctx :: *+   type ConnType ctx = PSQL.Connection+++   -- Take a look at how postgresql-simple does it:+   ctx_rollback :: ctx -> ConnType ctx -> IO ()+   default ctx_rollback :: (ConnType ctx ~ PSQL.Connection) => ctx -> ConnType ctx -> IO ()+   ctx_rollback _ conn =+      PSQL.rollback conn+         `E.catch` ((\_ -> return ()) :: IOError -> IO ())++   ctx_commit :: ctx -> ConnType ctx -> IO ()+   default ctx_commit :: (ConnType ctx ~ PSQL.Connection) => ctx -> ConnType ctx -> IO ()+   ctx_commit _ = PSQL.commit++   type TxModeType ctx :: *+   type TxModeType ctx = PSQL.TransactionMode++   ctx_defaultTransactionMode :: ctx -> TxModeType ctx+   default ctx_defaultTransactionMode :: (TxModeType ctx ~ PSQL.TransactionMode) => ctx -> TxModeType ctx+   ctx_defaultTransactionMode _ =+      PSQL.TransactionMode PSQL.Serializable PSQL.ReadWrite++   ctx_txIsReadOnly :: ctx -> TxModeType ctx -> Bool+   default ctx_txIsReadOnly :: (TxModeType ctx ~ PSQL.TransactionMode) => ctx -> TxModeType ctx -> Bool+   ctx_txIsReadOnly _ (PSQL.TransactionMode _ rwMode) =+      case rwMode of+         PSQL.ReadOnly -> True+         PSQL.ReadWrite -> False+         -- Without configuration, postgres defaults to ReadWrite:+         PSQL.DefaultReadWriteMode -> False++   ctx_beginTransaction :: ctx -> TxModeType ctx -> ConnType ctx -> IO ()+   default ctx_beginTransaction :: (TxModeType ctx ~ PSQL.TransactionMode, ConnType ctx ~ PSQL.Connection) => ctx -> TxModeType ctx -> ConnType ctx -> IO ()+   ctx_beginTransaction _ transactMode conn = do+      PSQL.beginMode transactMode conn+ -- This just forces the error type like a Proxy ctxErr :: IsCtx ctx => ctx -> (CtxErrType ctx) -> (CtxErrType ctx) ctxErr _ x = x@@ -326,9 +368,9 @@ --   NOTE this is for IO actions, not Snap actions. This is to ensure we can't --   call e.g. 'finishEarly' and never hit the 'end transaction' code! --   (It also has the side benefit of keeping code fairly framework-agnostic)-inTransaction :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()+inTransaction :: IsCtx ctx => ctx -> (ConnType ctx -> IO Rsp) -> Snap () inTransaction ctx actionThatReturnsAnRsp = do-   inTransactionMode ctx PSQL.Serializable PSQL.ReadWrite actionThatReturnsAnRsp+   inTransactionWithMode ctx (ctx_defaultTransactionMode ctx) actionThatReturnsAnRsp  -- | Creates a read-only transaction and will keep responding even if the --   server's in read-only mode.@@ -336,10 +378,15 @@ --   Note that you the programmer are asserting the DB queries are read-only. --   There's nothing in this library or in postgresql-simple which statically --   checks that to be true!-inTransaction_readOnly :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()+inTransaction_readOnly :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> (ConnType ctx -> IO Rsp) -> Snap () inTransaction_readOnly ctx f =-   inTransactionMode ctx PSQL.Serializable PSQL.ReadOnly f+   inTransactionWithMode ctx (PSQL.TransactionMode PSQL.Serializable PSQL.ReadOnly) f +-- | This is the default for IsCtx but this allows us to be explicit+inTransaction_readWrite :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> (ConnType ctx -> IO Rsp) -> Snap ()+inTransaction_readWrite ctx f =+   inTransactionWithMode ctx (PSQL.TransactionMode PSQL.Serializable PSQL.ReadWrite) f+ -- | _You should only use this once!_ --  --   This lets you do a write transaction during read-only mode (not a@@ -348,40 +395,53 @@ --  --   You may need this so that an admin user can take the app out of read-only --     mode-inTransaction_override :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()+inTransaction_override :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> (ConnType ctx -> IO Rsp) -> Snap () inTransaction_override ctx action =-   inTransaction_internal ctx PSQL.Serializable PSQL.ReadWrite action+   inTransaction_internal ctx (PSQL.TransactionMode PSQL.Serializable PSQL.ReadWrite) action --- | The most general version of 'inTransaction'.+-- | Postgres-specific version of 'inTransactionWithMode' -- ---   An endpoint that uses 'ReadOnly' will keep responding even when the server---   is in read-only mode.-inTransactionMode :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap ()+--   Will likely be removed in a future version+inTransactionMode :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (ConnType ctx -> IO Rsp) -> Snap () inTransactionMode ctx isolationLevel' readWriteMode' actionThatReturnsAResponse = do-   readOnlyMode <- liftIO $ ctxGetReadOnlyMode ctx-   when (readOnlyMode && (readWriteMode' /= PSQL.ReadOnly)) $+   inTransactionWithMode ctx (PSQL.TransactionMode isolationLevel' readWriteMode') actionThatReturnsAResponse++-- | The most general version of 'inTransaction'.+-- +--   An endpoint that uses a read-only transaction mode will keep responding+--   even when the server is in read-only mode, while all others will return+--   the result of 'apiErr_inReadOnlyMode' (by default a 503)+-- +--   'inTransactionMode' will eventually be replaced by this.+inTransactionWithMode :: IsCtx ctx => ctx -> TxModeType ctx -> (ConnType ctx -> IO Rsp) -> Snap ()+inTransactionWithMode ctx txMode actionThatReturnsAResponse = do+   inReadOnlyMode <- liftIO $ ctxGetReadOnlyMode ctx+   when (inReadOnlyMode && (not $ ctx_txIsReadOnly ctx txMode)) $       errorEarlyCode $ ctxErr ctx apiErr_inReadOnlyMode -   inTransaction_internal ctx isolationLevel' readWriteMode' actionThatReturnsAResponse+   inTransaction_internal ctx txMode actionThatReturnsAResponse  -- | DON'T USE THIS FUNCTION! This should only be called by---   'inTransaction_override' and 'inTransactionMode'-inTransaction_internal :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap ()-inTransaction_internal ctx isolationLevel' readWriteMode' actionThatReturnsAResponse = do+--   'inTransaction_override' and 'inTransactionWithMode'+--   and 'inTransactionMode'+-- +--   Only exported to enable writing '_override' for non-postgres datastores+inTransaction_internal :: IsCtx ctx => ctx -> TxModeType ctx -> (ConnType ctx -> IO Rsp) -> Snap ()+inTransaction_internal ctx transactionMode actionThatReturnsAResponse = do -   let transactMode = PSQL.TransactionMode isolationLevel' readWriteMode'    rsp <- liftIO $       (Pool.withResource (ctxConnectionPool ctx) $ \conn ->          E.mask $ \restore -> do-            PSQL.beginMode transactMode conn+            ctx_beginTransaction ctx transactionMode conn             !r <- restore (force <$> actionThatReturnsAResponse conn)-               `E.onException` rollback_ conn+               -- TODO: why onException instead of 'catch'?:+               `E.onException` ctx_rollback ctx conn             (case rspShouldCommit r of-               ShouldCommit -> PSQL.commit conn+               ShouldCommit -> ctx_commit ctx conn                -- Note it is safe to call rollback on a read-only transaction:                -- https://www.postgresql.org/message-id/26036.1114469591%40sss.pgh.pa.us-               ShouldRollback -> rollback_ conn-               ) `E.onException` rollback_ conn -- To be safe. E.g. what if inspecting 'r' errors?+               ShouldRollback -> ctx_rollback ctx conn+               ) `E.onException` ctx_rollback ctx conn -- To be safe. E.g. what if inspecting 'r' errors?             pure r)                `E.catch` (\e@(E.SomeException {}) -> pure $ rspBad $                   ctxErr ctx $ apiErr_unexpectedError $ T.pack $ show e)@@ -397,12 +457,6 @@       Snap.modifyResponse $ Snap.setResponseCode $          HTTP.statusCode httpStatus       writeLBSSuccess_dontUseThis mimeType bs---- Take a look at how postgresql-simple does it:-rollback_ :: Connection -> IO ()-rollback_ conn =-   PSQL.rollback conn-      `E.catch` ((\_ -> return ()) :: IOError -> IO ())  writeLBSSuccess_dontUseThis :: BS.ByteString -> BSL.ByteString -> Snap () writeLBSSuccess_dontUseThis contentType b = do

@@ -0,0 +1,75 @@+{-# LANGUAGE+     InstanceSigs+   , OverloadedStrings+   , TypeFamilies, NoMonoLocalBinds+   #-}++module Main where++import qualified Data.Map as Map+import Database.PostgreSQL.Simple.Transaction as PSQL+import Snap.Core+import Snap.Test+import Test.Microspec++import Gingersnap.Core+++main :: IO ()+main = microspec $ do+   describe "read-only mode" $ do+      let rwHandler, rHandler :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> Snap ()+          rwHandler ctx = inTransaction_readWrite ctx $ \_ -> pure $ rspGood True+          rHandler  ctx = inTransaction_readOnly  ctx $ \_ -> pure $ rspGood True+      it "doesn't run a read-write tx in read-only  mode" $ monadicIO $ do+         ctx <- run mkReadOnlyCtx+         r <- run $ runHandler (get "" Map.empty) (rwHandler ctx)+         body <- run $ getResponseBody r+         assert $ (rspStatus r == 503) && (body == "{\"errorCode\":0,\"errorVals\":[],\"errorMessage\":\"This action is unavailable in read-only mode\"}")+      it "does    run a read-write tx in read-write mode" $ monadicIO $ do+         ctx <- run mkReadWriteCtx+         r <- run $ runHandler (get "" Map.empty) (rwHandler ctx)+         body <- run $ getResponseBody r+         assert $ (rspStatus r == 200) && (body == "{\"result\":true}")+      it "does    run a read-only  tx in read-only mode" $ monadicIO $ do+         ctx <- run mkReadOnlyCtx+         r <- run $ runHandler (get "" Map.empty) (rHandler ctx)+         body <- run $ getResponseBody r+         assert $ (rspStatus r == 200) && (body == "{\"result\":true}")++data ReadOnlyCtx+   = ReadOnlyCtx (Pool ())++mkReadOnlyCtx :: IO ReadOnlyCtx+mkReadOnlyCtx = ReadOnlyCtx <$> createPool (pure ()) (\() -> pure ()) 100 0.5 100++data ReadWriteCtx+   = ReadWriteCtx (Pool ())++mkReadWriteCtx :: IO ReadWriteCtx+mkReadWriteCtx = ReadWriteCtx <$> createPool (pure ()) (\() -> pure ()) 100 0.5 100++instance IsCtx ReadOnlyCtx where+   ctxGetReadOnlyMode _ = pure True+   ctxConnectionPool (ReadOnlyCtx p) = p++   type ConnType ReadOnlyCtx = ()+   ctx_beginTransaction :: ReadOnlyCtx -> PSQL.TransactionMode -> () -> IO ()+   ctx_beginTransaction _ _ _ = pure ()+   ctx_commit :: ReadOnlyCtx -> () -> IO ()+   ctx_commit _ _ = pure ()+   ctx_rollback :: ReadOnlyCtx -> () -> IO ()+   ctx_rollback _ _ = pure ()++instance IsCtx ReadWriteCtx where+   ctxGetReadOnlyMode _ = pure False+   ctxConnectionPool (ReadWriteCtx p) = p++   type ConnType ReadWriteCtx = ()+   ctx_beginTransaction :: ReadWriteCtx -> PSQL.TransactionMode -> () -> IO ()+   ctx_beginTransaction _ _ _ = pure ()+   ctx_commit :: ReadWriteCtx -> () -> IO ()+   ctx_commit _ _ = pure ()+   ctx_rollback :: ReadWriteCtx -> () -> IO ()+   ctx_rollback _ _ = pure ()+