paypal-adaptive-hoops-0.10.0.0: Example.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Prelude             hiding (getLine, lookup, putStr, putStrLn)
import           Data.Default
import           Data.Text           (Text)
import           Data.Text.IO
import qualified Web.PayPal.Adaptive as PP

-- You need to create a sandbox app on PayPal and enter its credentials
-- below for this app to run.
--
-- Also, the email associated with the sandbox app will need at least
-- a dollar in its sandbox account.
userId, password, sig, accountEmail :: Text
userId       = "foo_api1.example.com"
password     = "bar"
sig          = "baz"
accountEmail = "foo@example.com"

-- You must also create a sandbox user on PayPal. Enter its email here.
-- This is the account we'll be sending money to and from.
sandboxTestUser :: Text
sandboxTestUser = "user@mail.com"

main :: IO ()
main = do
  putStrLn "-- Sending money to another PayPal account."
  PP.toPayPal client withdrawal >>= print
  putStrLn ""

  putStrLn "-- Creating a payment from another account to us."
  r <- PP.toPayPal client deposit
  print r
  putStrLn ""
  case r of
    Left _        -> putStrLn "Stopping on payment creation failure."
    Right payResp -> do
      let payKey = PP._prPayKey payResp
      putStrLn "-- Go here and use the other account's password to approve the payment:"
      putStrLn $ PP.approvalUrl client payKey
      putStrLn ""
      putStrLn "-- Once that's done press enter ..."
      _ <- getLine

      putStrLn "-- Now looking up the payment on PayPal to make sure it succeeded."
      lookupAttempt <- PP.toPayPal client (PP.LookupPayKey payKey)
      case lookupAttempt of
        Right lookupResp ->
          case PP._prPayInfo lookupResp of
            [info] -> do
              case PP._piTransactionStatus info of
                Just PP.TsCompleted -> putStrLn "Withdrawal complete."
                _ -> do
                  putStrLn "The payment has not gone through yet. Expected the PayInfo in"
                  putStrLn "the response to have a _piTransactionStatus of Just TsCompleted:"
                  putStrLn ""
                  print lookupResp
            _      -> do
              putStrLn "The payment has not gone through yet."
              putStrLn "Expected exactly one PayInfo in the response:"
              putStrLn ""
              print lookupResp
        Left lookupError -> do
          putStrLn "Error getting information about the payment:"
          putStrLn ""
          print lookupError

client :: PP.Client
client = PP.Client
  { PP._clAppId        = "APP-80W284485P519543T" -- Currently the ID for all sandbox apps.
  , PP._clUserId       = userId
  , PP._clEnv          = PP.Sandbox
  , PP._clPassword     = password
  , PP._clSig          = sig
  , PP._clAccountEmail = accountEmail
  }

withdrawal :: PP.Withdrawal
withdrawal = def
  { PP._wdAmount = PP.USD 100
  , PP._wdReceiverEmail = sandboxTestUser
  }

deposit :: PP.Deposit
deposit = def
  { PP._dpAmount = PP.USD 100
  , PP._dpSenderEmail = sandboxTestUser
  }