{-# LANGUAGE
     BangPatterns
   , DeriveGeneric
   , ExistentialQuantification
   , FlexibleContexts
   , InstanceSigs
   , LambdaCase
   , OverloadedStrings
   , TypeFamilies
   , ViewPatterns
   #-}

module Gingersnap.Core (
   -- * Rsp
     rspGood
   , rspBad
   , rspBadCommit
   , rspBadRollback
   , rspGoodCSV
   , rspGoodLBS
   , rspEmptyGood
   , Rsp(..)


   -- * pureRsp
   , pureRsp

   -- * DB Transactions
   , inTransaction
   , inTransactionMode
   , inTransaction_readOnly
   , inTransaction_override
   , rspIsGood

   -- * IsCtx
   , IsCtx(..)

   -- * JSON requests
   , reqObject
   , reqObject'
   , (.!)
   , (.!?)
   , ReqObject(..)

   -- * Errors
   , errorEarlyCode

   , ApiErr(..)
   , ErrResult(..)
   , DefaultApiErr(..)

   , ctxErr

   -- * Internals
   -- These won't typically be inspected by hand but there's no reason we should
   --   block people from inspecting them if they like
   , RspPayload(..)
   , ShouldCommitOrRollback(..)

   -- * Reexports, for convenience
   , Pool
   , createPool
   , Connection

   -- Maybe?:
   -- , module import Network.HTTP.Types.Status
   -- , module Snap.Core
   ) where

import Control.DeepSeq -- (NFData(rnf), deepseq)
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, fromJSON, 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 qualified Data.HashMap.Strict as HM
import Data.Pool (Pool, createPool)
import qualified Data.Pool as Pool
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word
import Database.PostgreSQL.Simple (Connection)
import qualified Database.PostgreSQL.Simple as PSQL
import qualified Database.PostgreSQL.Simple.Transaction as PSQL
import GHC.Generics (Generic)
import qualified Network.HTTP.Types.Status as HTTP
import Snap.Core (Snap)
import qualified Snap.Core as Snap

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

   ctxGetReadOnlyMode :: ctx -> IO Bool
   ctxGetReadOnlyMode ctx
_ = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

   ctx_wrapSuccess :: ToJSON x => ctx -> x -> JSON.Value
   ctx_wrapSuccess ctx
_ x
x = [Pair] -> Value
JSON.object [Text
"result" Text -> x -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= x
x]

   type CtxErrType ctx
   type instance CtxErrType ctx = DefaultApiErr

-- This just forces the error type like a Proxy
ctxErr :: IsCtx ctx => ctx -> (CtxErrType ctx) -> (CtxErrType ctx)
ctxErr :: ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
_ CtxErrType ctx
x = CtxErrType ctx
x

class ApiErr apiErr where
   errResult :: apiErr -> ErrResult

   -- | The request object is missing a required key.
   --   E.g. the request is @{"first": "Tom"}@ but we need both a @"first"@ and a
   --   @"last"@
   apiErr_missingRequestKey :: Text -> apiErr

   -- | We can't process the request because the request is malformed JSON or
   --   not JSON at all
   apiErr_requestNotJSON :: apiErr

   -- | The request *is* JSON, but not an object (e.g. maybe it's an array
   --   or a number, but we need an object)
   apiErr_requestNotJSONObject :: apiErr

   -- | It's a JSON object but it's malformed somehow (e.g. maybe it's got the
   --   wrong keys). In other words, we can't 'fromJSON' it successfully.
   --
   --   (The 'Text' is the key of the malformed value)
   apiErr_malformedRequestValue :: Text -> JSON.Value -> apiErr

   -- | A 500 internal server error
   -- 
   --   The Text value is the error message. You may want different behavior in
   --     development vs. production, e.g. not showing internal errors in prod
   apiErr_unexpectedError :: Text -> apiErr

   apiErr_inReadOnlyMode :: apiErr

data ErrResult
   = ErrResult HTTP.Status JSON.Value
 deriving (Int -> ErrResult -> ShowS
[ErrResult] -> ShowS
ErrResult -> String
(Int -> ErrResult -> ShowS)
-> (ErrResult -> String)
-> ([ErrResult] -> ShowS)
-> Show ErrResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrResult] -> ShowS
$cshowList :: [ErrResult] -> ShowS
show :: ErrResult -> String
$cshow :: ErrResult -> String
showsPrec :: Int -> ErrResult -> ShowS
$cshowsPrec :: Int -> ErrResult -> ShowS
Show, ErrResult -> ErrResult -> Bool
(ErrResult -> ErrResult -> Bool)
-> (ErrResult -> ErrResult -> Bool) -> Eq ErrResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrResult -> ErrResult -> Bool
$c/= :: ErrResult -> ErrResult -> Bool
== :: ErrResult -> ErrResult -> Bool
$c== :: ErrResult -> ErrResult -> Bool
Eq) -- , Generic)

instance NFData ErrResult where
   -- ~~[Forcing HTTP.Status]~~
   -- There's no NFData instance for HTTP.Status, and I don't want to make an
   --   orphan instance for one, so we take it apart by hand instead:
   rnf :: ErrResult -> ()
rnf (ErrResult (HTTP.Status Int
code ByteString
msg) Value
v) =
      Int -> ()
forall a. NFData a => a -> ()
rnf Int
code () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
msg () -> () -> ()
`seq` Value -> ()
forall a. NFData a => a -> ()
rnf Value
v

{-
deriving instance Generic HTTP.Status
instance NFData HTTP.Status
-}

-- 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)
-}

data DefaultApiErr
   = DefaultApiErr_ReadOnlyMode
   | DefaultApiErr_MissingRequestKey Text
   | DefaultApiErr_RequestNotJSON
   | DefaultApiErr_RequestNotJSONObject
   | DefaultApiErr_MalformedRequestValue Text JSON.Value
   | DefaultApiErr_UnexpectedError Text
   | DefaultApiErr_Custom HTTP.Status String [(Text, JSON.Value)]
 deriving (Int -> DefaultApiErr -> ShowS
[DefaultApiErr] -> ShowS
DefaultApiErr -> String
(Int -> DefaultApiErr -> ShowS)
-> (DefaultApiErr -> String)
-> ([DefaultApiErr] -> ShowS)
-> Show DefaultApiErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultApiErr] -> ShowS
$cshowList :: [DefaultApiErr] -> ShowS
show :: DefaultApiErr -> String
$cshow :: DefaultApiErr -> String
showsPrec :: Int -> DefaultApiErr -> ShowS
$cshowsPrec :: Int -> DefaultApiErr -> ShowS
Show, DefaultApiErr -> DefaultApiErr -> Bool
(DefaultApiErr -> DefaultApiErr -> Bool)
-> (DefaultApiErr -> DefaultApiErr -> Bool) -> Eq DefaultApiErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultApiErr -> DefaultApiErr -> Bool
$c/= :: DefaultApiErr -> DefaultApiErr -> Bool
== :: DefaultApiErr -> DefaultApiErr -> Bool
$c== :: DefaultApiErr -> DefaultApiErr -> Bool
Eq)

instance ApiErr DefaultApiErr where
   apiErr_inReadOnlyMode :: DefaultApiErr
apiErr_inReadOnlyMode =
      DefaultApiErr
DefaultApiErr_ReadOnlyMode
   apiErr_missingRequestKey :: Text -> DefaultApiErr
apiErr_missingRequestKey =
      Text -> DefaultApiErr
DefaultApiErr_MissingRequestKey
   apiErr_requestNotJSON :: DefaultApiErr
apiErr_requestNotJSON =
      DefaultApiErr
DefaultApiErr_RequestNotJSON
   apiErr_requestNotJSONObject :: DefaultApiErr
apiErr_requestNotJSONObject =
      DefaultApiErr
DefaultApiErr_RequestNotJSONObject
   apiErr_malformedRequestValue :: Text -> Value -> DefaultApiErr
apiErr_malformedRequestValue =
      Text -> Value -> DefaultApiErr
DefaultApiErr_MalformedRequestValue
   apiErr_unexpectedError :: Text -> DefaultApiErr
apiErr_unexpectedError =
      Text -> DefaultApiErr
DefaultApiErr_UnexpectedError

   errResult :: DefaultApiErr -> ErrResult
   errResult :: DefaultApiErr -> ErrResult
errResult = DefaultApiErr -> ErrResult
defaultApiErrResult

defaultApiErrResult :: DefaultApiErr -> ErrResult
defaultApiErrResult :: DefaultApiErr -> ErrResult
defaultApiErrResult DefaultApiErr
err =
   Status -> Value -> ErrResult
ErrResult Status
status  (Value -> ErrResult) -> Value -> ErrResult
forall a b. (a -> b) -> a -> b
$
      [Pair] -> Value
JSON.object [
           Text
"errorCode" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Int
code :: Int)
         , Text
"errorMessage" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
msg
         , Text
"errorVals" Text -> [Pair] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ([Pair]
vals :: [(Text, JSON.Value)])
         ]
 where
    (Int
code, Status
status, String
msg, [Pair]
vals) = case DefaultApiErr
err of
       DefaultApiErr
DefaultApiErr_ReadOnlyMode ->
          (Int
0, Status
HTTP.serviceUnavailable503, String
"This action is unavailable in read-only mode", [])
       DefaultApiErr_UnexpectedError Text
t ->
          (Int
1, Status
HTTP.internalServerError500, String
"An unexpected error occurred", [
               Text
"text" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
t
             ])
       DefaultApiErr_MissingRequestKey Text
k ->
          (Int
2, Status
HTTP.unprocessableEntity422, String
"Required key not present: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
k, [
               Text
"key" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
k
             ])
       DefaultApiErr
DefaultApiErr_RequestNotJSON ->
          (Int
3, Status
HTTP.unprocessableEntity422, String
"Non-JSON message body", [])

       DefaultApiErr
DefaultApiErr_RequestNotJSONObject ->
          (Int
4, Status
HTTP.unprocessableEntity422, String
"Message body is not a JSON object", [])

       DefaultApiErr_MalformedRequestValue Text
k Value
v ->
          (Int
5, Status
HTTP.unprocessableEntity422, String
"Malformed value: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
k, [
               Text
"key" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
k, Text
"value" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
v
             ])
       DefaultApiErr_Custom Status
s String
t [Pair]
vs ->
          (Int
6, Status
s, String
t, [Pair]
vs)

-- | How we construct responses. You probably don't want to be constructing or
--   inspecting them by hand; instead you can use 'rspGood', 'rspBadRollback', etc.
data Rsp
   = Rsp {
     Rsp -> ShouldCommitOrRollback
rspShouldCommit :: ShouldCommitOrRollback
   , Rsp -> RspPayload
rspPayload :: RspPayload
   }
 deriving ((forall x. Rsp -> Rep Rsp x)
-> (forall x. Rep Rsp x -> Rsp) -> Generic Rsp
forall x. Rep Rsp x -> Rsp
forall x. Rsp -> Rep Rsp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Rsp x -> Rsp
$cfrom :: forall x. Rsp -> Rep Rsp x
Generic)

instance NFData Rsp

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

instance NFData RspPayload where
   rnf :: RspPayload -> ()
rnf = \case
      RspPayload
RspPayload_Empty -> ()
      -- RspPayload_Custom a b c -> (RspPayload_Custom $!! a <$!!> b <$!!> c) `seq` ()
      -- TODO: i don't need this '_ $!!' rite?:
      RspPayload_Good x
x -> (Value -> RspPayload
forall x. ToJSON x => x -> RspPayload
RspPayload_Good (Value -> RspPayload) -> Value -> RspPayload
forall a b. NFData a => (a -> b) -> a -> b
$!! (Value -> Value
forall a. NFData a => a -> a
force (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ x -> Value
forall a. ToJSON a => a -> Value
toJSON x
x)) RspPayload -> () -> ()
`seq` ()
      RspPayload_Bad e
e -> ErrResult -> ()
forall a. NFData a => a -> ()
rnf (ErrResult -> ()) -> ErrResult -> ()
forall a b. (a -> b) -> a -> b
$ e -> ErrResult
forall apiErr. ApiErr apiErr => apiErr -> ErrResult
errResult e
e
      RspPayload_Custom (HTTP.Status Int
a ByteString
b) ByteString
c ByteString
d ->
         -- See the note above about ~~[Forcing HTTP.Status]~~ :
         Int -> ()
forall a. NFData a => a -> ()
rnf Int
a () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
b () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
c () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
d

data ShouldCommitOrRollback
   = ShouldCommit
   | ShouldRollback
 deriving (Int -> ShouldCommitOrRollback -> ShowS
[ShouldCommitOrRollback] -> ShowS
ShouldCommitOrRollback -> String
(Int -> ShouldCommitOrRollback -> ShowS)
-> (ShouldCommitOrRollback -> String)
-> ([ShouldCommitOrRollback] -> ShowS)
-> Show ShouldCommitOrRollback
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShouldCommitOrRollback] -> ShowS
$cshowList :: [ShouldCommitOrRollback] -> ShowS
show :: ShouldCommitOrRollback -> String
$cshow :: ShouldCommitOrRollback -> String
showsPrec :: Int -> ShouldCommitOrRollback -> ShowS
$cshowsPrec :: Int -> ShouldCommitOrRollback -> ShowS
Show, ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
(ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool)
-> (ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool)
-> Eq ShouldCommitOrRollback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
$c/= :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
== :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
$c== :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
Eq, (forall x. ShouldCommitOrRollback -> Rep ShouldCommitOrRollback x)
-> (forall x.
    Rep ShouldCommitOrRollback x -> ShouldCommitOrRollback)
-> Generic ShouldCommitOrRollback
forall x. Rep ShouldCommitOrRollback x -> ShouldCommitOrRollback
forall x. ShouldCommitOrRollback -> Rep ShouldCommitOrRollback x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShouldCommitOrRollback x -> ShouldCommitOrRollback
$cfrom :: forall x. ShouldCommitOrRollback -> Rep ShouldCommitOrRollback x
Generic)

instance NFData ShouldCommitOrRollback

-- | This means everything's succeeded. We should commit DB changes and
--   return a success object
rspGood :: ToJSON x => x -> Rsp
rspGood :: x -> Rsp
rspGood x
x = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ x -> RspPayload
forall x. ToJSON x => x -> RspPayload
RspPayload_Good x
x

rspBad, rspBadCommit, rspBadRollback :: ApiErr ae => ae -> Rsp
-- | We should send back an error object and roll back DB changes
rspBad :: ae -> Rsp
rspBad ae
e       = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldRollback (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ ae -> RspPayload
forall e. ApiErr e => e -> RspPayload
RspPayload_Bad ae
e
-- | Like 'rspBad' but should still commit DB changes
rspBadCommit :: ae -> Rsp
rspBadCommit ae
e = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit   (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ ae -> RspPayload
forall e. ApiErr e => e -> RspPayload
RspPayload_Bad ae
e
-- | The same as 'rspBad' but more explicit that we roll back
rspBadRollback :: ae -> Rsp
rspBadRollback ae
e = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldRollback (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ ae -> RspPayload
forall e. ApiErr e => e -> RspPayload
RspPayload_Bad ae
e

rspGoodCSV :: BSL.ByteString -> Rsp
rspGoodCSV :: ByteString -> Rsp
rspGoodCSV ByteString
bs = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> ByteString -> RspPayload
RspPayload_Custom Status
HTTP.ok200 (String -> ByteString
BS8.pack String
"text/csv") ByteString
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 :: ByteString -> ByteString -> Rsp
rspGoodLBS ByteString
mimeType ByteString
bs = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> ByteString -> RspPayload
RspPayload_Custom Status
HTTP.ok200 ByteString
mimeType ByteString
bs

{-
rspCustomLBS :: ShouldCommitOrRollback -> HTTP.Status -> BS.ByteString -> BSL.ByteString -> Rsp
rspCustomLBS shouldCommit status mimeType bs =
   Rsp shouldCommit $ RspPayload_Custom status mimeType bs
-}

-- | Everything worked and we send a 200, but we don't have any data to send
rspEmptyGood :: Rsp
rspEmptyGood :: Rsp
rspEmptyGood = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit RspPayload
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 -> Bool
rspIsGood (Rsp ShouldCommitOrRollback
_ RspPayload
payload) = case RspPayload
payload of
   RspPayload_Good {} -> Bool
True
   RspPayload_Bad {} -> Bool
False
   RspPayload_Custom Status
httpStatus ByteString
_ ByteString
_ ->
      Status
httpStatus Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.ok200
   RspPayload
RspPayload_Empty -> Bool
True

instance Show Rsp where
   show :: Rsp -> String
show (Rsp ShouldCommitOrRollback
commit RspPayload
payload) =
      String
"Rsp "String -> ShowS
forall a. [a] -> [a] -> [a]
++ShouldCommitOrRollback -> String
forall a. Show a => a -> String
show ShouldCommitOrRollback
commitString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++case RspPayload
payload of
         RspPayload_Good x
x -> String
"(Good "String -> ShowS
forall a. [a] -> [a] -> [a]
++ByteString -> String
forall a. Show a => a -> String
show (x -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode x
x)String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
         RspPayload_Bad (e -> ErrResult
forall apiErr. ApiErr apiErr => apiErr -> ErrResult
errResult -> ErrResult
e) -> String
"(Bad "String -> ShowS
forall a. [a] -> [a] -> [a]
++ErrResult -> String
forall a. Show a => a -> String
show ErrResult
eString -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
         RspPayload
RspPayload_Empty -> String
"Empty"
         RspPayload_Custom Status
a ByteString
b ByteString
c -> String
"(Custom "String -> ShowS
forall a. [a] -> [a] -> [a]
++(Status, ByteString, ByteString) -> String
forall a. Show a => a -> String
show (Status
a,ByteString
b,ByteString
c)String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"

-- | _If you hit the DB, use this function!_
-- 
--   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 -> (Connection -> IO Rsp) -> Snap ()
inTransaction ctx
ctx Connection -> IO Rsp
actionThatReturnsAnRsp = do
   ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransactionMode ctx
ctx IsolationLevel
PSQL.Serializable ReadWriteMode
PSQL.ReadWrite Connection -> IO Rsp
actionThatReturnsAnRsp

-- | Creates a read-only transaction and will keep responding even if the
--   server's 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 -> (Connection -> IO Rsp) -> Snap ()
inTransaction_readOnly ctx
ctx Connection -> IO Rsp
f =
   ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransactionMode ctx
ctx IsolationLevel
PSQL.Serializable ReadWriteMode
PSQL.ReadOnly Connection -> IO Rsp
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 -> (Connection -> IO Rsp) -> Snap ()
inTransaction_override ctx
ctx Connection -> IO Rsp
action =
   ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransaction_internal ctx
ctx IsolationLevel
PSQL.Serializable ReadWriteMode
PSQL.ReadWrite Connection -> IO Rsp
action

-- | The most general version of 'inTransaction'.
-- 
--   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 ()
inTransactionMode :: ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransactionMode ctx
ctx IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode' Connection -> IO Rsp
actionThatReturnsAResponse = do
   Bool
readOnlyMode <- IO Bool -> Snap Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Snap Bool) -> IO Bool -> Snap Bool
forall a b. (a -> b) -> a -> b
$ ctx -> IO Bool
forall ctx. IsCtx ctx => ctx -> IO Bool
ctxGetReadOnlyMode ctx
ctx
   Bool -> Snap () -> Snap ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
readOnlyMode Bool -> Bool -> Bool
&& (ReadWriteMode
readWriteMode' ReadWriteMode -> ReadWriteMode -> Bool
forall a. Eq a => a -> a -> Bool
/= ReadWriteMode
PSQL.ReadOnly)) (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$
      CtxErrType ctx -> Snap ()
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap ()) -> CtxErrType ctx -> Snap ()
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx CtxErrType ctx
forall apiErr. ApiErr apiErr => apiErr
apiErr_inReadOnlyMode

   ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransaction_internal ctx
ctx IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode' Connection -> IO Rsp
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
-> (Connection -> IO Rsp)
-> Snap ()
inTransaction_internal ctx
ctx IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode' Connection -> IO Rsp
actionThatReturnsAResponse = do

   let transactMode :: TransactionMode
transactMode = IsolationLevel -> ReadWriteMode -> TransactionMode
PSQL.TransactionMode IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode'
   Rsp
rsp <- IO Rsp -> Snap Rsp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Rsp -> Snap Rsp) -> IO Rsp -> Snap Rsp
forall a b. (a -> b) -> a -> b
$
      (Pool Connection -> (Connection -> IO Rsp) -> IO Rsp
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource (ctx -> Pool Connection
forall ctx. IsCtx ctx => ctx -> Pool Connection
ctxConnectionPool ctx
ctx) ((Connection -> IO Rsp) -> IO Rsp)
-> (Connection -> IO Rsp) -> IO Rsp
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
         ((forall a. IO a -> IO a) -> IO Rsp) -> IO Rsp
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO Rsp) -> IO Rsp)
-> ((forall a. IO a -> IO a) -> IO Rsp) -> IO Rsp
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
            TransactionMode -> Connection -> IO ()
PSQL.beginMode TransactionMode
transactMode Connection
conn
            !Rsp
r <- IO Rsp -> IO Rsp
forall a. IO a -> IO a
restore (Rsp -> Rsp
forall a. NFData a => a -> a
force (Rsp -> Rsp) -> IO Rsp -> IO Rsp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Rsp
actionThatReturnsAResponse Connection
conn)
               IO Rsp -> IO () -> IO Rsp
forall a b. IO a -> IO b -> IO a
`E.onException` Connection -> IO ()
rollback_ Connection
conn
            (case Rsp -> ShouldCommitOrRollback
rspShouldCommit Rsp
r of
               ShouldCommitOrRollback
ShouldCommit -> Connection -> IO ()
PSQL.commit Connection
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
               ShouldCommitOrRollback
ShouldRollback -> Connection -> IO ()
rollback_ Connection
conn
               ) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.onException` Connection -> IO ()
rollback_ Connection
conn -- To be safe. E.g. what if inspecting 'r' errors?
            Rsp -> IO Rsp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rsp
r)
               IO Rsp -> (SomeException -> IO Rsp) -> IO Rsp
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\e :: SomeException
e@(E.SomeException {}) -> Rsp -> IO Rsp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rsp -> IO Rsp) -> Rsp -> IO Rsp
forall a b. (a -> b) -> a -> b
$ CtxErrType ctx -> Rsp
forall ae. ApiErr ae => ae -> Rsp
rspBad (CtxErrType ctx -> Rsp) -> CtxErrType ctx -> Rsp
forall a b. (a -> b) -> a -> b
$
                  ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx (CtxErrType ctx -> CtxErrType ctx)
-> CtxErrType ctx -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ Text -> CtxErrType ctx
forall apiErr. ApiErr apiErr => Text -> apiErr
apiErr_unexpectedError (Text -> CtxErrType ctx) -> Text -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
   ctx -> Rsp -> Snap ()
forall ctx. IsCtx ctx => ctx -> Rsp -> Snap ()
pureRsp ctx
ctx Rsp
rsp

-- | Sometimes you don't need a DB connection at all!
pureRsp :: IsCtx ctx => ctx -> Rsp -> Snap ()
pureRsp :: ctx -> Rsp -> Snap ()
pureRsp ctx
ctx (Rsp ShouldCommitOrRollback
_ RspPayload
payload) = case RspPayload
payload of
   RspPayload
RspPayload_Empty -> ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
Snap.writeBS ByteString
""
   RspPayload_Good x
v -> Value -> Snap ()
forall x. ToJSON x => x -> Snap ()
writeJSON (Value -> Snap ()) -> Value -> Snap ()
forall a b. (a -> b) -> a -> b
$ ctx -> x -> Value
forall ctx x. (IsCtx ctx, ToJSON x) => ctx -> x -> Value
ctx_wrapSuccess ctx
ctx x
v
   RspPayload_Bad e
e -> e -> Snap ()
forall ae. ApiErr ae => ae -> Snap ()
writeApiErr e
e
   RspPayload_Custom Status
httpStatus ByteString
mimeType ByteString
bs -> do
      (Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
Snap.setResponseCode (Int -> Response -> Response) -> Int -> Response -> Response
forall a b. (a -> b) -> a -> b
$
         Status -> Int
HTTP.statusCode Status
httpStatus
      ByteString -> ByteString -> Snap ()
writeLBSSuccess_dontUseThis ByteString
mimeType ByteString
bs

-- Take a look at how postgresql-simple does it:
rollback_ :: Connection -> IO ()
rollback_ :: Connection -> IO ()
rollback_ Connection
conn =
   Connection -> IO ()
PSQL.rollback Connection
conn
      IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` ((\IOError
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) :: IOError -> IO ())

writeLBSSuccess_dontUseThis :: BS.ByteString -> BSL.ByteString -> Snap ()
writeLBSSuccess_dontUseThis :: ByteString -> ByteString -> Snap ()
writeLBSSuccess_dontUseThis ByteString
contentType ByteString
b = do
   (Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$
      CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
Snap.setHeader CI ByteString
"Content-Type" ByteString
contentType
   ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
Snap.writeLBS ByteString
b

writeJSON :: ToJSON x => x -> Snap ()
writeJSON :: x -> Snap ()
writeJSON x
x = do
   (Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$
      CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
Snap.setHeader CI ByteString
"Content-Type" ByteString
"application/json"
   ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
Snap.writeLBS (ByteString -> Snap ()) -> ByteString -> Snap ()
forall a b. (a -> b) -> a -> b
$ x -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (x -> ByteString) -> x -> ByteString
forall a b. (a -> b) -> a -> b
$ x
x

-- | This returns any 'Snap x' so you can use it like a throw anywhere
--     in your snap code
-- 
--   NOTE: if you ever use 's 'withTransaction' (which we don't recommend!)
--     this function has the same caveats as 'finishWith'

errorEarlyCode :: ApiErr ae => ae -> Snap x
errorEarlyCode :: ae -> Snap x
errorEarlyCode ae
err = do
   ae -> Snap ()
forall ae. ApiErr ae => ae -> Snap ()
writeApiErr ae
err
   Snap Response
forall (m :: * -> *). MonadSnap m => m Response
Snap.getResponse Snap Response -> (Response -> Snap x) -> Snap x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> Snap x
forall (m :: * -> *) a. MonadSnap m => Response -> m a
Snap.finishWith
-- Difference with 'pureRsp . rspBad' is that it actually 'finishWith's

-- TODO: alias to 'errorCode'?:
writeApiErr :: ApiErr ae => ae -> Snap ()
writeApiErr :: ae -> Snap ()
writeApiErr (ae -> ErrResult
forall apiErr. ApiErr apiErr => apiErr -> ErrResult
errResult -> (ErrResult Status
httpStatus Value
responseVal)) = do
   (Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
Snap.setResponseCode (Int -> Response -> Response) -> Int -> Response -> Response
forall a b. (a -> b) -> a -> b
$
      Status -> Int
HTTP.statusCode Status
httpStatus
   Value -> Snap ()
forall x. ToJSON x => x -> Snap ()
writeJSON (Value -> Snap ()) -> Value -> Snap ()
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
responseVal

-- | Like (.!?) but returns a 422 error (with 'errorEarly') if the key isn't
--   present
(.!) :: (IsCtx ctx, FromJSON x) => ReqObject ctx -> Text -> Snap x
ro :: ReqObject ctx
ro@(ReqObject ctx
ctx HashMap Text Value
_) .! :: ReqObject ctx -> Text -> Snap x
.! Text
k = (ReqObject ctx
ro ReqObject ctx -> Text -> Snap (Maybe x)
forall ctx x.
(IsCtx ctx, FromJSON x) =>
ReqObject ctx -> Text -> Snap (Maybe x)
.!? Text
k) Snap (Maybe x) -> (Maybe x -> Snap x) -> Snap x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
   Maybe x
Nothing -> CtxErrType ctx -> Snap x
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap x) -> CtxErrType ctx -> Snap x
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx (CtxErrType ctx -> CtxErrType ctx)
-> CtxErrType ctx -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ Text -> CtxErrType ctx
forall apiErr. ApiErr apiErr => Text -> apiErr
apiErr_missingRequestKey Text
k
   Just x
x -> x -> Snap x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x

-- | Get a JSON value from the request object, and give a HTTP 422
--   response ('errorEarly') if the value is malformed (not able to be decoded).
--   If it's not present, don't fail: just give us a Nothing
(.!?) :: (IsCtx ctx, FromJSON x) => ReqObject ctx -> Text -> Snap (Maybe x)
(ReqObject ctx
ctx HashMap Text Value
hm) .!? :: ReqObject ctx -> Text -> Snap (Maybe x)
.!? Text
k = case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k HashMap Text Value
hm of
   Maybe Value
Nothing -> Maybe x -> Snap (Maybe x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe x
forall a. Maybe a
Nothing
   Just Value
v -> case Value -> Result x
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
      JSON.Success x
x -> Maybe x -> Snap (Maybe x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Maybe x
forall a. a -> Maybe a
Just x
x)
      Result x
_ -> CtxErrType ctx -> Snap (Maybe x)
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap (Maybe x))
-> CtxErrType ctx -> Snap (Maybe x)
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx (CtxErrType ctx -> CtxErrType ctx)
-> CtxErrType ctx -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ Text -> Value -> CtxErrType ctx
forall apiErr. ApiErr apiErr => Text -> Value -> apiErr
apiErr_malformedRequestValue Text
k Value
v

data ReqObject ctx
   = ReqObject ctx (HM.HashMap Text JSON.Value)

reqObject :: IsCtx ctx => ctx -> Snap (ReqObject ctx)
reqObject :: ctx -> Snap (ReqObject ctx)
reqObject ctx
ctx = ctx -> Word64 -> Snap (ReqObject ctx)
forall ctx. IsCtx ctx => ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' ctx
ctx Word64
2048

reqObject' :: IsCtx ctx => ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' :: ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' ctx
ctx Word64
size =
   (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
JSON.decode (ByteString -> Maybe Value)
-> Snap ByteString -> Snap (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Snap ByteString
forall (m :: * -> *). MonadSnap m => Word64 -> m ByteString
Snap.readRequestBody Word64
size) Snap (Maybe Value)
-> (Maybe Value -> Snap (ReqObject ctx)) -> Snap (ReqObject ctx)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Value
Nothing -> CtxErrType ctx -> Snap (ReqObject ctx)
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap (ReqObject ctx))
-> CtxErrType ctx -> Snap (ReqObject ctx)
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx CtxErrType ctx
forall apiErr. ApiErr apiErr => apiErr
apiErr_requestNotJSON
      Just (JSON.Object HashMap Text Value
o) -> ReqObject ctx -> Snap (ReqObject ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReqObject ctx -> Snap (ReqObject ctx))
-> ReqObject ctx -> Snap (ReqObject ctx)
forall a b. (a -> b) -> a -> b
$ ctx -> HashMap Text Value -> ReqObject ctx
forall ctx. ctx -> HashMap Text Value -> ReqObject ctx
ReqObject ctx
ctx HashMap Text Value
o
      Just Value
_ -> CtxErrType ctx -> Snap (ReqObject ctx)
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap (ReqObject ctx))
-> CtxErrType ctx -> Snap (ReqObject ctx)
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx CtxErrType ctx
forall apiErr. ApiErr apiErr => apiErr
apiErr_requestNotJSONObject