diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for gingersnap + +## 0.1.0.0 -- 2018-10-18 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Tinybop Inc., Tom Murphy + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of tom-bop nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gingersnap.cabal b/gingersnap.cabal new file mode 100644 --- /dev/null +++ b/gingersnap.cabal @@ -0,0 +1,34 @@ +name: gingersnap +version: 0.1.0.0 +synopsis: snap-core + aeson + postgresql-simple = delicious +description: JSON API idioms for snap-core, preventing DB connection leaks +license: BSD3 +license-file: LICENSE +author: Tinybop Labs, tom-bop +maintainer: tom@tinybop.com +homepage: https://github.com/Tinybop/gingersnap +-- copyright: +category: Web +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/Tinybop/gingersnap + +library + exposed-modules: + Gingersnap.Core + -- other-modules: + -- other-extensions: + build-depends: + base >=4.9 && <5 + , aeson + , bytestring + , http-types + , postgresql-simple + , resource-pool + , snap-core + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Gingersnap/Core.hs b/src/Gingersnap/Core.hs new file mode 100644 --- /dev/null +++ b/src/Gingersnap/Core.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE + ExistentialQuantification + , InstanceSigs + , LambdaCase + , OverloadedStrings + , ViewPatterns + #-} + +module Gingersnap.Core ( + IsCtx(..) + , ApiErr(..) + , ErrResult(..) + + , Rsp -- (..) -- Maybe export this and 'ShouldCommitOrRollback' in the future + -- TODO: move these lower in export list for Haddocks: + -- , RspPayload + -- , ShouldCommitOrRollback(..) + + , rspGood + , rspBad + , rspGoodCSV + , rspGoodLBS + , rspEmptyGood + , rspBadCommit + + , pureRsp + + , inTransaction + , inTransaction_readOnly + , inTransaction_override + , inTransactionMode + , rspIsGood + + , errorEarlyCode + + -- Maybe?: + -- , module import Network.HTTP.Types.Status + -- , module Snap.Core + ) where + +import qualified Control.Exception as E +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON(..), (.=)) +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import Data.Pool (Pool) +import qualified Data.Pool as Pool +import Database.PostgreSQL.Simple (Connection) +import qualified Database.PostgreSQL.Simple as PSQL +import qualified Database.PostgreSQL.Simple.Transaction as PSQL +import qualified Network.HTTP.Types.Status as HTTP +import Snap.Core (Snap) +import qualified Snap.Core as Snap + +class IsCtx ctx where + ctxConnectionPool :: ctx -> Pool Connection + + ctxGetReadOnlyMode :: ctx -> IO Bool + + ctx_wrapSuccess :: ToJSON x => ctx -> x -> JSON.Value + ctx_wrapSuccess _ x = JSON.object ["result" .= x] + + ctx_err_inReadOnlyMode :: ctx -> ErrResult + ctx_err_inReadOnlyMode _ = errResult DefaultErrors_ReadOnlyMode + +class ApiErr apiErr where + errResult :: apiErr -> ErrResult + +data ErrResult + = ErrResult HTTP.Status JSON.Value + deriving (Show, Eq) + +-- Might be nice, since we don't have a Read. +-- But probably better for a 'pretty*' function +{- +instance Show ErrResult where + show (ErrResult status j) = + "ErrResult "++show status++" "++show (JSON.encode j) +-} + +instance ApiErr ErrResult where + errResult x = x + +data DefaultErrors + = DefaultErrors_ReadOnlyMode + deriving (Show, Eq) + +instance ApiErr DefaultErrors where + errResult :: DefaultErrors -> ErrResult + errResult = \case + DefaultErrors_ReadOnlyMode -> ErrResult HTTP.serviceUnavailable503 $ + JSON.object [ + "errorCode" .= (0 :: Int) + , "errorMessage" .= JSON.String "This action is unavailable in read-only mode" + ] + +data Rsp + = Rsp { + rspShouldCommit :: ShouldCommitOrRollback + , rspPayload :: RspPayload + } + +data RspPayload + = forall x. ToJSON x => RspPayload_Good x + | forall e. ApiErr e => RspPayload_Bad e + -- First ByteString is MIME type; second is response body: + | RspPayload_Custom HTTP.Status BS.ByteString BSL.ByteString + | RspPayload_Empty -- This might be a dupe with '_Custom' but it's nice to have + +data ShouldCommitOrRollback + = ShouldCommit + | ShouldRollback + deriving (Show, Eq) + +-- | This means everything's succeeded. We should commit DB changes and +-- return a success object +rspGood :: ToJSON x => x -> Rsp +rspGood x = Rsp ShouldCommit $ RspPayload_Good x + +rspBad, rspBadCommit :: ApiErr ae => ae -> Rsp +-- | We should send back an error object and roll back DB changes +rspBad e = Rsp ShouldRollback $ RspPayload_Bad e +-- | Like 'RspBad' but should still commit DB changes +rspBadCommit e = Rsp ShouldCommit $ RspPayload_Bad e + +rspGoodCSV :: BSL.ByteString -> Rsp +rspGoodCSV bs = Rsp ShouldCommit $ RspPayload_Custom HTTP.ok200 (BS8.pack "text/csv") bs + +-- | First Bytestring is the content type, e.g. "application/json" +-- Here's a helpful list: +-- https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types +rspGoodLBS :: BS.ByteString -> BSL.ByteString -> Rsp +rspGoodLBS mimeType bs = Rsp ShouldCommit $ RspPayload_Custom HTTP.ok200 mimeType bs + +-- | Everything worked and we send a 200, but we don't have any data to send +rspEmptyGood :: Rsp +rspEmptyGood = Rsp ShouldCommit RspPayload_Empty + +-- Extra helpers we could add: +{- +data Rsp + -- | Like 'RspGood' but rolls back. Sure, why not? Maybe we'll want this for + -- something... + | forall x. ToJSON x => RspGoodRollback x + + -- | We use this in the case where we want to rollback but don't want to tell + -- the user about it. E.g. if we want to not create an account because + -- the email is already taken - but we don't want to tell the + -- unauthenticated user that that email is taken (because it's leaking + -- information about our users) + | RspEmptyGoodRollback +-} + +rspIsGood :: Rsp -> Bool +rspIsGood (Rsp _ payload) = case payload of + RspPayload_Good {} -> True + RspPayload_Bad {} -> False + RspPayload_Custom httpStatus _ _ -> httpStatus == HTTP.ok200 + RspPayload_Empty -> True + +instance Show Rsp where + show (Rsp commit payload) = + "Rsp "++show commit++" "++case payload of + RspPayload_Good x -> "(Good "++show (JSON.encode x)++")" + RspPayload_Bad (errResult -> e) -> "(Bad "++show e++")" + RspPayload_Empty -> "Empty" + RspPayload_Custom a b c -> "(Custom "++show (a,b,c)++")" + +-- | *If you hit the DB, use this function!* +-- +-- This is a lot like 'withTransaction', but it allows us to rollback if we +-- want, without throwing an error. +-- (Don't use 'withTransaction'!) +-- +-- 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 ctx actionThatReturnsAnRsp = do + inTransactionMode ctx PSQL.Serializable PSQL.ReadWrite actionThatReturnsAnRsp + +-- | An endpoint that uses 'inTransaction_readOnly' will keep responding even +-- when the server is in read-only mode. +-- +-- 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 ctx f = + inTransactionMode ctx PSQL.Serializable PSQL.ReadOnly f + +-- | YOU SHOULD ONLY USE THIS ONCE +-- +-- This lets you do a write transaction during read-only mode (not a +-- read-only transaction! A time where 'ctxGetReadOnlyMode' would return +-- True) +-- +-- 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 ctx action = + inTransaction_internal ctx PSQL.Serializable PSQL.ReadWrite action + +inTransactionMode :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap () +inTransactionMode ctx isolationLevel' readWriteMode' actionThatReturnsAResponse = do + readOnlyMode <- liftIO $ ctxGetReadOnlyMode ctx + when (readOnlyMode && (readWriteMode' /= PSQL.ReadOnly)) $ + errorEarlyCode $ ctx_err_inReadOnlyMode ctx + + inTransaction_internal ctx isolationLevel' readWriteMode' 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 + + let transactMode = PSQL.TransactionMode isolationLevel' readWriteMode' + rsp <- liftIO $ Pool.withResource (ctxConnectionPool ctx) $ \conn -> + E.mask $ \restore -> do + PSQL.beginMode transactMode conn + r <- restore (actionThatReturnsAResponse conn) + `E.onException` rollback_ conn + (case rspShouldCommit r of + ShouldCommit -> PSQL.commit 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? + pure r + pureRsp ctx rsp + +-- | Sometimes you don't need a DB connection at all! +pureRsp :: IsCtx ctx => ctx -> Rsp -> Snap () +pureRsp ctx (Rsp _ payload) = case payload of + RspPayload_Empty -> Snap.writeBS "" + RspPayload_Good v -> writeJSON $ ctx_wrapSuccess ctx v + RspPayload_Bad e -> writeApiErr e + RspPayload_Custom httpStatus mimeType bs -> do + 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 + Snap.modifyResponse $ Snap.setHeader "Content-Type" contentType + Snap.writeLBS b + +writeJSON :: ToJSON x => x -> Snap () +writeJSON x = do + Snap.modifyResponse $ Snap.setHeader "Content-Type" "application/json" + Snap.writeLBS $ JSON.encode $ x + +-- | NOTE: be very careful to not use this with any setup/teardown block like 'withTransaction' +-- - causes resource leaks +-- - BUT! This should never happen to you because all your DB code should +-- use 'inTransaction'! +-- +-- NOTE: use 403 forbidden instead of unauthorized - unauth means not logged in at all +-- +-- Also note this returns any 'Snap x' so you can use it like a throw anywhere +-- in your snap code +errorEarlyCode :: ApiErr ae => ae -> Snap x +errorEarlyCode err = do + writeApiErr err + Snap.getResponse >>= Snap.finishWith +-- Difference with 'pureRsp . rspBad' is that it actually 'finishWith's + +writeApiErr :: ApiErr ae => ae -> Snap () +writeApiErr (errResult -> (ErrResult httpStatus responseVal)) = do + Snap.modifyResponse $ Snap.setResponseCode $ + HTTP.statusCode httpStatus + writeJSON $ toJSON responseVal