{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

module Web.PayPal.Adaptive.Core where

import           Prelude              hiding (mapM)
import           Control.Applicative
import           Control.Exception
import           Control.Lens         hiding ((.=))
import           Control.Monad        ((>=>))
import           Data.Aeson
import           Data.Aeson.TH        hiding (Options)
import           Data.Aeson.Types     hiding (Options)
import           Data.ByteString.Lazy (ByteString)
import           Data.Char
import           Data.Default
import           Data.Maybe
import           Data.Monoid
import           Data.Text            (Text)
import qualified Data.Text            as T
import           Data.Text.Read
import           Data.Text.Encoding
import           Data.Traversable
import qualified Data.Vector          as V
import           Network.HTTP.Client  (HttpException (NoResponseDataReceived))
import           Network.Wreq

--------------------------------------------------
-- Client
--------------------------------------------------

data PpClient = PpClient
  { _clAppId    :: Text
  , _clEnv      :: PpEnv
  , _clPassword :: Text
  , _clSig      :: Text
  , _clUserId   :: Text
  } deriving (Eq, Show)

data PpEnv = PpSandbox | PpProduction deriving (Eq, Show, Read)

--------------------------------------------------
-- API class
--------------------------------------------------

class AdaptiveAPI a where
  toPayPal :: PpClient -> a -> IO (Either AdaptiveErr PayResp)

-- | Exported by Web.PayPal.Adaptive.Internal
ppPost :: (ToJSON a) => PpClient -> Text -> a -> IO (Either AdaptiveErr (Response ByteString))
ppPost c endpoint p = catch (return . Right =<< runPost) handler
  where
    runPost :: IO (Response ByteString)
    runPost = postWith opts (clBaseUrl <> T.unpack endpoint) (toJSON p)

    clBaseUrl :: String
    clBaseUrl =
      case _clEnv c of
        PpSandbox    -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"
        PpProduction -> "https://svcs.paypal.com/AdaptivePayments/"

    handler :: HttpException -> IO (Either AdaptiveErr (Response ByteString))
    handler NoResponseDataReceived = return (Left AeNoResponse)
    handler e = return . Left . AeConnectionErr . T.pack . show $ e

    opts :: Options
    opts = defaults
      & header "X-PAYPAL-SECURITY-USERID"      .~ [ encodeUtf8 (_clUserId   c) ]
      & header "X-PAYPAL-SECURITY-PASSWORD"    .~ [ encodeUtf8 (_clPassword c) ]
      & header "X-PAYPAL-SECURITY-SIGNATURE"   .~ [ encodeUtf8 (_clSig      c) ]
      & header "X-PAYPAL-APPLICATION-ID"       .~ [ encodeUtf8 (_clAppId    c) ]
      & header "X-PAYPAL-REQUEST-DATA-FORMAT"  .~ [ "JSON" ]
      & header "X-PAYPAL-RESPONSE-DATA-FORMAT" .~ [ "JSON" ]

-- | Exported by Web.PayPal.Adaptive.Internal
ppDecode :: (FromJSON a) => Response ByteString -> Either AdaptiveErr a
ppDecode r =
  let b = r ^. responseBody
  in case eitherDecode b of
    Right d -> Right d
    Left  e -> -- If the response isn't a PayResp, it might be a PayPal error message.
      case eitherDecode b of
        Right (AeErrCodes cs) -> Left $ AeErrCodes cs
        _                     -> Left $ AeDecodeFailed b (T.pack e)

--------------------------------------------------
-- Errors
--------------------------------------------------

-- | Text is an error message in all the below types.
--
-- AeShouldNotHappen is meant to cover PayPal responses to API requests
-- that this library doesn't support sending in the first place.
-- TODO: is this actually how we're using it?
data AdaptiveErr
  = AeNoResponse
  | AeConnectionErr   Text
  | AeDecodeFailed    ByteString Text
  | AeErrCodes        [Int]
  | AePending         PayResp
  | AeRefused         PayResp
  | AeShouldNotHappen PayResp Text
  deriving (Eq, Show)

-- Error responses are what's returned if, e.g., your password is incorrect.
--
-- Here's an example error response. Only the parts we parse are included.
--
--     {
--         "error": [
--             {
--                 "errorId": "111111",
--             }
--         ]
--     }
instance FromJSON AdaptiveErr where
  parseJSON = withObject "error response" $ \o ->
    AeErrCodes . V.toList <$> (mapM parseErrId =<< o .: "error")

-- | Exported by Web.PayPal.Adaptive.Internal
parseErrId :: Value -> Parser Int
parseErrId = withObject "error array item" $ \o -> do
  a <- o .: "errorId"
  case decimal a of
    Left  _     -> fail "Could not parse error response code to Int"
    Right (b,_) -> return b

--------------------------------------------------
-- Common payload things
--------------------------------------------------

data ReceiverList = ReceiverList
  { _rlAmount :: Money
  , _rlEmail  :: Text
  } deriving (Eq, Show)

instance ToJSON ReceiverList where
  toJSON (ReceiverList a e) =
    object [ "receiver" .= [ object ["amount" .= m2PayPal a, "email" .= e] ] ]

-- | Exported by Web.PayPal.Adaptive.Internal
--
-- "en_US" is hardcoded because it's the only supported error language.
requestEnvelope :: Value
requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]

--------------------------------------------------
-- Send Payment
--------------------------------------------------

-- | Send a single payment from your account.
--
--
-- "Pay" operation docs:
-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>
--
-- This is a "Simple Payment" which means there's a single sender
-- and receiver (same as CreatePayment).
--
-- It uses the "Implicit" payment approval type, meaning the application
-- making the API call must also be the sender of the payment.
data SendPayment = SendPayment
  { _spReceiverList :: ReceiverList
  , _spReturnUrl    :: Text
  , _spCancelUrl    :: Text
  , _spSenderEmail  :: Text
  } deriving (Eq, Show)

instance Default SendPayment where
  def = SendPayment
    { _spReceiverList = ReceiverList mempty mempty
    , _spReturnUrl    = "https://example.com/"
    , _spCancelUrl    = "https://example.com/cancel"
    , _spSenderEmail  = mempty
    }

instance ToJSON SendPayment where
  toJSON p = object
    [ "actionType"      .= ("PAY" :: Text)
    , "currencyCode"    .= (m2Currency . _rlAmount . _spReceiverList) p
    , "receiverList"    .= _spReceiverList p
    , "returnUrl"       .= _spReturnUrl p
    , "cancelUrl"       .= _spCancelUrl p
    , "requestEnvelope" .= requestEnvelope
    , "senderEmail"     .= _spSenderEmail p
    ]

instance AdaptiveAPI SendPayment where
  toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p
    where
      ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp
      ensureSucceeded a =
        case _prPayExecStatus a of
          PeProcessing -> Left $ AePending a
          PePending    -> Left $ AePending a
          PeError      -> Left $ AeRefused a
          PeCompleted  ->
            let infos = _prPayInfo a
            in if length infos /= 1
              then Left $ AeShouldNotHappen a "sendPayment expects one PayInfo in reponse"
              else case _piTransactionStatus (head infos) of
                Just TsCompleted  -> Right a
                Just TsPending    -> Left $ AePending a
                Just TsProcessing -> Left $ AePending a
                Just TsDenied     -> Left $ AeRefused a
                Just TsFailed     -> Left $ AeRefused a
                _            -> Left $ AeShouldNotHappen a "got unsupported TransactionStatus"
          _ -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"

--------------------------------------------------
-- Create Payment
--------------------------------------------------

-- | Start the process of someone paying you. You have to redirect the payer's
-- browser to PayPal to finish it.
--
--
-- "Pay" operation docs:
-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>
--
-- This is a "Simple Payment" which means there's a single sender
-- and receiver (same as SendPayment).
--
-- It uses the "Explicit" payment approval type, meaning the payer must go to
-- PayPal in their browser to approve the payment. Here's an example payment
-- approval URL with a PayKey of "foo":
--
--     https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=foo
data CreatePayment = CreatePayment
  { _cpReceiverList :: ReceiverList
  , _cpReturnUrl    :: Text
  , _cpCancelUrl    :: Text
  , _cpSenderEmail  :: Text
  } deriving (Eq, Show)

instance Default CreatePayment where
  def = CreatePayment
    { _cpReceiverList = ReceiverList mempty mempty
    , _cpReturnUrl    = "https://example.com/"
    , _cpCancelUrl    = "https://example.com/cancel"
    , _cpSenderEmail  = mempty
    }

instance ToJSON CreatePayment where
  toJSON p = object
    [ "actionType"      .= ("PAY" :: Text)
    , "currencyCode"    .= (m2Currency . _rlAmount . _cpReceiverList) p
    , "receiverList"    .= _cpReceiverList p
    , "returnUrl"       .= _cpReturnUrl p
    , "cancelUrl"       .= _cpCancelUrl p
    , "requestEnvelope" .= requestEnvelope
    , "senderEmail"     .= _cpSenderEmail p
    ]

instance AdaptiveAPI CreatePayment where
  toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p
    where
      ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp
      ensureSucceeded a =
        case _prPayExecStatus a of
          PeCreated    -> Right a
          PeProcessing -> Left $ AePending a
          PePending    -> Left $ AePending a
          PeError      -> Left $ AeRefused a
          _            -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"

approvalUrl :: PpClient -> PayKey -> Text
approvalUrl c k =
  case _clEnv c of
    PpSandbox ->
      "https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="
      <> _unPayKey k
    PpProduction ->
      "https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="
      <> _unPayKey k

--------------------------------------------------
-- Lookup Payment
--------------------------------------------------

-- | Lookup information about a payment.
--
-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/>
data LookupPayment a where
  LookupTrID   :: TransactionId -> LookupPayment TransactionId
  LookupPayKey :: PayKey        -> LookupPayment PayKey

instance ToJSON (LookupPayment a) where
  toJSON (LookupTrID (TransactionId p)) =
    object [ "transactionId"   .= p
           , "requestEnvelope" .= requestEnvelope
           ]
  toJSON (LookupPayKey (PayKey p)) =
    object [ "payKey"          .= p
           , "requestEnvelope" .= requestEnvelope
           ]

instance AdaptiveAPI (LookupPayment a) where
  toPayPal c p = (>>= ppDecode) <$> ppPost c "PaymentDetails" p

--------------------------------------------------
-- Payment Responses
--------------------------------------------------

data PayResp = PayResp
  { _prPayError      :: Maybe Text -- Nothing for all Right responses
  , _prPayExecStatus :: PayExecStatus
  , _prPayKey        :: PayKey
  , _prPayInfo       :: [PayInfo] -- Empty in CreatePayment responses
  } deriving (Eq, Show)

instance FromJSON PayResp where
  parseJSON = withObject "PayResp" $ \o -> do
    e <- o .:? "payErrorList"
    k <- o .:  "payKey"

    s  <- o .:? "paymentExecStatus"
    s' <- o .:? "status"
    status <- maybe (fail "no paymentExecStatus or status") return (if isJust s then s else s')

    a <- o .:? "paymentInfoList"
    case a of
      Nothing -> return $ PayResp e status k mempty
      Just v  -> do
        infos <- v .:? "paymentInfo" .!= mempty
        return $ PayResp e status k infos

-- | This is "paymentExecStatus" in responses to sendPayment and createPayment.
-- It's called "status" in responses to lookupPayment.
data PayExecStatus
  = PeCreated
  | PeCompleted
  | PeIncomplete
  | PeError
  | PeReversalError
  | PeProcessing
  | PePending
  deriving (Eq, Show, Read)

-- | Defaults to expiring after three hours:
--
-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>
newtype PayKey = PayKey { _unPayKey :: Text } deriving (Eq, Show)

instance FromJSON PayKey where
  parseJSON = withText "PayKey" $ return . PayKey

instance ToJSON PayKey where
  toJSON (PayKey a) = toJSON a

-- | All the API calls we support return a PayInfo along with three Justs, with two
-- exceptions.
--
--     1. toPayPal CreatePayment returns no PayInfo at all.
--
--     2. toPayPal LookupPayment on such a payment does return a PayInfo, but with
-- three Nothings.
--
-- NOTE: _piSenderTransactionId and _piTransactionStatus will be different, but
-- both can be used to look up a payment.
data PayInfo = PayInfo
  { _piReceiver            :: Receiver
  , _piSenderTransactionId :: Maybe TransactionId
  , _piTransactionStatus   :: Maybe TransactionStatus
  , _piTransactionId       :: Maybe TransactionId
  } deriving (Eq, Show)

data Receiver = Receiver
  -- Haven't converted this to Money yet because I'm not sure how
  -- to determine its currency.
  { _reAmount    :: Text
  , _reEmail     :: Text
  , _reAccountId :: Text
  } deriving (Eq, Show)

newtype TransactionId = TransactionId { _unTransactionId :: Text } deriving (Eq, Show)

instance FromJSON TransactionId where
  parseJSON = withText "TransactionId" $ return . TransactionId

instance ToJSON TransactionId where
  toJSON (TransactionId a) = toJSON a

data TransactionStatus
  = TsCompleted
  | TsPending
  | TsCreated
  | TsPartiallyRefunded
  | TsDenied
  | TsProcessing
  | TsReversed
  | TsRefunded
  | TsFailed
  deriving (Eq, Show, Read)

--------------------------------------------------
-- Money
--------------------------------------------------

data Money = USD { _usdCents :: Int } deriving (Eq, Show)

-- NOTE: Once we add more currencies this instance will violate the
-- Monoid laws.
instance Monoid Money where
  mempty = USD 0
  mappend (USD c1) (USD c2) = USD $ c1 + c2

m2Currency :: Money -> Text
m2Currency (USD _) = "USD"

m2PayPal :: Money -> String
m2PayPal (USD c) =
  let s = show (abs c)
      a = case length s of
            0 -> "0.00"
            1 -> "0.0" <> s
            2 -> "0." <> s
            _ -> tailInsert 2 '.' s
  in if c < 0 then '-':a else a

  where
    tailInsert :: Int -> a -> [a] -> [a]
    tailInsert i x xs =
      let (ys, zs) = splitAt i (reverse xs)
      in reverse (ys <> pure x <> zs)


$(deriveFromJSON defaultOptions { fieldLabelModifier     = (\(x:xs) -> toLower x:xs) . drop 3 } ''PayInfo)
$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper               . drop 2 } ''PayExecStatus)
$(deriveFromJSON defaultOptions { fieldLabelModifier     = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver)
$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)

$(makePrisms ''AdaptiveErr)
$(makeLenses ''PpClient)
$(makeLenses ''CreatePayment)
$(makePrisms ''PpEnv)
$(makePrisms ''PayExecStatus)
$(makeLenses ''PayInfo)
$(makeLenses ''PayResp)
$(makeLenses ''Receiver)
$(makeLenses ''ReceiverList)
$(makeLenses ''SendPayment)
$(makePrisms ''TransactionId)
$(makePrisms ''TransactionStatus)