summaryrefslogtreecommitdiff
path: root/src/Network/Payments/PayPal/Payments.hs
blob: 9650efaf43ebaf548bf573985e5f58fd9e376f7a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
-- |
-- Module: Network.Payments.PayPal.Payments
-- Copyright: (C) 2016 Braden Walters
-- License: MIT (see LICENSE file)
-- Maintainer: Braden Walters <vc@braden-walters.info>
-- Stability: experimental
-- Portability: ghc

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Payments.PayPal.Payments
( URL
, PaymentID
, Intent(..)
, RedirectUrls(..)
, ReturnLinkParams(..)
, CreateRequest(..)
, CreateResponse(..)
, ExecuteRequest(..)
, ExecuteResponse(..)
, FindResponse(..)
, ListResponse(..)
, createPayment
, approvalUrlFromCreate
, executePayment
, findPaymentById
, listPayments
, returnLinkParams
) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Time.Clock
import Data.Time.Format
import qualified Network.HTTP.Client as HTTP
import Network.Payments.PayPal
import Network.Payments.PayPal.Types.Hateoas
import Network.Payments.PayPal.Types.Paging
import Network.Payments.PayPal.Types.Payer
import Network.Payments.PayPal.Types.Transaction
import Network.Wreq
import qualified Network.Wreq.Types as WTypes

-- A string representing a URL.
type URL = String

-- The ID of a payment provided by PayPal.
type PaymentID = String

-- |Payment intent.
data Intent = SaleIntent | AuthoriseIntent | OrderIntent
  deriving (Eq, Read, Show)

instance ToJSON Intent where
  toJSON SaleIntent = "sale"
  toJSON AuthoriseIntent = "authorize"
  toJSON OrderIntent = "order"

instance FromJSON Intent where
  parseJSON (String "sale") = return SaleIntent
  parseJSON (String "authorize") = return AuthoriseIntent
  parseJSON (String "order") = return OrderIntent
  parseJSON _ = mzero

data RedirectUrls = RedirectUrls
  { redirUrlReturn :: URL
  , redirUrlCancel :: URL
  } deriving (Eq, Show)

instance ToJSON RedirectUrls where
  toJSON urls =
    object ["return_url" .= redirUrlReturn urls,
            "cancel_url" .= redirUrlCancel urls]

instance FromJSON RedirectUrls where
  parseJSON (Object obj) =
    RedirectUrls <$>
    obj .: "return_url" <*>
    obj .: "cancel_url"
  parseJSON _ = mzero

data ReturnLinkParams = ReturnLinkParams
  { retLinkParamPayId :: PaymentID
  , retLinkParamToken :: String
  , retLinkParamPayerId :: String
  } deriving (Eq, Show)

-- |Current status of the PayPal payment.
data PaymentState = PayStateCreated | PayStateApproved | PayStateFailed |
                    PayStateCancelled | PayStateExpired | PayStatePending
                    deriving (Eq, Read, Show)

instance FromJSON PaymentState where
  parseJSON (String "created") = return PayStateCreated
  parseJSON (String "approved") = return PayStateApproved
  parseJSON (String "failed") = return PayStateFailed
  parseJSON (String "canceled") = return PayStateCancelled
  parseJSON (String "expired") = return PayStateExpired
  parseJSON (String "pending") = return PayStatePending
  parseJSON _ = mzero

-- |Contains data sent to PayPal to create a payment.
data CreateRequest = CreateRequest
  { createReqIntent :: Intent
  , createReqPayer :: Payer
  , createReqTransactions :: [Transaction]
  , createReqRedirectUrls :: Maybe RedirectUrls
  } deriving (Eq, Show)

instance ToJSON CreateRequest where
  toJSON req =
    object (["intent" .= createReqIntent req,
             "payer" .= createReqPayer req,
             "transactions" .= createReqTransactions req] ++
            maybeToList (("redirect_urls" .=) <$> createReqRedirectUrls req))

-- |Contains a parsed response from PayPal after making a create payment
-- request.
data CreateResponse = CreateResponse
  { createResIntent :: Intent
  , createResPayer :: Payer
  , createResTransactions :: [Transaction]
  , createResRedirectUrls :: Maybe RedirectUrls
  , createResPayId :: PaymentID
  , createResCreateTime :: UTCTime
  , createResPayState :: PaymentState
  , createResUpdateTime :: Maybe UTCTime
  , createResHateoasLinks :: [HateoasLink]
  } deriving (Eq, Show)

instance FromJSON CreateResponse where
  parseJSON (Object obj) =
    CreateResponse <$>
    obj .: "intent" <*>
    obj .: "payer" <*>
    obj .: "transactions" <*>
    obj .:? "redirect_urls" <*>
    obj .: "id" <*>
    (obj .: "create_time" >>= parseTimeIso8106) <*>
    obj .: "state" <*>
    (obj .:? "update_time" >>=
     maybe (return Nothing) (\str -> Just <$> parseTimeIso8106 str)) <*>
    obj .: "links"
  parseJSON _ = mzero

-- |Executing a payment has a special transaction object which only contains the
-- amount.
data ExecuteTransaction = ExecuteTransaction
  { executeTransactionAmount :: Amount
  } deriving (Eq, Show)

instance ToJSON ExecuteTransaction where
  toJSON trans = object ["amount" .= executeTransactionAmount trans]

-- |Request to execute a payment.
data ExecuteRequest = ExecuteRequest
  { executeReqPayerId :: String
  , executeReqTransactions :: [ExecuteTransaction]
  } deriving (Eq, Show)

instance ToJSON ExecuteRequest where
  toJSON req =
    let transactions = if length (executeReqTransactions req) > 0
          then ["transactions" .= executeReqTransactions req]
          else []
    in object (["payer_id" .= executeReqPayerId req] ++ transactions)

-- |Response from an execute payment request.
data ExecuteResponse = ExecuteResponse
  { executeResIntent :: Intent
  , executeResPayer :: Payer
  , executeResTransactions :: [Transaction]
  , executeResHateoasLinks :: [HateoasLink]
  } deriving (Eq, Show)

instance FromJSON ExecuteResponse where
  parseJSON (Object obj) =
    ExecuteResponse <$>
    obj .: "intent" <*>
    obj .: "payer" <*>
    obj .: "transactions" <*>
    obj .: "links"
  parseJSON _ = mzero

-- |Contains a parsed response from a find payment request.
data FindResponse = FindResponse
  { findResIntent :: Intent
  , findResPayer :: Payer
  , findResTransactions :: [Transaction]
  , findResRedirectUrls :: Maybe RedirectUrls
  , findResPayId :: PaymentID
  , findResCreateTime :: UTCTime
  , findResPayState :: PaymentState
  , findResUpdateTime :: Maybe UTCTime
  } deriving (Eq, Show)

instance FromJSON FindResponse where
  parseJSON (Object obj) =
    FindResponse <$>
    obj .: "intent" <*>
    obj .: "payer" <*>
    obj .: "transactions" <*>
    obj .:? "redirect_urls" <*>
    obj .: "id" <*>
    (obj .: "create_time" >>= parseTimeIso8106) <*>
    obj .: "state" <*>
    (obj .:? "update_time" >>= maybe (return Nothing)
                                     (\str -> Just <$> parseTimeIso8106 str))
  parseJSON _ = mzero

-- Response to a payment list request.
data ListResponse = ListResponse
  { listResPayments :: [CreateResponse]
  , listResCount :: Integer
  , listResNextId :: Maybe PaymentID
  } deriving (Eq, Show)

instance FromJSON ListResponse where
  parseJSON (Object obj) =
    ListResponse <$>
    (fromMaybe [] <$> obj .:? "payments") <*>
    obj .: "count" <*>
    obj .:? "next_id"
  parseJSON _ = mzero

-- |Creates a new payment using payment data.
createPayment :: CreateRequest -> PayPalOperations CreateResponse
createPayment request =
  let url = "/v1/payments/payment"
      contentType = "application/json"
      content = encode request
      payload = WTypes.Raw contentType $ HTTP.RequestBodyLBS content
  in PayPalOperation (UseHttpPost payload) url defaults

-- |Extracts an approval URL, if there is one, from a create response
approvalUrlFromCreate :: CreateResponse -> Maybe URL
approvalUrlFromCreate response =
  let criteriaFunction hateoas =
        hateoasRel hateoas == "approval_url" &&
        hateoasMethod hateoas == HateoasRedirect
      maybeHateoas =
        listToMaybe $ filter criteriaFunction $ createResHateoasLinks response
  in hateoasHref <$> maybeHateoas

-- |Execute (or complete) a payment that has been approved by the payer.
executePayment :: PaymentID -> ExecuteRequest ->
                  PayPalOperations ExecuteResponse
executePayment id' request =
  let url = "/v1/payments/payment/" ++ id' ++ "/execute"
      contentType = "application/json"
      content = encode request
      payload = WTypes.Raw contentType $ HTTP.RequestBodyLBS content
  in PayPalOperation (UseHttpPost payload) url defaults

-- |Looks up a payment by ID.
findPaymentById :: PaymentID -> PayPalOperations FindResponse
findPaymentById id' =
  let url = "/v1/payments/payment/" ++ id'
  in PayPalOperation UseHttpGet url defaults

-- |Lists payments, possibly with paging.
listPayments :: Maybe PagingRequest -> PayPalOperations ListResponse
listPayments pagingRequest =
  let url = "/v1/payments/payment/" ++
            (maybe mempty (\req -> "?" ++ pagingReqToQuery req) pagingRequest)
  in PayPalOperation UseHttpGet url defaults

-- |Use this function to parse GET parameters passed from PayPal to the return
-- URL. Takes a map of query parameters (name to value) and returns a structure
-- containing these parameters if possible. Otherwise PayPal didn't give you
-- required data.
returnLinkParams :: M.Map BS.ByteString BS.ByteString -> Maybe ReturnLinkParams
returnLinkParams query = do
  paymentId <- BS8.unpack <$> M.lookup "paymentId" query
  token <- BS8.unpack <$> M.lookup "token" query
  payerId <- BS8.unpack <$> M.lookup "PayerID" query
  return $ ReturnLinkParams paymentId token payerId

-- Parses a time in ISO 8106 format to a UTCTime.
parseTimeIso8106 :: String -> Parser UTCTime
parseTimeIso8106 str =
  parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") str