{-# LANGUAGE MultiWayIf      #-}
{-# LANGUAGE TemplateHaskell #-}

module PayPal.Adaptive.Core where

import           Prelude              hiding (mapM)
import           Control.Applicative
import           Control.Exception
import           Control.Lens         hiding ((.=))
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.Maybe
import           Data.Monoid
import           Data.Text            (Text)
import qualified Data.Text            as T
import           Data.Text.Encoding
import           Data.Text.Read
import           Data.Traversable
import qualified Data.Vector          as V
import           Network.Wreq

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

data Client = Client
  { _clAppId        :: Text
  , _clUserId       :: Text
  , _clEnv          :: Env
  , _clPassword     :: Text
  , _clSig          :: Text
  -- | Not needed for authentication, but deposits are sent
  -- to here and withdrawals are sent from here. Must be the
  -- email associated with your PayPal app.
  , _clAccountEmail :: Text
  } deriving (Eq, Show)

data Env = Sandbox | Production deriving (Eq, Show, Read)

--------------------------------------------------
-- 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
  = AeConnectionErr   Text
  | AeDecodeFailed    ByteString Text
  | AeInvalidCredentials
  -- ^ Just a wrapper around an AeErrCodes Int.
  | AeNoSuchEmail
  -- ^ Just a wrapper around an AeErrCodes Int. Raised when the Deposit
  -- sender email or the Withdrawal account email doesn't exist.
  | 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 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

--------------------------------------------------
-- * Payment Responses
--------------------------------------------------

-- | Used for forgiving attempts to parse PayPal responses. For instance,
-- this library never expects more than one PayInfo. We still try to
-- parse them as a list here so we can still sucessfully parse a PayResp
-- to use in an 'AdaptiveError' if for some reason more than one 'PayInfo'
-- is returned 
data PayResp = PayResp
  { _prPayError      :: Maybe Text
  , _prPayExecStatus :: PayExecStatus
  , _prPayKey        :: PayKey
  , _prPayInfos      :: [PayInfo]
  } deriving (Eq, Show)

-- | A version of 'PayResp' for completed transactions.
--
-- Status fields are omitted since they should be complete.
--
-- Has no separate field for a 'PayInfo' 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 CompletePayResp = CompletePayResp
  { _crPayKey              :: PayKey
  , _crReceiver            :: Receiver
  , _crSenderTransactionId :: TransactionId
  , _crTransactionId       :: TransactionId
  } deriving (Eq, Show)

checkComplete :: PayResp -> Either AdaptiveErr CompletePayResp
checkComplete pr = do
  errorFieldNothing pr
  payExecStatusCompleted pr
  checkPayKey pr
  info <- getPayInfo pr
  sid <- transactionIdJust pr (_piSenderTransactionId info)
  transactionStatusCompleted pr info
  tid <- transactionIdJust pr (_piTransactionId info)
  return $ CompletePayResp (_prPayKey pr) (_piReceiver info) sid tid

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 refers to the processing of this request. To make sure a payment
-- has actually gone through, check 'TransactionStatus' instead.
--
-- PayPal returns this using the JSON object key "paymentExecStatus"
-- in responses to Withdrawal and Deposit and "status" in responses to
-- LookupPayment.
data PayExecStatus
  = PeCreated
  | PeCompleted
  | PeIncomplete
  | PeError
  | PeReversalError
  | PeProcessing
  | PePending
  deriving (Eq, Show, Read)

-- | Expires 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

-- | Right toPayPal responses return a PayInfo along with a
-- _piTransactionStatus Just, with some exceptions.
--
--     1. Withdrawals to nonexistent accounts return no PayInfos.
--
--     2. Lookups on such transactions return one PayInfo with a
--     _piTransactionStatus of Nothing.
--
--     3. Deposits don't return PayInfos.
--
--     4. Lookups on such transactions return one PayInfo with a
--     _piTransactionStatus of Nothing.
--
-- NOTE: We use the same newtype for both _piSenderTransactionId and
-- _piTransactionStatus. They will have different values, but either
-- 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
  { _reAmount    :: Text
  -- ^ Haven't converted this to Money yet because I'm not sure how
  -- to determine its currency.
  , _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)

--------------------------------------------------
-- Internal Helpers
--------------------------------------------------

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

ppPost :: (ToJSON a) => Client -> 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
        Sandbox    -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"
        Production -> "https://svcs.paypal.com/AdaptivePayments/"

    handler :: SomeException -> IO (Either AdaptiveErr (Response ByteString))
    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" ]

ppDecode :: Response ByteString -> Either AdaptiveErr PayResp
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 decode b of
        Just (AeErrCodes codes) -> Left $ codeErr codes
        _ -> Left $ AeDecodeFailed b (T.pack e)
  where
    codeErr :: [Int] -> AdaptiveErr
    codeErr cs =
      if | elem 520003 cs -> AeInvalidCredentials
         | elem 589039 cs -> AeNoSuchEmail
         | otherwise      -> AeErrCodes cs

payExecStatusCompleted :: PayResp -> Either AdaptiveErr ()
payExecStatusCompleted a =
  case _prPayExecStatus a of
    PeCompleted  -> Right ()
    PeProcessing -> Left $ AePending a
    PePending    -> Left $ AePending a
    PeError      -> Left $ AeRefused a
    _            -> Left $ AeShouldNotHappen a "unsupported PayExecStatus"

-- | TODO: this makes the assumption that an empty PayInfo list means
-- the transaction is pending. Is this always right?
getPayInfo :: PayResp -> Either AdaptiveErr PayInfo
getPayInfo a =
  case _prPayInfos a of
    []     -> Left $ AePending a
    [info] -> Right info
    _      -> Left $ AeShouldNotHappen a "more than one PayInfo in reponse"

transactionStatusCompleted :: PayResp -> PayInfo -> Either AdaptiveErr ()
transactionStatusCompleted a info =
  case _piTransactionStatus info of
    Just TsCompleted  -> Right ()
    Just TsPending    -> Left $ AePending a
    Just TsProcessing -> Left $ AePending a
    Just TsDenied     -> Left $ AeRefused a
    Just TsFailed     -> Left $ AeRefused a
    _                 -> Left $ AeShouldNotHappen a "unsupported TransactionStatus"

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

checkPayKey :: PayResp -> Either AdaptiveErr ()
checkPayKey a
  | T.null . _unPayKey . _prPayKey $ a =
    Left $ AeShouldNotHappen a "got a PayKey with length zero"
  | otherwise = Right ()

payExecStatusCreated :: PayResp -> Either AdaptiveErr ()
payExecStatusCreated a =
  case _prPayExecStatus a of
    PeCreated    -> Right ()
    PeProcessing -> Left $ AePending a
    PePending    -> Left $ AePending a
    PeError      -> Left $ AeRefused a
    _            -> Left $ AeShouldNotHappen a "unsupported PayExecStatus"

noPayInfo :: PayResp -> Either AdaptiveErr ()
noPayInfo a =
  case _prPayInfos a of
    [] -> Right ()
    _  -> Left $ AeShouldNotHappen a
      "At least one PayInfo present in otherwise successful deposit resp"

transactionIdJust :: PayResp -> Maybe TransactionId -> Either AdaptiveErr TransactionId
transactionIdJust a Nothing = Left $ AeShouldNotHappen a "expected a Just for Maybe TransactionId"
transactionIdJust _ (Just tid) = Right tid


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