diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/gingersnap.cabal b/gingersnap.cabal --- a/gingersnap.cabal +++ b/gingersnap.cabal @@ -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 + diff --git a/src/Gingersnap/Core.hs b/src/Gingersnap/Core.hs --- a/src/Gingersnap/Core.hs +++ b/src/Gingersnap/Core.hs @@ -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 diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -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 () +