Processing.hs

{-# LANGUAGE TemplateHaskell #-}

module PayPal.Adaptive.Core.Processing where

import qualified Data.Text as T

import           Import
import           PayPal.Adaptive.Core.PayResponse

-- | A version of 'PayResponse' for completed transactions.
--
-- Status fields are omitted since they should be complete.
--
-- Has no separate field for a 'PaymentInfo' list since successful transactions
-- will always have exactly one. Instead the pay info fields have been
-- flattened into the top level of this structure.
data CompletePayResponse = CompletePayResponse
  { _cpPayKey              :: PayKey
  , _cpReceiver            :: Receiver
  , _cpTransactionId       :: TransactionId
  , _cpSenderTransactionId :: TransactionId
  } deriving (Eq, Show)

-- | A high level data type that tries to summarize the status
-- of a payment in simple terms (meant to be used in an 'Either',
-- e.g. 'Either' 'NotComplete' 'CompletePayResponse').
data NotComplete
  = NcIncomplete      Text
  | NcFailed          Text
  | NcShouldNotHappen Text
  deriving (Eq, Show)

checkComplete :: PayResponse -> Either NotComplete CompletePayResponse
checkComplete pr = do
  payStatusCompleted pr
  info <- getPaymentInfo pr
  sid <- transactionIdJust (_piSenderTransactionId info)
  transactionStatusCompleted (_piTransactionStatus info)
  transactionStatusCompleted (_piSenderTransactionStatus info)
  tid <- transactionIdJust (_piTransactionId info)
  errorFieldNothing pr
  return $ CompletePayResponse (_prPayKey pr) (_piReceiver info) sid tid
  where
    transactionIdJust :: Maybe TransactionId -> Either NotComplete TransactionId
    transactionIdJust Nothing = Left $ NcShouldNotHappen "expected a Just for Maybe TransactionId"
    transactionIdJust (Just tid) = Right tid

    errorFieldNothing :: PayResponse -> Either NotComplete ()
    errorFieldNothing a
      | _prPayError a == Nothing = Right ()
      | otherwise                =
        Left $ NcShouldNotHappen "PayResponse error field is Just in otherwise correct payment"

    transactionStatusCompleted :: Maybe TransactionStatus -> Either NotComplete ()
    transactionStatusCompleted Nothing       = Left (NcShouldNotHappen "TransactionStatus is Nothing")
    transactionStatusCompleted (Just status) =
      let msg = "TransactionStatus " <> T.pack (show status)
      in case status of
        TsCreated           -> Left (NcIncomplete msg)
        TsPending           -> Left (NcIncomplete msg)
        TsProcessing        -> Left (NcIncomplete msg)
        TsCompleted         -> Right ()
        TsDenied            -> Left (NcFailed msg)
        TsFailed            -> Left (NcFailed msg)
        TsRefunded          -> Left (NcShouldNotHappen msg)
        TsPartiallyRefunded -> Left (NcShouldNotHappen msg)
        TsReversed          -> Left (NcShouldNotHappen msg)

    payStatusCompleted :: PayResponse -> Either NotComplete ()
    payStatusCompleted a =
      let status = _prPayStatus a
          msg = "_prPayStatus: " <> T.pack (show status)
      in case status of
        PeCreated       -> Left (NcIncomplete msg)
        PeCompleted     -> Right ()
        PePending       -> Left (NcIncomplete msg)
        PeProcessing    -> Left (NcIncomplete msg)
        PeIncomplete    -> Left (NcShouldNotHappen msg) -- PeIncomplete has to do with delayed or chained
                                                        -- payments, which we don't support.
        PeExpired       -> Left (NcFailed msg)
        PeError         -> Left (NcFailed msg)
        PeReversalError -> Left (NcShouldNotHappen msg)

getPaymentInfo :: PayResponse -> Either NotComplete PaymentInfo
getPaymentInfo a =
  case _prPaymentInfos a of
    []     -> Left $ NcIncomplete "no PaymentInfo"
    [info] -> Right info
    _      -> Left $ NcShouldNotHappen "more than one PaymentInfo"

$(makeLenses ''CompletePayResponse)
$(makePrisms ''NotComplete)