NVP.hs

{-# 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.Maybe
import Data.Monoid
import Network.HTTP.Conduit as HTTP
import Network.HTTP.Types as HTTP
import System.IO.Unsafe
import Data.Conduit
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 L.ByteString) (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
    res <- liftIO $ withManager $ httpLbs (prepareRequest service cred req)
    processResponse req res

-- | 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, MonadIO m) =>
                   req
                -> Response L.ByteString
                -> m (Either (Response L.ByteString) (PayPal.Status (PayPalResponse req)))
processResponse req res = do
    let Status statusCode _ = responseStatus res
        body = responseBody res
    return $ case statusCode of
        200 -> Right . decodeResponseChecking
                     . map (second (fromMaybe mempty))
                     . parseQuery
                     . (mconcat . L.toChunks) $ body
        _   -> Left res