Paynow.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}

module Network.Payments.Paynow
  ( 
    newPaynowClient,
    defaultProdConfig,
    PaynowConfig (..),
    PaynowClient (..),
    PaynowTransaction (..),
    Checkout (..),
    PaynowTXResult (..),
    PaymentMethod (..),
    TxData (..),
    PaynowError(..),
    PaynowTXPayload (..),
    Status(..),
    BillingAddress (..),
    Card (..),
    PhoneNumber,
    Email,
    Amount,
    Ref,
    PaynowRef,
    PaynowIntegrationID,
    PaynowIntegrationKey,
    PaynowResultURL,
    PaynowReturnURL,
    Hash,
    RedirectURL,
    PollURL,
    VMC (..),
    serverResponseToResult,
    sha1Hex,
  )
where

import UnliftIO.Exception
import UnliftIO
import qualified Crypto.Hash as C
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Map as M
import Data.List (sort)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Text hiding (zip, filter, foldr)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Base (urlDecode, urlEncodeVars)
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Simple

prodPaynowEndpoint :: Text
prodPaynowEndpoint = "https://www.paynow.co.zw/interface/"


-- | Additional data to be sent with the transaction
data TxData = TxData
  { tAdditionalInfo :: Maybe Text,
    tResultURL :: Maybe PaynowResultURL,
    tReturnURL :: Maybe PaynowReturnURL
  }

instance ToKeyMap (Maybe TxData) where
  toKeyMap Nothing = []
  toKeyMap (Just (TxData {..})) = foldr 
    (\(k, v) accum -> if (isJust v) then (k, fromMaybe "" v) : accum else accum )
    []
    [("additionalinfo", tAdditionalInfo), ("returnurl", tReturnURL), ("resulturl", tResultURL)]

class ToKeyMap a where
  toKeyMap :: a -> [(Text, Text)]


-- Type aliases used to make documentation more readable
type PhoneNumber = Text
type Email = Text
type Amount = Double
type PaynowRef = Text
type Instructions = Text

data Status = Created | Error | Cancelled | Paid | Okay | Refunded | Failed | OtherStatus Text deriving (Show, Eq)
type PollURL = Text
type RedirectURL = Text
type Hash = Text
type Ref = Text

type PaynowIntegrationID = Text
type PaynowIntegrationKey = Text
type PaynowResultURL = Text
type PaynowReturnURL = Text


-- | Card Details
data Card = Card {cardNumber :: !Text, cardCVV :: !Text, cardExpiry :: !Text, cardName :: !Text} deriving (Show)

-- | ToKeyMap typeclass
instance ToKeyMap Card where
  toKeyMap Card {..} = [("cardnumber", cardNumber), ("cardname", cardName), ("cardcvv", cardCVV), ("cardexpiry", cardExpiry)]

-- | Billing Address
data BillingAddress = BillingAddress {baAddressLine1 :: !Text, baAddressLine2 :: !Text, baCity :: !Text, baCountry :: !Text, baProvince :: Maybe Text} deriving (Show)

instance ToKeyMap BillingAddress where
  toKeyMap BillingAddress {..} =
    [("billingline1", baAddressLine1), ("billingline2", baAddressLine2), ("billingcity", baCity), ("billingprovince", fromMaybe "" baProvince), ("billingcountry", baCountry)]

-- | Visa Mastercard Details
data VMC = VMC Card BillingAddress deriving (Show)

instance ToKeyMap VMC where
  toKeyMap (VMC card address) = (toKeyMap card) <> (toKeyMap address)

-- | Ecocash, OneMoney, VisaMastercard payment methods
data PaymentMethod = Ecocash PhoneNumber | OneMoney PhoneNumber | VisaMastercard VMC deriving (Show)

instance ToKeyMap PaymentMethod where
  toKeyMap (Ecocash phone) = [("phone", phone), ("method", "ecocash")]
  toKeyMap (OneMoney phone) = [("phone", phone), ("method", "onemoney")]
  toKeyMap (VisaMastercard vmcd) = toKeyMap vmcd

-- | Checkout type
data Checkout = ExpressCheckout PaymentMethod | ClassicCheckout deriving (Show)

instance ToKeyMap Checkout where
  toKeyMap ClassicCheckout = []
  toKeyMap (ExpressCheckout method) = toKeyMap method

data PaynowError = ServerError | InternalError | UnHandledException SomeException | OtherError Text deriving (Show)

-- |
-- | PaynowTXResult is the result of a transaction
-- | 
data PaynowTXResult = 
  InitExpressPaymentSuccess Status PaynowRef Instructions PollURL  Hash | 
  InitClassicCheckoutSuccess Status RedirectURL PollURL Hash  |
  PollPaymentSuccess Status PaynowRef Ref Amount PollURL Hash  |
  VerifySignatureSuccess deriving (Show, Eq)

-- |
--  PaynowTransaction is the type of transaction to be performed.
--
--  InitPayment: Initialize a payment
--  PollPayment: Poll for the status of a payment
--  VerifyStatusUpdate: Verify the authenticity of a status update
data PaynowTransaction = InitPayment Ref Amount Email Checkout (Maybe TxData) | PollPayment PollURL | VerifyStatusUpdate [(Text, Text)]

statusMessage :: [(Text, Text)]
statusMessage = [("status", "Message")]

-- | Ordering of keys for hashing and form body
txOrdering :: [Text]
txOrdering = ["resulturl", "returnurl", "reference", "amount", "id", "additionalinfo", "authemail", "phone", "method", "status", "hash"]

orderTXKeyMap :: [(Text, Text)] -> [(Text, Text)]
orderTXKeyMap l =
  catMaybes $ (\k -> (k,) <$> M.lookup k m) <$> txOrdering
  where
    m :: M.Map Text Text
    m = M.fromList l

instance ToKeyMap PaynowTransaction where
  toKeyMap (InitPayment ref amount email checkout mTxData) =
    orderTXKeyMap $ statusMessage <> [("reference", ref), ("amount", T.pack $ show amount), ("authemail", email)] <> (toKeyMap checkout) <> (toKeyMap mTxData)
  toKeyMap (PollPayment _) = statusMessage
  toKeyMap _ = statusMessage

class PaynowTXPayload a where
  urlParamsWithHash :: a -> PaynowConfig -> (Hash, Text)
  hash :: a -> PaynowConfig -> Text

urlEncodeT :: [(Text, Text)] -> Text
urlEncodeT tple = T.pack $ urlEncodeVars $ (\(k, v) -> (T.unpack k, T.unpack v)) <$> tple

sha1Hex :: Text -> Hash
sha1Hex t =
  T.toUpper $ T.decodeUtf8 $ (C.digestToHexByteString (C.hash (T.encodeUtf8 t) :: C.Digest C.SHA512))

instance PaynowTXPayload PaynowTransaction where
  hash tx config =
    sha1Hex $ (intercalate "" ((snd) <$> (orderTXKeyMap $ toKeyMap config <> toKeyMap tx))) <> (pncIntegrationKey config)

  urlParamsWithHash tx config =
    (hashed, urlEncodeT $ orderTXKeyMap ((toKeyMap config <> toKeyMap tx <> [("hash", hashed)])))
    where
      hashed :: Text
      hashed = hash tx config

-- |
--  PaynowConfig is the configuration for the Paynow API.
--  For more details, see https://www.paynow.co.zw/docs/api/
--
--  pncEndpoint: The endpoint to use for the API
--  pncIntegrationID: The integration ID for the API
--  pncIntegrationKey: The integration key for the API
--  pncResultURL: The URL to redirect to after a transaction is completed
--  pncReturnURL: The URL to redirect to after a transaction is completed
data PaynowConfig = PaynowConfig
  { pncEndpoint :: !Text,
    pncIntegrationID :: !PaynowIntegrationID,
    pncIntegrationKey :: !PaynowIntegrationKey,
    pncResultURL :: !PaynowResultURL,
    pncReturnURL :: !PaynowReturnURL
  }
  deriving (Show)

checkoutEndpoint :: PaynowConfig -> Checkout -> Text
checkoutEndpoint PaynowConfig {..} ClassicCheckout =
  pncEndpoint <> "initiatetransaction"
checkoutEndpoint PaynowConfig {..} (ExpressCheckout _) =
  pncEndpoint <> "remotetransaction"

instance ToKeyMap PaynowConfig where
  toKeyMap PaynowConfig {..} =
    [("id", pncIntegrationID), ("resulturl", pncResultURL), ("returnurl", pncReturnURL)]

-- |
-- | A PaynowClient is a client for the Paynow API. It contains the following functions:
-- | - newExpressCheckout: Create a new express checkout transaction (mobile or visa mastercard)
-- | - newClassicCheckout: Create a new classic checkout transaction (user will be redirected to url to complete payment)
-- | - newPollPayment: Create a new poll payment transaction (poll for the status of a payment)
-- | - newVerifyStatusUpdate: Create a new verify status update transaction (verify the authenticity of a status update)
-- | - processTx: Process a transaction, sends an HTTP request to the Paynow API
-- | - txHash: Get the hash of a transaction
data PaynowClient m = PaynowClient
  { newExpressCheckout :: PaymentMethod -> Ref -> Amount -> Email -> Maybe TxData -> m PaynowTransaction,
    newClassicCheckout :: Ref -> Amount -> Email -> Maybe TxData -> m PaynowTransaction,
    newPollPayment :: PollURL -> m PaynowTransaction,
    newVerifyStatusUpdate :: [(Text, Text)] -> m PaynowTransaction,
    processTx :: PaynowTransaction -> m (Either PaynowError PaynowTXResult),
    txHash :: PaynowTransaction -> m Text
  }

-- | The default configuration for the Paynow production API
defaultProdConfig :: PaynowIntegrationID -> PaynowIntegrationKey -> PaynowResultURL -> PaynowReturnURL -> PaynowConfig
defaultProdConfig apiID apiSecret = PaynowConfig prodPaynowEndpoint apiID apiSecret



-- |
--  Create a new PaynowClient with the given configuration.
-- @
-- client <- newPaynowClient config
-- payment <- newExpressCheckout (Ecocash "0779800700") "45" 37.50 Nothing
-- result <- processTx payment
-- case result of
--    PaynowError e => //handle err
--    PaynowTxResult r => //handle result
-- @
newPaynowClient :: forall m. (MonadUnliftIO m) => PaynowConfig -> (PaynowClient m)
newPaynowClient config =
  PaynowClient {..}
  where
    newExpressCheckout method ref amount email mTXData =
      pure $ InitPayment ref amount email (ExpressCheckout method) mTXData

    newClassicCheckout ref amount email mTXData =
      pure $ InitPayment ref amount email ClassicCheckout mTXData

    newPollPayment = pure . PollPayment

    newVerifyStatusUpdate = pure . VerifyStatusUpdate

    txHash = pure . fst . (`urlParamsWithHash` config)

    processTx tx = processTxHandler `handleAny` case tx of
      InitPayment _ _ _ checkout _ -> do
        r <- pure $ parseRequest_ $ T.unpack $ "POST " <> (checkoutEndpoint config checkout)
        let req = addRequestHeader hContentType "application/x-www-form-urlencoded" $  setRequestBodyLBS (BS.pack $ T.unpack $ snd $ urlParamsWithHash tx config) r
        response <- httpLBS req
        let body = T.pack . BS.unpack $ getResponseBody response
        case getResponseStatusCode response of
          200 -> pure $ serverResponseToResult body
          _ -> pure $ Left $ ServerError
      PollPayment url -> do
        req <- pure $ parseRequest_ $ T.unpack $ "GET " <> url
        response <- httpLBS req
        case getResponseStatusCode response of
          200 -> 
            pure $ serverResponseToResult (T.pack . BS.unpack $ getResponseBody response)
          _ -> pure $ Left $ ServerError
      VerifyStatusUpdate _ -> 
        pure $ Left $ OtherError "not yet implemented"

    
    processTxHandler :: (MonadUnliftIO m) => SomeException -> m (Either PaynowError PaynowTXResult)
    processTxHandler ex = pure $ Left $ UnHandledException ex


serverResponseToResult :: Text -> Either PaynowError PaynowTXResult
serverResponseToResult resp = case ( sort $ M.keys kvp) of
--  InitExpressPaymentSuccess Status PaynowRef Instructions PollURL  Hash  
  ["hash", "instructions", "paynowreference", "pollurl", "status"] -> 
    Right $ InitExpressPaymentSuccess (ls "status") (l "paynowreference") (l "instructions") (l "pollurl") (l "hash")
--  InitClassicCheckoutSuccess Status RedirectURL PollURL Hash  
  ["browserurl", "hash", "pollurl", "status"] -> 
    Right $ InitClassicCheckoutSuccess (ls "status") (l "browserurl") (l "pollurl") (l "hash")
--  PollPaymentSuccess Status PaynowRef Ref Amount PollURL Hash  
  ["amount", "hash", "paynowreference", "pollurl", "reference", "status"] -> 
    Right $ PollPaymentSuccess (ls "status") (l "paynowreference") (l "reference") (la "amount") (l "pollurl") (l "hash")
  _ -> Left $ OtherError resp
  
  where
    l :: Text -> Text
    l k = fromMaybe "" $ M.lookup k kvp

    la :: Text -> Amount
    la k =  (read . T.unpack . fromMaybe "0" $ M.lookup k kvp) :: Amount

    ls :: Text -> Status
    ls t = case (T.toLower $ l t) of
      "paid" -> Paid
      "created" -> Created
      "ok" -> Okay
      "cancelled" -> Cancelled
      "failed" -> Failed
      "error" -> Error
      "refunded" -> Refunded
      other -> OtherStatus other
    

    kvp :: M.Map Text Text
    kvp = M.fromList $ (\t -> explode $ splitOn "=" t) <$> splitOn "&" resp

    explode :: [Text] -> (Text, Text)
    explode [] = ("", "")
    explode [k] = (k, "")
    explode [k, v] = (k, T.pack . urlDecode $ T.unpack v)
    explode (k : vs) = (k, T.pack . urlDecode $ T.unpack $ T.unwords vs)