{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-}
module Stripe.Wreq
(
get, get', Get (..)
, post, post', Post (..)
, delete, delete', Delete (..)
, WreqResponse, Response (..)
, wreqResponse, responseValue, responseValueError
, Error (..), UserMessage (..), LogMessage (..), userError, logError
, StatusCode (..)
, isSuccess, isError, isClientError, isServerError
, badRequest400, unauthorized401, requestFailed402
, notFound404, conflict409, tooManyRequests429
, FormParam (..), Session, Network.Wreq.Session.newAPISession
) where
import qualified Data.Aeson
import qualified Control.Exception
import Control.Monad ((>=>))
import qualified Data.Bifunctor
import qualified Data.Semigroup
import Data.String (fromString)
import Prelude hiding (userError)
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import Control.Lens ((&), (.~), (?~), (^.), (<>~))
import Stripe.Concepts (ApiSecretKey (..), RequestApiVersion (..), ApiVersion (..))
import Data.Text (Text)
import qualified Data.Text
import qualified Data.HashMap.Strict
import Network.Wreq (FormParam (..))
import qualified Network.Wreq
import Network.Wreq.Session (Session)
import qualified Network.Wreq.Session
newtype StatusCode = StatusCode Int deriving Eq
isSuccess :: StatusCode -> Bool
isSuccess (StatusCode x) = x >= 200 && x < 300
isError :: StatusCode -> Bool
isError (StatusCode x) = x >= 400 && x < 600
isClientError :: StatusCode -> Bool
isClientError (StatusCode x) = x >= 400 && x < 500
isServerError :: StatusCode -> Bool
isServerError (StatusCode x) = x >= 500 && x < 600
badRequest400 :: StatusCode
badRequest400 = StatusCode 400
unauthorized401 :: StatusCode
unauthorized401 = StatusCode 401
requestFailed402 :: StatusCode
requestFailed402 = StatusCode 402
notFound404 :: StatusCode
notFound404 = StatusCode 404
conflict409 :: StatusCode
conflict409 = StatusCode 409
tooManyRequests429 :: StatusCode
tooManyRequests429 = StatusCode 429
data Get =
Get
{ getPath :: [Text]
, getParams :: [(Text, Text)]
}
data Post =
Post
{ postPath :: [Text]
, postParams :: [FormParam]
}
data Delete =
Delete
{ deletePath :: [Text]
, deleteParams :: [(Text, Text)]
}
get :: Session -> ApiSecretKey -> Get -> IO WreqResponse
get session key x = get' session key DefaultApiVersion x
get' :: Session -> ApiSecretKey -> RequestApiVersion -> Get -> IO WreqResponse
get' session key v x = Network.Wreq.Session.getWith opts session url
where
url = makeUrl (getPath x)
opts = wreqDefaults & Network.Wreq.auth ?~ auth key
& Network.Wreq.params .~ (getParams x)
& Network.Wreq.headers <>~ (requestApiVersionHeaders v)
post :: Session -> ApiSecretKey -> Post -> IO WreqResponse
post session key x = post' session key DefaultApiVersion x
post' :: Session -> ApiSecretKey -> RequestApiVersion -> Post -> IO WreqResponse
post' session key v x = Network.Wreq.Session.postWith opts session url params
where
url = makeUrl (postPath x)
params = postParams x
opts = wreqDefaults & Network.Wreq.auth ?~ auth key
& Network.Wreq.headers <>~ (requestApiVersionHeaders v)
delete :: Session -> ApiSecretKey -> Delete -> IO WreqResponse
delete session key x = delete' session key DefaultApiVersion x
delete' :: Session -> ApiSecretKey -> RequestApiVersion -> Delete -> IO WreqResponse
delete' session key v x = Network.Wreq.Session.deleteWith opts session url
where
url = makeUrl (deletePath x)
opts = wreqDefaults & Network.Wreq.auth ?~ auth key
& Network.Wreq.params .~ (deleteParams x)
& Network.Wreq.headers <>~ (requestApiVersionHeaders v)
urlBase :: Text
urlBase = Data.Text.pack "https://api.stripe.com/v1"
makeUrl :: [Text] -> String
makeUrl =
Data.Text.unpack
. Data.Text.intercalate (Data.Text.pack "/")
. (urlBase :)
wreqDefaults :: Network.Wreq.Options
wreqDefaults = Network.Wreq.defaults & noCheckResponse
requestApiVersionHeaders DefaultApiVersion = []
requestApiVersionHeaders (OverrideApiVersion v) = [apiVersionHeader v]
apiVersionHeader (ApiVersion v) = (name, value)
where
name = fromString "Stripe-Version"
value = fromString (Data.Text.unpack v)
noCheckResponse :: Network.Wreq.Options -> Network.Wreq.Options
noCheckResponse = Network.Wreq.checkResponse ?~ (\_ _ -> return ())
auth :: ApiSecretKey -> Network.Wreq.Auth
auth (ApiSecretKey key) = Network.Wreq.basicAuth key Data.ByteString.empty
newtype UserMessage = UserMessage Text deriving (Eq, Show)
newtype LogMessage = LogMessage Text deriving (Eq, Show)
data Error =
Error
{ userMessages :: [UserMessage]
, logMessages :: [LogMessage]
}
deriving (Eq, Show)
instance Data.Semigroup.Semigroup Error
where
Error x y <> Error x' y' =
Error
((Data.Semigroup.<>) x x')
((Data.Semigroup.<>) y y')
instance Monoid Error
where
mappend = (Data.Semigroup.<>)
mempty = Error mempty mempty
instance Control.Exception.Exception Error
userError
:: Text
-> Error
userError x = Error { userMessages = [UserMessage x], logMessages = [] }
logError
:: Text
-> Error
logError x = Error { userMessages = [], logMessages = [LogMessage x] }
type WreqResponse = Network.Wreq.Response Data.ByteString.Lazy.ByteString
data Response =
Response
{ responseBody :: Either Text Data.Aeson.Value
, responseCode :: StatusCode
}
wreqResponse :: WreqResponse -> Response
wreqResponse r =
Response
{ responseBody =
r ^. Network.Wreq.responseBody
& Data.Aeson.eitherDecode
& Data.Bifunctor.first Data.Text.pack
, responseCode =
r ^. Network.Wreq.responseStatus
. Network.Wreq.statusCode
& StatusCode
}
responseValue :: Response -> Either Error Data.Aeson.Value
responseValue r =
case (responseBody r) of
Left e -> Left (logError e)
Right val ->
case isSuccess (responseCode r) of
True -> Right val
False -> Left (responseValueError val)
responseValueError :: Data.Aeson.Value -> Error
responseValueError val
| isCardError = foldMap userError (msg val)
| otherwise = foldMap logError (msg val)
where
isCardError = typ val == Just (Data.Text.pack "card_error")
msg = aesonAttr "error" >=> aesonAttr "message" >=> aesonText
typ = aesonAttr "error" >=> aesonAttr "type" >=> aesonText
aesonAttr :: String -> Data.Aeson.Value -> Maybe Data.Aeson.Value
aesonAttr x = aesonObject >=> Data.HashMap.Strict.lookup (Data.Text.pack x)
aesonObject :: Data.Aeson.Value -> Maybe Data.Aeson.Object
aesonObject (Data.Aeson.Object x) = Just x
aesonObject _ = Nothing
aesonText :: Data.Aeson.Value -> Maybe Text
aesonText (Data.Aeson.String x) = Just x
aesonText _ = Nothing