gingersnap (empty) → 0.1.0.0

raw patch · 5 files changed

+351/−0 lines, 5 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, http-types, postgresql-simple, resource-pool, snap-core

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• gingersnap.cabal +34/−0
• src/Gingersnap/Core.hs +280/−0

@@ -0,0 +1,5 @@+# Revision history for gingersnap++## 0.1.0.0  -- 2018-10-18++* Initial release

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -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