packages feed

paddle (empty) → 0.1.0.0

raw patch · 24 files changed

+604/−0 lines, 24 filesdep +HsOpenSSLdep +aesondep +basesetup-changed

Dependencies added: HsOpenSSL, aeson, base, base64-bytestring, bytestring, containers, http-api-data, http-client, protolude, scientific, servant, servant-client, servant-client-core, time

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for paddle++## Unreleased changes++* Initial release
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2019 Patrick Chilton and Benaco Ltd++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,10 @@+# Haskell API for [Paddle](https://paddle.com) payments++Implements parts of:++- Paddle.WebHook - [webhooks](https://developer.paddle.com/webhook-reference/intro)+- Paddle.Client - [API](https://developer.paddle.com/api-reference/intro)++## Getting started++TODO: minimal example
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ paddle.cabal view
@@ -0,0 +1,69 @@+cabal-version:  2.2+name:           paddle+version: 0.1.0.0+synopsis:       API to the Paddle payment processor+description:    Please see the README on GitHub at <https://github.com/benaco/paddle#readme>+category:       Web+homepage:       https://github.com/benaco/paddle#readme+bug-reports:    https://github.com/benaco/paddle/issues+author:         Patrick Chilton+maintainer:     chpatrick@gmail.com+copyright:      2019 Patrick Chilton and Benaco Ltd+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/benaco/paddle++library+  exposed-modules:+      Paddle.Amount+      Paddle.Client+      Paddle.Client.CreateModifier+      Paddle.Client.CreateModifierResponse+      Paddle.Client.DeleteModifier+      Paddle.Client.GeneratePayLink+      Paddle.Client.GeneratePayLinkResponse+      Paddle.Client.ListModifier+      Paddle.Client.ListModifierResponse+      Paddle.Client.ListUsers+      Paddle.Client.ListUsersResponse+      Paddle.Client.SubscriptionUsersUpdate+      Paddle.Client.SubscriptionUsersUpdateResponse+      Paddle.Env+      Paddle.FieldModifier+      Paddle.WebHook+      Paddle.WebHook.Signature+      Paddle.WebHook.SubscriptionCreated+      Paddle.WebHook.SubscriptionCancelled+  autogen-modules: Paths_paddle+  other-modules:+      Paths_paddle+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      HsOpenSSL+    , aeson+    , base >=4.7 && <5+    , base64-bytestring+    , bytestring+    , containers+    , http-api-data+    , http-client+    , time+    , protolude+    , scientific+    , servant+    , servant-client+    , servant-client-core+  default-language: Haskell2010+  default-extensions:+    OverloadedStrings+    DeriveGeneric+
+ src/Paddle/Amount.hs view
@@ -0,0 +1,29 @@+module Paddle.Amount +  ( Amount(..)+  ) where++import Protolude hiding (Show)+import Prelude (Show(..), read)+import Data.Scientific+import Data.Aeson.Types (Parser)+import Data.Aeson (FromJSON, ToJSON, toJSON, parseJSON, withText, withScientific, Value(Number))++newtype Amount = Amount { getScientific :: Scientific }++instance Show Amount where+    show = formatScientific Fixed Nothing . getScientific++instance Eq Amount where+    a1 == a2 = getScientific a1 == getScientific a2++instance FromJSON Amount where+    parseJSON value =+          withText "amount" f value+      <|> withScientific "amount" (pure . Amount) value+      where+        f :: Text -> Parser Amount+        -- TODO: use `reads` to `fail` early+        f t = pure $ Amount (read (toS t))++instance ToJSON Amount where+    toJSON = Number . getScientific
+ src/Paddle/Client.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveAnyClass #-}+module Paddle.Client + ( API(..)+ , PaddleError(..)+ , PaddleResponse(..)+ , responseToEither+ , client+ , runClient+ ) where++import           Data.Aeson (FromJSON, parseJSON, (.:), withObject)+import           Protolude +import           Prelude ()+import           Network.HTTP.Client ( Manager )+import           Servant.API+import           Servant.API.Generic+import           Servant.Client hiding (client)+import qualified Servant.Client+import           Servant.Client.Generic+import           Paddle.Client.DeleteModifier (DeleteModifier)+import           Paddle.Client.ListModifier (ListModifier)+import           Paddle.Client.GeneratePayLink (GeneratePayLink)+import           Paddle.Client.GeneratePayLinkResponse (GeneratePayLinkResponse)+import           Paddle.Client.ListModifierResponse (ListModifierResponse)+import           Paddle.Client.CreateModifier (CreateModifier)+import           Paddle.Client.CreateModifierResponse (CreateModifierResponse)+import           Paddle.Client.ListUsers (ListUsers)+import           Paddle.Client.ListUsersResponse (ListUsersResponse)+import           Paddle.Client.SubscriptionUsersUpdate (SubscriptionUsersUpdate)+import           Paddle.Client.SubscriptionUsersUpdateResponse (SubscriptionUsersUpdateResponse)++data PaddleError = PaddleError+  { message :: Text+  , code :: Int +  } deriving (Show, Generic, FromJSON)++instance Exception Paddle.Client.PaddleError++data PaddleResponse a = +  ResponseError PaddleError | ResponseSuccess a+  deriving (Show)++responseToEither :: PaddleResponse a -> Either PaddleError a+responseToEither (ResponseError e) = Left e+responseToEither (ResponseSuccess a) = Right a++instance FromJSON a => FromJSON (PaddleResponse a) where+  parseJSON = withObject "PaddleResponse" $ \v -> do+    isSuccessful <- v .: "success"+    if isSuccessful+    then ResponseSuccess <$> v .: "response"+    else ResponseError <$> v .: "error"++data API route = API+    { modifiersList :: route :-+        "subscription" :>+        "modifiers" :>+        ReqBody '[JSON] ListModifier :>+        Post '[JSON] (PaddleResponse [ListModifierResponse])+    , modifiersCreate :: route :-+        "subscription" :>+        "modifiers" :>+        "create" :>+        ReqBody '[JSON] CreateModifier :>+        Post '[JSON] (PaddleResponse CreateModifierResponse)+    , modifiersDelete :: route :-+        "subscription" :>+        "modifiers" :>+        "delete" :>+        ReqBody '[JSON] DeleteModifier :>+        Post '[JSON] (PaddleResponse (Maybe ())) -- https://github.com/bos/aeson/issues/744+    , productGeneratePayLink :: route :-+        "product" :>+        "generate_pay_link" :>+        ReqBody '[JSON] GeneratePayLink :>+        Post '[JSON] (PaddleResponse GeneratePayLinkResponse)+    , usersList :: route :-+        "subscription" :>+        "users" :>+        ReqBody '[JSON] ListUsers :>+        Post '[JSON] (PaddleResponse [ListUsersResponse])+    , subscriptionUsersUpdate :: route :-+        "subscription" :>+        "users" :>+        "update" :>+        ReqBody '[JSON] SubscriptionUsersUpdate :>+        Post '[JSON] (PaddleResponse SubscriptionUsersUpdateResponse)+    } deriving (Generic)++api :: Proxy (ToServantApi API)+api = genericApi (Proxy :: Proxy API)++client :: API (AsClientT ClientM)+client = fromServant $ Servant.Client.client api++runClient :: Manager -> ClientM a -> IO (Either ClientError a)+runClient httpmanager cmd = do+  (`runClientM` env) cmd+  where+    env :: ClientEnv+    env = Servant.Client.mkClientEnv httpmanager (BaseUrl Https "vendors.paddle.com" 443 "api/2.0")
+ src/Paddle/Client/CreateModifier.hs view
@@ -0,0 +1,19 @@+module Paddle.Client.CreateModifier where++import Data.Aeson (ToJSON, toJSON, genericToJSON)+import Protolude+import Prelude ()+import Paddle.Amount (Amount)+import Paddle.FieldModifier (customJSONOptions)++data CreateModifier = CreateModifier +  { vendorId :: Int+  , vendorAuthCode :: Text+  , subscriptionId :: Text+  , modifierRecurring :: Bool+  , modifierAmount :: Amount+  , modifierDescription :: Maybe Text+  } deriving (Show, Generic)++instance ToJSON CreateModifier where+  toJSON = genericToJSON customJSONOptions
+ src/Paddle/Client/CreateModifierResponse.hs view
@@ -0,0 +1,14 @@+module Paddle.Client.CreateModifierResponse where++import Data.Aeson (FromJSON, parseJSON, genericParseJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+  +data CreateModifierResponse = CreateModifierResponse+  { modifierId :: Integer+  , subscriptionId :: Integer+  } deriving (Show, Generic)++instance FromJSON CreateModifierResponse where+  parseJSON = genericParseJSON customJSONOptions
+ src/Paddle/Client/DeleteModifier.hs view
@@ -0,0 +1,16 @@+module Paddle.Client.DeleteModifier where++import Data.Aeson (ToJSON, toJSON, genericToJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+++data DeleteModifier = DeleteModifier +  { vendorId :: Int+  , vendorAuthCode :: Text+  , modifierId :: Integer+  } deriving (Show, Generic)++instance ToJSON DeleteModifier where+  toJSON = genericToJSON customJSONOptions
+ src/Paddle/Client/GeneratePayLink.hs view
@@ -0,0 +1,17 @@+module Paddle.Client.GeneratePayLink where++import Data.Aeson (ToJSON, toJSON, genericToJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)++data GeneratePayLink = GeneratePayLink +  { vendorId :: Int+  , vendorAuthCode :: Text+  , productId :: Maybe Integer+  , prices :: Maybe [Text]+  , customMessage :: Maybe Text+  } deriving (Show, Generic)++instance ToJSON GeneratePayLink where+  toJSON = genericToJSON customJSONOptions
+ src/Paddle/Client/GeneratePayLinkResponse.hs view
@@ -0,0 +1,13 @@+module Paddle.Client.GeneratePayLinkResponse where++import Data.Aeson (FromJSON, parseJSON, genericParseJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)++data GeneratePayLinkResponse = GeneratePayLinkResponse+  { url :: Text+  } deriving (Show, Generic)++instance FromJSON GeneratePayLinkResponse where+  parseJSON = genericParseJSON customJSONOptions
+ src/Paddle/Client/ListModifier.hs view
@@ -0,0 +1,17 @@+module Paddle.Client.ListModifier where++import Data.Aeson (ToJSON, toJSON, genericToJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+++data ListModifier = ListModifier +  { vendorId :: Int+  , vendorAuthCode :: Text+  , subscriptionId :: Maybe Text+  , planId :: Maybe Text+  } deriving (Show, Generic)++instance ToJSON ListModifier where+    toJSON = genericToJSON customJSONOptions
+ src/Paddle/Client/ListModifierResponse.hs view
@@ -0,0 +1,16 @@+module Paddle.Client.ListModifierResponse where++import Data.Aeson (FromJSON, parseJSON, genericParseJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+import Paddle.Amount++data ListModifierResponse = ListModifierResponse+  { modifierId :: Integer+  , subscriptionId :: Integer+  , amount :: Amount+  } deriving (Show, Generic)++instance FromJSON ListModifierResponse where+  parseJSON = genericParseJSON customJSONOptions
+ src/Paddle/Client/ListUsers.hs view
@@ -0,0 +1,18 @@+module Paddle.Client.ListUsers where++import Data.Aeson (ToJSON, toJSON, genericToJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+++data ListUsers = ListUsers +  { vendorId :: Int+  , vendorAuthCode :: Text+  , subscriptionId :: Maybe Text+  , planId :: Maybe Text+  -- TODO: state, page, resultsPerPage+  } deriving (Show, Generic)++instance ToJSON ListUsers where+    toJSON = genericToJSON customJSONOptions
+ src/Paddle/Client/ListUsersResponse.hs view
@@ -0,0 +1,32 @@+module Paddle.Client.ListUsersResponse where++import Data.Aeson (FromJSON, parseJSON, genericParseJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+import Paddle.Amount++data ListUsersResponse = ListUsersResponse+  { subscriptionId :: Integer+  , planId :: Integer+  , userId :: Integer+  , userEmail :: Text+  , marketingConsent :: Bool+  , lastPayment :: Payment+  , nextPayment :: Maybe Payment+  , updateUrl :: Text+  , cancelUrl :: Text+  -- TODO: state, signup_date, paused_at, paused_from+  } deriving (Show, Generic)++instance FromJSON ListUsersResponse where+  parseJSON = genericParseJSON customJSONOptions++data Payment = Payment+  { amount :: Amount+  , currency :: Text+  , date :: Text+  } deriving (Show, Generic)++instance FromJSON Payment where+  parseJSON = genericParseJSON customJSONOptions
+ src/Paddle/Client/SubscriptionUsersUpdate.hs view
@@ -0,0 +1,21 @@+-- https://developer.paddle.com/api-reference/subscription-api/subscription-users/updateuser+module Paddle.Client.SubscriptionUsersUpdate where++import Data.Aeson (ToJSON, toJSON, genericToJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)+++data SubscriptionUsersUpdate = SubscriptionUsersUpdate +  { vendorId :: Int+  , vendorAuthCode :: Text+  , subscriptionId :: Integer+  , planId :: Maybe Integer+  , prorate :: Maybe Bool+  , pause :: Maybe Bool+  , billImmediately :: Maybe Bool+  } deriving (Show, Generic)++instance ToJSON SubscriptionUsersUpdate where+    toJSON = genericToJSON customJSONOptions
+ src/Paddle/Client/SubscriptionUsersUpdateResponse.hs view
@@ -0,0 +1,16 @@+module Paddle.Client.SubscriptionUsersUpdateResponse where++import Data.Aeson (FromJSON, parseJSON, genericParseJSON)+import Protolude+import Prelude ()+import Paddle.FieldModifier (customJSONOptions)++data SubscriptionUsersUpdateResponse = SubscriptionUsersUpdateResponse+  { subscriptionId :: Integer+  , planId :: Integer+  , userId :: Integer+  -- TODO: nextPayment+  } deriving (Show, Generic)++instance FromJSON SubscriptionUsersUpdateResponse where+  parseJSON = genericParseJSON customJSONOptions
+ src/Paddle/Env.hs view
@@ -0,0 +1,29 @@+module Paddle.Env where++import Prelude ()+import Protolude+import qualified OpenSSL as SSL+import qualified OpenSSL.EVP.PKey as SSL+import qualified OpenSSL.PEM as SSL++data PaddleSecrets = PaddleSecrets+  { paddlePublicKey :: Text -- ^ despite being a public key this must remain secret or anyone who has it can call our webhooks+  , paddleApiKey :: Text+  , paddleVendorId :: Int+  } deriving (Eq)++-- | Various keys for Paddle. These should all be kept secret.+data Env = Env+  { pctxPubKey :: SSL.SomePublicKey+  , pctxVendorId :: Int+  , pctxApiKey :: Text+  } deriving (Eq)++init :: (MonadIO m) => PaddleSecrets -> m Env+init secrets = do+  pubKey <- liftIO $ SSL.withOpenSSL $ SSL.readPublicKey (toS (paddlePublicKey secrets))+  return Env+    { pctxPubKey = pubKey+    , pctxVendorId = paddleVendorId secrets+    , pctxApiKey = paddleApiKey secrets+    }
+ src/Paddle/FieldModifier.hs view
@@ -0,0 +1,17 @@+module Paddle.FieldModifier+  ( modifier+  , customJSONOptions+  ) where++import Data.Aeson+import Protolude+import Prelude ()+import           Data.Char                      (toLower, isUpper)++modifier :: [Char] -> [Char]+modifier = concatMap (\x -> if isUpper x then ['_', toLower x] else [x])++customJSONOptions :: Options+customJSONOptions = defaultOptions+    { fieldLabelModifier = modifier+    }
+ src/Paddle/WebHook.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Paddle.WebHook where+++import           Protolude+import           Prelude ()+import           Servant.API+import           Web.FormUrlEncoded+import Paddle.WebHook.Signature (SignatureBody)+import Paddle.WebHook.SubscriptionCreated (SubscriptionCreated)+import Paddle.WebHook.SubscriptionCancelled (SubscriptionCancelled)+import Paddle.FieldModifier (modifier)++data PaddleWebHook passthrough +  = SubscriptionCreatedWebHook (SubscriptionCreated passthrough)+  | SubscriptionCancelledWebHook (SubscriptionCancelled passthrough)+  | UnknownWebHook Text+  deriving (Generic, Show)++-- TODO: validate request body using http://hackage.haskell.org/package/servant-0.16.2/docs/Servant-API-WithNamedContext.html+instance FromHttpApiData passthrough => FromForm (PaddleWebHook passthrough, SignatureBody) where+  fromForm form = +    lookupUnique "alert_name" form >>= (\name -> liftA2 (,) (toWebHook name) signatureBody)+    where+      signatureBody :: Either Text SignatureBody+      signatureBody = fromForm form++      formOptions :: FormOptions+      formOptions =+        defaultFormOptions +          { fieldLabelModifier = modifier+          }++      toWebHook :: Text -> Either Text (PaddleWebHook passthrough)+      toWebHook "subscription_created" = SubscriptionCreatedWebHook <$> genericFromForm formOptions form+      toWebHook "subscription_cancelled" = SubscriptionCancelledWebHook <$> genericFromForm formOptions form+      toWebHook name = Right $ UnknownWebHook name++type API passthrough+    = ReqBody '[FormUrlEncoded] (PaddleWebHook passthrough, SignatureBody)+    :> Post '[JSON] NoContent++api :: Proxy (API passthrough)+api = Proxy
+ src/Paddle/WebHook/Signature.hs view
@@ -0,0 +1,48 @@+module Paddle.WebHook.Signature where ++import Prelude ()+import qualified Prelude+import Protolude hiding (toS)+import Protolude.Conv+import qualified Data.Map.Strict as M+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import qualified OpenSSL as SSL+import qualified OpenSSL.EVP.Digest as SSL+import qualified OpenSSL.EVP.Verify as SSL+import qualified Data.ByteString.Base64 as Base64++import Paddle.Env (Env(..))++type SignatureBody = M.Map Text [Text]++-- Given all fields in webhook request, validate against their signature+validateSignature :: (MonadIO m) => Env -> SignatureBody -> m (Either Text ())+validateSignature env rawFields =+  let +    fields =  M.fromList $ map (\(k ,v) -> (toS k, toS (maybe "" identity (head v)))) (M.toList rawFields)++    signature :: Either Prelude.String ByteString+    signature = maybeToEither "Missing signature field." (M.lookup "p_signature" fields)++    signatureDecode :: ByteString -> Either Prelude.String ByteString+    signatureDecode = Base64.decode . toS++    -- we need to verify the signature against the PHP-serialized request parameters (excluding p_signature)+    -- here's a gist that does it in Swift: https://gist.github.com/drewmccormack/a51b18ffeda8f596a11a8623481344d8+    serializeString str = "s:" <> BSB.intDec (BS.length str) <> ":\"" <> BSB.byteString str <> "\";"+    serialize sig = (\x -> Right (x, sig)) <$> LBS.toStrict $ BSB.toLazyByteString $+            "a:" <> BSB.intDec (M.size fields - 1) <> ":{" <>+              foldMap (\( key, value ) -> serializeString key <> serializeString value) (M.toAscList $ M.delete "p_signature" fields)+            <> "}"+  in do+    case signature >>= signatureDecode >>= serialize of+      Left err -> return $ Left (toS err)+      Right (serializedFields, sigBytes) -> liftIO $ SSL.withOpenSSL $ do+        Just sha1 <- SSL.getDigestByName "SHA1"+        verifyRes <- SSL.verifyBS sha1 sigBytes (pctxPubKey env) serializedFields++        if (verifyRes == SSL.VerifySuccess)+        then return $ Right ()+        else return $ Left "Request has invalid signature"
+ src/Paddle/WebHook/SubscriptionCancelled.hs view
@@ -0,0 +1,12 @@+-- https://developer.paddle.com/webhook-reference/subscription-alerts/subscription-cancelled+module Paddle.WebHook.SubscriptionCancelled where++import Protolude+import Prelude ()++data SubscriptionCancelled passthrough = SubscriptionCancelled+  { subscriptionId :: Text+  , subscriptionPlanId :: Text+  , cancellationEffectiveDate :: Text+  , passthrough :: passthrough+  } deriving (Generic, Show)
+ src/Paddle/WebHook/SubscriptionCreated.hs view
@@ -0,0 +1,27 @@+module Paddle.WebHook.SubscriptionCreated where++import Protolude+import Prelude ()++{-+data SubscriptionStatus =+    Active | Trialing | PastDue | Deleted+    deriving (Show, Eq)++instance FromHttpApiData SubscriptionStatus where+  where+    parseUrlPiece = ++instance FromForm SubscriptionStatus where+  fromForm form = +    Left (trace ("form" :: Text) $ show form) -- TODO+-}++data SubscriptionCreated passthrough = SubscriptionCreated+  { subscriptionId :: Text+  , subscriptionPlanId :: Text+  , updateUrl :: Text+  , cancelUrl :: Text+  --, status :: SubscriptionStatus+  , passthrough :: passthrough+  } deriving (Generic, Show)