diff options
Diffstat (limited to 'Haskell/merchant-api-tutorial/taler-merchant-api-tutorial.hs')
| -rw-r--r-- | Haskell/merchant-api-tutorial/taler-merchant-api-tutorial.hs | 329 |
1 files changed, 329 insertions, 0 deletions
diff --git a/Haskell/merchant-api-tutorial/taler-merchant-api-tutorial.hs b/Haskell/merchant-api-tutorial/taler-merchant-api-tutorial.hs new file mode 100644 index 0000000..56b668c --- /dev/null +++ b/Haskell/merchant-api-tutorial/taler-merchant-api-tutorial.hs @@ -0,0 +1,329 @@ +-- SPDX-FileCopyrightText: 2023 Vint Leenaars <vl.software@leenaa.rs> +-- SPDX-License-Identifier: Apache-2.0 +-- SPDX-License-Identifier: EUPL-1.2 +-- SPDX-License-Identifier: MPL-2.0 +-- SPDX-License-Identifier: AGPL-3.0-or-later + +-- See https://docs.taler.net/taler-merchant-api-tutorial.html for full tutorial +-- +-- GNU Taler is an open protocol for an electronic payment system with a free +-- software reference implementation. GNU Taler offers secure, fast and easy +-- payment processing using well understood cryptographic techniques. GNU Taler +-- allows customers to remain anonymous, while ensuring that merchants can be +-- held accountable by governments. Hence, GNU Taler is compatible with +-- anti-money-laundering (AML) and know-your-customer (KYC) regulation, as well +-- as data protection regulation (such as GDPR). + +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} + +-- IMPORTS -- +import Data.Aeson (FromJSON (..), (.=), object, encode, decode) +import Network.HTTP +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Types +import Network.URI + +import Data.ByteString.Lazy as BL +import Data.ByteString as B + +import Control.Monad (when) + +import GHC.Generics + +-- VARIABLES + +-- Domain name of the sandbox backend +domainName :: String +domainName = "https://backend.demo.taler.net/private/" + +-- Domain name of the sandbox backends orders +domainNameOrder :: String +domainNameOrder = "https://backend.demo.taler.net/private/orders" + +-- Key of the Authorization header ("Bearer secret-token:$KEY") +secretToken :: B.ByteString +secretToken = "sandbox" + +-- 4.1.4 Public Sandbox Backend and Authentication +-- https://docs.taler.net/taler-merchant-api-tutorial.html#public-sandbox-backend-and-authentication + +-- The public sandbox backend https://backend.demo.taler.net/ uses an API key +-- in the Authorization header. The value of this header must be Bearer +-- secret-token:secret for the public sandbox backend. + +-- The function 'authenticationTest' tests if authenticating to the backend works: + +authenticationTest :: Manager -> IO () +authenticationTest manager = do + initialized_request <- parseRequest domainNameOrder + + response <- httpLbs initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] } manager + + let status_code = statusCode $ responseStatus response + + print $ "Function 'authenticationTest' returned status code: " ++ show status_code + + when (not $ status_code == 200) $ printHint response + +-- This should return HTTP status code 200. + + + +-- 4.2.1: Creating an Order for a Payment +-- https://docs.taler.net/taler-merchant-api-tutorial.html#creating-an-order-for-a-payment + +-- Payments in Taler revolve around an order, which is a machine-readable +-- description of the business transaction for which the payment is to be made. +-- Before accepting a Taler payment as a merchant you must create such an +-- order. + +-- The function 'createOrder' creates a minimal order and returns a response: + +createOrder :: Manager -> IO BL.ByteString +createOrder manager = do + initialized_request <- parseRequest domainNameOrder + + let order = object [ "create_token" .= False + , "order" .= object [ "amount" .= ("KUDOS:10" :: String) + , "summary" .= ("Donation" :: String) + , "fulfillment_url" .= ("https://example.com/thanks.html" :: String) ] ] + + let request = initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken )] + , method = "POST" + , requestBody = RequestBodyLBS $ encode order } + + response <- httpLbs request manager + + let status_code = statusCode $ responseStatus response + + print $ "Function 'createOrder' returned status code: " ++ show status_code + + if status_code == 200 + then print $ "Created an order with ID: " ++ (order_id $ responseToOrderID $ responseBody response) + else printHint response + + return $ responseBody response + + +-- The backend will fill in some details missing in the order, such as the +-- address of the merchant instance. The full details are called the contract +-- terms. + +-- After successfully POSTing to /private/orders, a JSON with just an order_id +-- field with a string representing the order ID will be returned. + + + +-- 4.2.2: Checking Payment Status +-- https://docs.taler.net/taler-merchant-api-tutorial.html#checking-payment-status-and-prompting-for-payment + +-- Given the order ID, the status of a payment can be checked with the +-- /private/orders/$ORDER_ID endpoint. If the payment is yet to be completed by +-- the customer, /private/orders/$ORDER_ID will give the frontend a URL (under +-- the name payment_redirect_url) that will trigger the customer’s wallet to +-- execute the payment. + +-- The function 'checkPaymentStatus' checks what the current status of the +-- payment with given order_id is: + +checkPaymentStatus :: Manager -> String -> IO () +checkPaymentStatus manager order_id = do + + initialized_request <- parseRequest ( domainNameOrder ++ "/" ++ order_id ) + response <- httpLbs ( initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] } ) manager + + let status_code = statusCode $ responseStatus response + + print $ "Function 'checkPaymentStatus' returned status code: " ++ show status_code + + if status_code == 200 + then print $ responseBody response + else printHint response + + +-- If the order_status field in the response is paid, you will not get a +-- payment_redirect_url and instead information about the payment status, +-- including contract_terms (the full contract terms of the order), +-- refunded (true if a (possibly partial) refund was granted for this purchase) +-- and refunded_amount (amount that was refunded). + + + +-- 4.3: Giving Refunds +-- https://docs.taler.net/taler-merchant-api-tutorial.html#index-9 + +-- A refund in GNU Taler is a way to “undo” a payment. It needs to be +-- authorized by the merchant. Refunds can be for any fraction of the original +-- amount paid, but they cannot exceed the original payment. Refunds are +-- time-limited and can only happen while the exchange holds funds for a +-- particular payment in escrow. The time during which a refund is possible can +-- be controlled by setting the refund_deadline in an order. The default value +-- for this refund deadline is specified in the configuration of the merchant’s +-- backend. +-- +-- The frontend can instruct the merchant backend to authorize a refund by +-- POSTing to the /private/orders/$ORDER_ID/refund endpoint. + +-- The function 'requestRefund' requests for a refund: + +requestRefund :: Manager -> String -> IO () +requestRefund manager order_id = do + + initialized_request <- parseRequest ( domainNameOrder ++ "/" ++ order_id ++ "/refund" ) + + let order_refund = object [ "refund" .= ("KUDOS:10" :: String) + , "reason" .= ("Customer did not like the product" :: String) ] + + let refund_request = initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] + , method = "POST" + , requestBody = RequestBodyLBS $ encode order_refund } + + response <- httpLbs refund_request manager + + let status_code = statusCode $ responseStatus response + + print $ "Function 'requestRefund' returned status code: " ++ show status_code + + if status_code == 200 + then print $ "Succesfully created request for refund, send customer to: " + ++ (taler_refund_uri $ responseToRefundURI $ responseBody response) + else printHint response + + +-- If the request is successful (indicated by HTTP status code 200), the +-- response includes a taler_refund_uri. The frontend must redirect the +-- customer’s browser to that URL to allow the refund to be processed by the +-- wallet. + + + +-- 4.5 Giving Customers Rewards +-- https://docs.taler.net/taler-merchant-api-tutorial.html#index-11 + +-- GNU Taler allows Web sites to grant digital cash directly to a visitor. The +-- idea is that some sites may want incentivize actions such as filling out a +-- survey or trying a new feature. It is important to note that receiving +-- rewards is not enforceable for the visitor, as there is no contract. It is +-- simply a voluntary gesture of appreciation of the site to its visitor. +-- However, once a reward has been granted, the visitor obtains full control +-- over the funds provided by the site. + +-- The function 'checkReserves' checks if rewards are confiured properly and +-- if there are sufficient funds avaliable for granting rewards: + +checkReserves :: Manager -> IO () +checkReserves manager = do + + initialized_request <- parseRequest $ domainName ++ "reserves" + + response <- httpLbs ( initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] } ) manager + + let status_code = statusCode $ responseStatus response + + print $ "Function 'checkReserves' returned status code: " ++ show status_code + + if status_code == 200 + + -- Check that a reserve exists where the merchant_initial_amount is below the + -- committed_amount and that the reserve is active. + then print $ BL.append "Reserves found: " (responseBody response) + + else printHint response + +-- The response from the backend contains a taler_reward_url. The customer’s +-- browser must be redirected to this URL for the wallet to pick up the reward. + + + +-- The function 'giveReward' illustrates giving a reward +giveReward :: Manager -> IO () +giveReward manager = do + + initialized_request <- parseRequest $ domainName ++ "rewards" + + let order = object [ "amount" .= ("KUDOS:0.5" :: String) + , "justification" .= ("User filled out survey" :: String) + , "next_url" .= ("https://merchant.com/thanks.html" :: String) ] + + let reward_request = initialized_request { requestHeaders = [(hAuthorization, B.append "Bearer secret-token:" secretToken)] + , method = methodPost + , requestBody = RequestBodyLBS $ encode order } + + response <- httpLbs reward_request manager + + print response + + let status_code = statusCode $ responseStatus response + + print $ "Function 'giveReward' returned status code: " ++ show status_code + + if status_code == 200 + then print $ "Reward created, redirect customer to: " + ++ (taler_reward_url $ responseToRewardURL $ responseBody response) + else printHint response + + +-- HELPER FUNCTIONS & CUSTOM DATA TYPES + +printHint :: Network.HTTP.Client.Response BL.ByteString -> IO () +printHint response = do + print $ B.append "Status message: " (statusMessage $ responseStatus response) + case decode $ responseBody response :: Maybe FailedResponse of + Just help -> print $ Prelude.concat [ "Hint ", "(code ", show $ code help, "): ", hint help ] + Nothing -> return () + +data ResponseWithID = ResponseWithID { + order_id :: String } deriving (Show, Eq, Generic) + +data ResponseWithRefundURI = ResponseWithRefundURI { + taler_refund_uri :: String } deriving (Show, Eq, Generic) + +data ResponseWithRewardURL = ResponseWithRewardURL { + taler_reward_url :: String } deriving (Show, Eq, Generic) + +data FailedResponse = FailedResponse + { hint :: String + , code :: Int } deriving (Show, Eq, Generic) + +instance FromJSON ResponseWithID +instance FromJSON ResponseWithRefundURI +instance FromJSON ResponseWithRewardURL +instance FromJSON FailedResponse + +responseToOrderID :: BL.ByteString -> ResponseWithID +responseToOrderID input = case decode input of + Just r -> r + Nothing -> ResponseWithID { order_id = "NO ORDER ID FOUND" } + +responseToRefundURI :: BL.ByteString -> ResponseWithRefundURI +responseToRefundURI input = case decode input of + Just r -> r + Nothing -> ResponseWithRefundURI { taler_refund_uri = "NO REFUND URI FOUND" } + +responseToRewardURL :: BL.ByteString -> ResponseWithRewardURL +responseToRewardURL input = case decode input of + Just r -> r + Nothing -> ResponseWithRewardURL { taler_reward_url = "NO REWARD URL FOUND" } + + + +-- MAIN -- +main :: IO () +main = do + let settings = managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings + manager <- newTlsManagerWith settings + + authenticationTest manager + + response <- createOrder manager + + let orderId = order_id $ responseToOrderID response + + checkPaymentStatus manager orderId + + requestRefund manager orderId + + checkReserves manager + + giveReward manager |