{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
module Network.PayPal.NVP (
        -- * High-level interface
        Service,
        sandbox,
        live,
        submit,
        -- * Low-level interface
        prepareRequest,
        processResponse
    ) where

import Network.PayPal.Types as PayPal

import Control.Applicative
import Control.Arrow
import Control.Failure
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import Data.Monoid
import Network.HTTP.Enumerator as HTTP
import Network.HTTP.Types as HTTP
import Web.Encodings (decodeUrlPairs)
import System.IO.Unsafe
import Data.Enumerator (Iteratee (..), run_)
import Data.Enumerator.List (consume)
import qualified Network.Wai as W


-- | A PayPal service.
data Service = Service (HTTP.Request IO) (HTTP.Request IO)

-- | PayPal sandbox.
sandbox :: Service
sandbox = Service
    -- URL for signature security
    (unsafePerformIO $ parseUrl "https://api-3t.sandbox.paypal.com/nvp")
    -- URL for certificate security
    (unsafePerformIO $ parseUrl "https://api.sandbox.paypal.com/nvp")

-- | PayPal live system.
live :: Service
live = Service
    -- URL for signature security
    (unsafePerformIO $ parseUrl "https://api-3t.paypal.com/nvp")
    -- URL for certificate security
    (unsafePerformIO $ parseUrl "https://api.paypal.com/nvp")

-- | Submit a request to PayPal.
submit :: (Failure HttpException m, MonadIO m, PayPalRequest req) =>
          Service
       -> Credentials
       -> req
       -> m (Either Response (PayPal.Status (PayPalResponse req)))
submit service cred req = do
    -- Re-using connections (i.e. not creating a new manager each time) fails with
    -- an exception for some reason:
    --
    -- too few bytes. Failed reading at byte position 1
    mgr <- liftIO newManager
    run_ $ httpRedirect (prepareRequest service cred req) (processResponse req) mgr

-- | Construct an HTTP request for the specified PayPal request.
prepareRequest :: (Monad m, PayPalRequest req) =>
                  Service
               -> Credentials
               -> req
               -> HTTP.Request m
prepareRequest (Service url _) (Credentials user pwd (Signature sig) version) req =
    urlEncodedBody vars url
  where
    vars =
        [("USER", user),
         ("PWD", pwd),
         ("VERSION", version),
         ("SIGNATURE", sig)] ++ toVariables req

processResponse :: (PayPalRequest req, Monad m) =>
                   req
                -> HTTP.Status
                -> ResponseHeaders
                -> Iteratee B.ByteString m (Either Response (PayPal.Status (PayPalResponse req)))
processResponse req (Status statusCode _) headers = do
    body <- L.fromChunks <$> consume
    return $ case statusCode of
        200 -> Right . decodeResponseChecking
                     . map (textify *** textify)
                     . decodeUrlPairs $ body
        _   -> Left $ Response statusCode headers body
  where
    textify = mconcat . L.toChunks