taler-merchant-api-tutorial.hs (12844B)
1 -- SPDX-FileCopyrightText: 2023 Vint Leenaars <vl.software@leenaa.rs> 2 -- SPDX-License-Identifier: Apache-2.0 3 -- SPDX-License-Identifier: EUPL-1.2 4 -- SPDX-License-Identifier: MPL-2.0 5 -- SPDX-License-Identifier: AGPL-3.0-or-later 6 7 -- See https://docs.taler.net/taler-merchant-api-tutorial.html for full tutorial 8 -- 9 -- GNU Taler is an open protocol for an electronic payment system with a free 10 -- software reference implementation. GNU Taler offers secure, fast and easy 11 -- payment processing using well understood cryptographic techniques. GNU Taler 12 -- allows customers to remain anonymous, while ensuring that merchants can be 13 -- held accountable by governments. Hence, GNU Taler is compatible with 14 -- anti-money-laundering (AML) and know-your-customer (KYC) regulation, as well 15 -- as data protection regulation (such as GDPR). 16 17 {-# LANGUAGE OverloadedStrings, DeriveGeneric #-} 18 19 -- IMPORTS -- 20 import Data.Aeson (FromJSON (..), (.=), object, encode, decode) 21 import Network.HTTP 22 import Network.HTTP.Client 23 import Network.HTTP.Client.TLS 24 import Network.HTTP.Types 25 import Network.URI 26 27 import Data.ByteString.Lazy as BL 28 import Data.ByteString as B 29 30 import Control.Monad (when) 31 32 import GHC.Generics 33 34 -- VARIABLES 35 36 -- Domain name of the sandbox backend 37 domainName :: String 38 domainName = "https://backend.demo.taler.net/private/" 39 40 -- Domain name of the sandbox backends orders 41 domainNameOrder :: String 42 domainNameOrder = "https://backend.demo.taler.net/private/orders" 43 44 -- Key of the Authorization header ("Bearer secret-token:$KEY") 45 secretToken :: B.ByteString 46 secretToken = "sandbox" 47 48 -- 4.1.4 Public Sandbox Backend and Authentication 49 -- https://docs.taler.net/taler-merchant-api-tutorial.html#public-sandbox-backend-and-authentication 50 51 -- The public sandbox backend https://backend.demo.taler.net/ uses an API key 52 -- in the Authorization header. The value of this header must be Bearer 53 -- secret-token:secret for the public sandbox backend. 54 55 -- The function 'authenticationTest' tests if authenticating to the backend works: 56 57 authenticationTest :: Manager -> IO () 58 authenticationTest manager = do 59 initialized_request <- parseRequest domainNameOrder 60 61 response <- httpLbs initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] } manager 62 63 let status_code = statusCode $ responseStatus response 64 65 print $ "Function 'authenticationTest' returned status code: " ++ show status_code 66 67 when (not $ status_code == 200) $ printHint response 68 69 -- This should return HTTP status code 200. 70 71 72 73 -- 4.2.1: Creating an Order for a Payment 74 -- https://docs.taler.net/taler-merchant-api-tutorial.html#creating-an-order-for-a-payment 75 76 -- Payments in Taler revolve around an order, which is a machine-readable 77 -- description of the business transaction for which the payment is to be made. 78 -- Before accepting a Taler payment as a merchant you must create such an 79 -- order. 80 81 -- The function 'createOrder' creates a minimal order and returns a response: 82 83 createOrder :: Manager -> IO BL.ByteString 84 createOrder manager = do 85 initialized_request <- parseRequest domainNameOrder 86 87 let order = object [ "create_token" .= False 88 , "order" .= object [ "amount" .= ("KUDOS:10" :: String) 89 , "summary" .= ("Donation" :: String) 90 , "fulfillment_url" .= ("https://example.com/thanks.html" :: String) ] ] 91 92 let request = initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken )] 93 , method = "POST" 94 , requestBody = RequestBodyLBS $ encode order } 95 96 response <- httpLbs request manager 97 98 let status_code = statusCode $ responseStatus response 99 100 print $ "Function 'createOrder' returned status code: " ++ show status_code 101 102 if status_code == 200 103 then print $ "Created an order with ID: " ++ (order_id $ responseToOrderID $ responseBody response) 104 else printHint response 105 106 return $ responseBody response 107 108 109 -- The backend will fill in some details missing in the order, such as the 110 -- address of the merchant instance. The full details are called the contract 111 -- terms. 112 113 -- After successfully POSTing to /private/orders, a JSON with just an order_id 114 -- field with a string representing the order ID will be returned. 115 116 117 118 -- 4.2.2: Checking Payment Status 119 -- https://docs.taler.net/taler-merchant-api-tutorial.html#checking-payment-status-and-prompting-for-payment 120 121 -- Given the order ID, the status of a payment can be checked with the 122 -- /private/orders/$ORDER_ID endpoint. If the payment is yet to be completed by 123 -- the customer, /private/orders/$ORDER_ID will give the frontend a URL (under 124 -- the name payment_redirect_url) that will trigger the customer’s wallet to 125 -- execute the payment. 126 127 -- The function 'checkPaymentStatus' checks what the current status of the 128 -- payment with given order_id is: 129 130 checkPaymentStatus :: Manager -> String -> IO () 131 checkPaymentStatus manager order_id = do 132 133 initialized_request <- parseRequest ( domainNameOrder ++ "/" ++ order_id ) 134 response <- httpLbs ( initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] } ) manager 135 136 let status_code = statusCode $ responseStatus response 137 138 print $ "Function 'checkPaymentStatus' returned status code: " ++ show status_code 139 140 if status_code == 200 141 then print $ responseBody response 142 else printHint response 143 144 145 -- If the order_status field in the response is paid, you will not get a 146 -- payment_redirect_url and instead information about the payment status, 147 -- including contract_terms (the full contract terms of the order), 148 -- refunded (true if a (possibly partial) refund was granted for this purchase) 149 -- and refunded_amount (amount that was refunded). 150 151 152 153 -- 4.3: Giving Refunds 154 -- https://docs.taler.net/taler-merchant-api-tutorial.html#index-9 155 156 -- A refund in GNU Taler is a way to “undo” a payment. It needs to be 157 -- authorized by the merchant. Refunds can be for any fraction of the original 158 -- amount paid, but they cannot exceed the original payment. Refunds are 159 -- time-limited and can only happen while the exchange holds funds for a 160 -- particular payment in escrow. The time during which a refund is possible can 161 -- be controlled by setting the refund_deadline in an order. The default value 162 -- for this refund deadline is specified in the configuration of the merchant’s 163 -- backend. 164 -- 165 -- The frontend can instruct the merchant backend to authorize a refund by 166 -- POSTing to the /private/orders/$ORDER_ID/refund endpoint. 167 168 -- The function 'requestRefund' requests for a refund: 169 170 requestRefund :: Manager -> String -> IO () 171 requestRefund manager order_id = do 172 173 initialized_request <- parseRequest ( domainNameOrder ++ "/" ++ order_id ++ "/refund" ) 174 175 let order_refund = object [ "refund" .= ("KUDOS:10" :: String) 176 , "reason" .= ("Customer did not like the product" :: String) ] 177 178 let refund_request = initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] 179 , method = "POST" 180 , requestBody = RequestBodyLBS $ encode order_refund } 181 182 response <- httpLbs refund_request manager 183 184 let status_code = statusCode $ responseStatus response 185 186 print $ "Function 'requestRefund' returned status code: " ++ show status_code 187 188 if status_code == 200 189 then print $ "Succesfully created request for refund, send customer to: " 190 ++ (taler_refund_uri $ responseToRefundURI $ responseBody response) 191 else printHint response 192 193 194 -- If the request is successful (indicated by HTTP status code 200), the 195 -- response includes a taler_refund_uri. The frontend must redirect the 196 -- customer’s browser to that URL to allow the refund to be processed by the 197 -- wallet. 198 199 200 201 -- 4.5 Giving Customers Rewards 202 -- https://docs.taler.net/taler-merchant-api-tutorial.html#index-11 203 204 -- GNU Taler allows Web sites to grant digital cash directly to a visitor. The 205 -- idea is that some sites may want incentivize actions such as filling out a 206 -- survey or trying a new feature. It is important to note that receiving 207 -- rewards is not enforceable for the visitor, as there is no contract. It is 208 -- simply a voluntary gesture of appreciation of the site to its visitor. 209 -- However, once a reward has been granted, the visitor obtains full control 210 -- over the funds provided by the site. 211 212 -- The function 'checkReserves' checks if rewards are confiured properly and 213 -- if there are sufficient funds avaliable for granting rewards: 214 215 checkReserves :: Manager -> IO () 216 checkReserves manager = do 217 218 initialized_request <- parseRequest $ domainName ++ "reserves" 219 220 response <- httpLbs ( initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] } ) manager 221 222 let status_code = statusCode $ responseStatus response 223 224 print $ "Function 'checkReserves' returned status code: " ++ show status_code 225 226 if status_code == 200 227 228 -- Check that a reserve exists where the merchant_initial_amount is below the 229 -- committed_amount and that the reserve is active. 230 then print $ BL.append "Reserves found: " (responseBody response) 231 232 else printHint response 233 234 -- The response from the backend contains a taler_reward_url. The customer’s 235 -- browser must be redirected to this URL for the wallet to pick up the reward. 236 237 238 239 -- The function 'giveReward' illustrates giving a reward 240 giveReward :: Manager -> IO () 241 giveReward manager = do 242 243 initialized_request <- parseRequest $ domainName ++ "rewards" 244 245 let order = object [ "amount" .= ("KUDOS:0.5" :: String) 246 , "justification" .= ("User filled out survey" :: String) 247 , "next_url" .= ("https://merchant.com/thanks.html" :: String) ] 248 249 let reward_request = initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] 250 , method = methodPost 251 , requestBody = RequestBodyLBS $ encode order } 252 253 response <- httpLbs reward_request manager 254 255 print response 256 257 let status_code = statusCode $ responseStatus response 258 259 print $ "Function 'giveReward' returned status code: " ++ show status_code 260 261 if status_code == 200 262 then print $ "Reward created, redirect customer to: " 263 ++ (taler_reward_url $ responseToRewardURL $ responseBody response) 264 else printHint response 265 266 267 -- HELPER FUNCTIONS & CUSTOM DATA TYPES 268 269 printHint :: Network.HTTP.Client.Response BL.ByteString -> IO () 270 printHint response = do 271 print $ B.append "Status message: " (statusMessage $ responseStatus response) 272 case decode $ responseBody response :: Maybe FailedResponse of 273 Just help -> print $ Prelude.concat [ "Hint ", "(code ", show $ code help, "): ", hint help ] 274 Nothing -> return () 275 276 data ResponseWithID = ResponseWithID { 277 order_id :: String } deriving (Show, Eq, Generic) 278 279 data ResponseWithRefundURI = ResponseWithRefundURI { 280 taler_refund_uri :: String } deriving (Show, Eq, Generic) 281 282 data ResponseWithRewardURL = ResponseWithRewardURL { 283 taler_reward_url :: String } deriving (Show, Eq, Generic) 284 285 data FailedResponse = FailedResponse 286 { hint :: String 287 , code :: Int } deriving (Show, Eq, Generic) 288 289 instance FromJSON ResponseWithID 290 instance FromJSON ResponseWithRefundURI 291 instance FromJSON ResponseWithRewardURL 292 instance FromJSON FailedResponse 293 294 responseToOrderID :: BL.ByteString -> ResponseWithID 295 responseToOrderID input = case decode input of 296 Just r -> r 297 Nothing -> ResponseWithID { order_id = "NO ORDER ID FOUND" } 298 299 responseToRefundURI :: BL.ByteString -> ResponseWithRefundURI 300 responseToRefundURI input = case decode input of 301 Just r -> r 302 Nothing -> ResponseWithRefundURI { taler_refund_uri = "NO REFUND URI FOUND" } 303 304 responseToRewardURL :: BL.ByteString -> ResponseWithRewardURL 305 responseToRewardURL input = case decode input of 306 Just r -> r 307 Nothing -> ResponseWithRewardURL { taler_reward_url = "NO REWARD URL FOUND" } 308 309 310 311 -- MAIN -- 312 main :: IO () 313 main = do 314 let settings = managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings 315 manager <- newTlsManagerWith settings 316 317 authenticationTest manager 318 319 response <- createOrder manager 320 321 let orderId = order_id $ responseToOrderID response 322 323 checkPaymentStatus manager orderId 324 325 requestRefund manager orderId 326 327 checkReserves manager 328 329 giveReward manager