{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

module Ebay
    ( sandboxConf
    , liveConf

    , EbayT (..)
    , runEbayT

    , ebayRequest
    , ebayPost

    , module Ebay.Types
    ) where

import           Control.Applicative
import           Control.Monad.Base
import           Control.Monad.Error
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Data.ByteString.Char8        as CBS
import           Data.Conduit
import           Data.Conduit.Binary
import           Data.String
import           Data.Text                    as T
import           Data.Text.Encoding           as TE
import           Data.XML.Pickle
import           Data.XML.Types
import           Network.HTTP.Conduit
import           Network.HTTP.Types.Status
import           Text.XML.Unresolved

import           Ebay.Types

apiVersion :: Int
apiVersion = 863

buildConf :: String -> Text -> Manager -> DevID -> AppID -> CertID -> RuName -> SiteID
                -> EbayConf
buildConf = EbayConf

sandboxConf :: Manager -> DevID -> AppID -> CertID -> RuName -> SiteID -> EbayConf
sandboxConf = buildConf endpoint authpoint
    where endpoint  = "https://api.sandbox.ebay.com/ws/api.dll"
          authpoint = "https://signin.sandbox.ebay.com/ws/eBayISAPI.dll"

liveConf :: Manager -> DevID -> AppID -> CertID -> RuName -> SiteID -> EbayConf
liveConf = buildConf endpoint authpoint
    where endpoint  = "https://api.ebay.com/ws/api.dll"
          authpoint = "https://signin.ebay.com/ws/eBayISAPI.dll"

newtype EbayT a = EbayT
        { unEbayT :: ResourceT (ReaderT EbayConf (ErrorT EbayFailure IO)) a
        } deriving ( Functor, Applicative, Monad, MonadIO, MonadThrow
                   , MonadError EbayFailure
                   , MonadReader EbayConf
                   , MonadBase IO
                   , MonadResource )

runEbayT :: EbayConf -> EbayT a -> IO (Either EbayFailure a)
runEbayT conf = runErrorT . flip runReaderT conf . runResourceT . unEbayT

ebayRequest :: (MonadIO m, MonadThrow m, MonadReader EbayConf m) => Text -> m Request
ebayRequest callName = do
        (EbayConf{..}) <- ask
        initReq <- parseUrl $ ebayEndpoint
        let compReq = initReq
                    { requestHeaders =
                        [ ("Content-Type", "text/xml")
                        , ("X-EBAY-API-COMPATIBILITY-LEVEL", CBS.pack $ show apiVersion)
                        , ("X-EBAY-API-DEV-NAME", TE.encodeUtf8 ebayDevName)
                        , ("X-EBAY-API-APP-NAME", TE.encodeUtf8 ebayAppName)
                        , ("X-EBAY-API-CERT-NAME", TE.encodeUtf8 ebayCertName)
                        , ("X-EBAY-API-CALL-NAME", TE.encodeUtf8 callName)
                        , ("X-EBAY-API-SITEID", CBS.pack $ show $ siteIdNumber ebaySiteId)
                        ]
                    , method      = "POST"
                    }
        return compReq

ebayPost :: Text -> PU [Node] a -> PU [Node] b -> a -> EbayT (StandardOutput, b)
ebayPost callName reqPickler resPickler req = do
        (EbayConf{..}) <- ask
        initReq <- ebayRequest callName
        let compReq = initReq
                    { requestBody = RequestBodyLBS $ renderLBS def reqDoc }
        renderBytes def reqDoc $$ sinkFile "input.xml"
        res <- http compReq ebayManager
        case responseStatus res of
            s | s == status200 -> do
                    doc@(Document _ root _) <- responseBody res $$+- sinkDoc def
                    renderBytes def doc $$ sinkFile "output.xml"
                    let stdOut  = unpickle stdXp (NodeElement root)
                        callOut = unpickle resXp (NodeElement root)
                    case (stdOut, callOut) of
                        (Right s1, Right s2) -> return (s1, s2)
                        (Left  e1,        _) -> throwError $ ParseFailure $ Just e1
                        --(Right s1,        _) -> throwError $ EbayFailure $ Just s1
                        (Right s1, Left  e1) -> throwError $ ParseFailure $ Just e1
              | otherwise      -> do
                    doc@(Document _ root _) <- responseBody res $$+- sinkDoc def
                    let out = unpickle stdXp (NodeElement root)
                    case out of
                        Left  e -> throwError $ ParseFailure $ Just e
                        Right s -> throwError $ EbayFailure $ Just s
    where reqDoc   = Document (Prologue [] Nothing [])
                        (Element reqName reqAttrs (pickle reqPickler req)) []
          reqName  = Name (T.concat [callName, "Request"]) Nothing Nothing
          reqAttrs = [(Name "xmlns" Nothing Nothing,
                        [ContentText "urn:ebay:apis:eBLBaseComponents"])]
          resName  = fromString $ T.unpack $
                        T.concat ["{urn:ebay:apis:eBLBaseComponents}", callName, "Response"]
          resXp    = xpRoot $ xpElemNodes resName $ xpClean resPickler
          stdXp    = xpRoot $ xpElemNodes resName $ xpClean xpStandardOutput
