@@ -0,0 +1,69 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+module Web.Connexpay.Payments where
5+
6+import Control.Monad.Reader (asks)
7+import Control.Monad.Writer.Strict
8+import Data.Aeson
9+import Data.Money
10+import Data.Text (Text)
11+import Data.Text qualified as Text
12+import Data.Text.Encoding qualified as Text
13+import GHC.TypeError as TypeError
14+import Network.HTTP.Req
15+import Web.Connexpay.Types
16+import Data.Aeson.Types (typeMismatch)
17+
18+-- | Credit card info
19+-- No 'Show' instance should be made for this type
20+-- in order to avoid sensitive data leaks.
21+data CreditCard = CreditCard { number :: Text
22+ , cardholder :: Maybe Text
23+ , expiration :: (Word, Word) -- ^ Expiration date (month,year)
24+ , cvv :: Maybe Text
25+ }
26+
27+type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
28+
29+instance TypeError ShowError => Show CreditCard where
30+ show = error "UNREACHABLE"
31+
32+instance ToJSON CreditCard where
33+ toJSON cc = object $ execWriter $ do tell ["CardNumber" .= cc.number]
34+ whenJust cc.cardholder $ \name ->
35+ tell ["CardHolderName" .= name]
36+ whenJust cc.cvv $ \cvv ->
37+ tell ["Cvv2" .= cvv]
38+ let expDate = tshow (snd cc.expiration) <> tshow (fst cc.expiration)
39+ tell ["ExpirationDate" .= expDate]
40+
41+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
42+whenJust (Just x) f = f x
43+whenJust Nothing _ = pure ()
44+
45+tshow :: Show a => a -> Text
46+tshow = Text.pack . show
47+
48+data AuthResponse = AuthResponse { paymentGuid :: Text
49+ , status :: Text
50+ }
51+
52+instance FromJSON AuthResponse where
53+ parseJSON (Object o) = AuthResponse <$> o .: "guid"
54+ <*> o .: "status"
55+ parseJSON v = typeMismatch "AuthReponse" v
56+
57+authorisePayment :: CreditCard -> Money USD -> ConnexpayM AuthResponse
58+authorisePayment cc amt = do guid <- asks (.deviceGuid)
59+ tok <- bearerToken
60+ host <- asks (.url)
61+ let body = ReqBodyJson (reqBody guid)
62+ auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
63+ url = https host /: "api" /: "v1" /: "authonlys"
64+ resp <- req POST url body jsonResponse auth
65+ pure (responseBody resp)
66+ where reqBody guid = object [ "Card" .= cc
67+ , "Amount" .= getAmount amt
68+ , "DeviceGuid" .= show guid
69+ ]