799bfc1 · typeable/connexpay

git.iko.soy/typeable/connexpay

Bump

commit799bfc186baebf2d073e33fcede1395294f00f4a authorNick <nick@typeable.io> dateThu 21 Mar 2024, 23:19 (3 years ago) parent05635b3

8 files changed+78−23

compare with master

unifiedsplit

connexpay.cabal+1 src/Tool.hs+3 src/Web/Connexpay/Auth.hs+1 src/Web/Connexpay/Init.hs+3−4 src/Web/Connexpay/Payments.hs+43−18 src/Web/Connexpay/Types.hs+10 src/Web/Connexpay/Utils.hs+15 stack.yaml+2−1

connexpay.cabal+1

@@ -22,6 +22,7 @@ library

2222 Web.Connexpay.Init

2323 Web.Connexpay.Payments

2424 Web.Connexpay.Types

25+ Web.Connexpay.Utils

2526 default-extensions: DuplicateRecordFields

2627 OverloadedLabels

2728 OverloadedRecordDot

src/Tool.hs+3

@@ -18,6 +18,7 @@ import Network.HTTP.Client

1818import Network.HTTP.Client.TLS

1919import Options.Applicative

2020import Web.Connexpay

21+import Web.Connexpay (capturePayment)

2122

2223data Config = Config { login :: Text

2324 , password :: Text

@@ -75,3 +76,5 @@ main = do cmdLine <- execParser (info cmdParser mempty)

7576doThing :: Command -> ConnexpayM ()

7677doThing (AuthSale cc amt) = liftIO . print =<< authorisePayment cc usd

7778 where usd = Money amt

79+doThing (VoidSale guid) = liftIO . print =<< voidPayment guid Nothing

80+doThing (CaptureSale guid) = liftIO . print =<< capturePayment

src/Web/Connexpay/Auth.hs+1

@@ -4,6 +4,7 @@ module Web.Connexpay.Auth (authenticate) where

55import Web.Connexpay.Types

7+import Control.Monad

78import Control.Monad.Reader

89import Data.Aeson

910import Data.Aeson.Types

src/Web/Connexpay/Init.hs+3−4

@@ -3,15 +3,14 @@ module Web.Connexpay.Init where

44import Web.Connexpay.Auth

55import Web.Connexpay.Types

6+import Web.Connexpay.Utils

78import Control.Concurrent

89import Control.Concurrent.Async

9−import Control.Monad

1010import Control.Monad.Except (catchError)

1111import Control.Monad.IO.Class

1212import Control.Monad.Reader (asks)

1313import Data.Text (Text)

14−import Data.Text qualified as Text

1514import Network.HTTP.Client (Manager)

1615import Numeric.Natural

1716

@@ -31,7 +30,7 @@ initConnexpay logf mgr devguid url login password =

3130 (tok, ts) <- authenticate

3231 a <- liftIO $ do logf "Connexpay authentication success"

3332 putMVar v tok

34− async (void $ runConnexpay env $ updateToken ts)

33+ async (runConnexpay_ env $ updateToken ts)

3534 pure (env { refreshAsync = Just a })

3635

3736updateToken :: Natural -> ConnexpayM ()

@@ -45,5 +44,5 @@ updateToken w = liftIO (threadDelay w') >> upd

4544 updateToken (ts - 5)

4645 `catchError` \err -> do

4746 logf <- asks (.logAction)

48− liftIO (logf ("Connexpay token update failure: " <> Text.pack (show err)))

47+ liftIO (logf ("Connexpay token update failure: " <> tshow err))

4948 updateToken 5

src/Web/Connexpay/Payments.hs+43−18

@@ -4,13 +4,20 @@

44module Web.Connexpay.Payments ( CreditCard(..)

55 , AuthResponse(..)

66 , authorisePayment

7+ , voidPayment

8+ , capturePayment

9+ , cancelPayment

710 ) where

811

12+import Web.Connexpay.Utils

13+

14+import Control.Monad (void)

915import Control.Monad.Reader (asks)

1016import Control.Monad.Writer.Strict

1117import Data.Aeson

12−import Data.Aeson.Types (typeMismatch)

18+import Data.Aeson.Types (Pair, typeMismatch)

1319import Data.Money

20+import Data.Proxy

1421import Data.Text (Text)

1522import Data.Text qualified as Text

1623import Data.Text.Encoding qualified as Text

@@ -49,14 +56,24 @@ padDate :: Text -> Text

4956padDate t | Text.length t == 1 = "0" <> t

5057 | otherwise = t

5158

52−whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()

53−whenJust (Just x) f = f x

54−whenJust Nothing _ = pure ()

59+sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp

60+sendRequest' resp endpoint body =

61+ do tok <- bearerToken

62+ host <- asks (.url)

63+ let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)

64+ url = http host /: "api" /: "v1" /: endpoint

65+ jbody <- ReqBodyJson . object <$> addGuid body

66+ req POST url jbody resp auth

67+ where addGuid b = do guid <- asks (.deviceGuid)

68+ return (b <> [ "DeviceGuid" .= show guid ])

69+

70+sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)

71+sendRequestJson = sendRequest' jsonResponse

5572

56−tshow :: Show a => a -> Text

57−tshow = Text.pack . show

73+sendRequest_ :: Text -> [Pair] -> ConnexpayM ()

74+sendRequest_ ep = void . sendRequest' ignoreResponse ep

5875

59−data AuthResponse = AuthResponse { paymentGuid :: Text

76+data AuthResponse = AuthResponse { paymentGuid :: SaleGuid

6077 , status :: TransactionStatus

6178 , processorStatusCode :: Maybe Text

6279 , processorMessage :: Maybe Text

@@ -70,15 +87,23 @@ instance FromJSON AuthResponse where

7087 parseJSON v = typeMismatch "AuthReponse" v

7188

7289authorisePayment :: CreditCard -> Money USD -> ConnexpayM AuthResponse

73−authorisePayment cc amt = do guid <- asks (.deviceGuid)

74− tok <- bearerToken

75− host <- asks (.url)

76− let body = ReqBodyJson (reqBody guid)

77− auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)

78− url = https host /: "api" /: "v1" /: "authonlys"

79− resp <- req POST url body jsonResponse auth

90+authorisePayment cc amt = do resp <- sendRequestJson "authonlys" body

8091 pure (responseBody resp)

81− where reqBody guid = object [ "Card" .= cc

82− , "Amount" .= getAmount amt

83− , "DeviceGuid" .= show guid

84− ]

92+ where body = [ "Card" .= cc

93+ , "Amount" .= getAmount amt

94+ ]

95+

96+voidPayment :: SaleGuid -> Maybe (Money USD) -> ConnexpayM ()

97+voidPayment pid amt = sendRequest_ "void" body

98+ where body = execWriter $

99+ do tell [ "AuthOnlyGuid" .= show pid ]

100+ whenJust amt $ \m ->

101+ tell [ "Amount" .= getAmount m ]

102+

103+capturePayment :: SaleGuid -> ConnexpayM ()

104+capturePayment pid = sendRequest_ "Captures" body

105+ where body = [ "AuthOnlyGuid" .= show pid ]

106+

107+cancelPayment :: SaleGuid -> ConnexpayM ()

108+cancelPayment pid = sendRequest_ "cancel" body

109+ where body = [ "SaleGuid" .= show pid ]

src/Web/Connexpay/Types.hs+10

@@ -1,11 +1,15 @@

1+{-# LANGUAGE OverloadedStrings #-}

12module Web.Connexpay.Types where

4+import Web.Connexpay.Utils

36import Control.Concurrent.Async

47import Control.Concurrent.MVar (MVar, readMVar)

58import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)

69import Control.Monad.IO.Class

710import Control.Monad.Reader

811import Data.Text (Text)

12+import Data.Text qualified as Text

913import Data.UUID (UUID)

1014import Network.HTTP.Client (Manager, HttpException(..), HttpExceptionContent)

1115import Network.HTTP.Req

@@ -46,6 +50,12 @@ instance MonadHttp ConnexpayM where

4650runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either PaymentError a)

4751runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)

4852

53+runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()

54+runConnexpay_ cp m =

55+ do r <- runConnexpay cp m

56+ whenLeft r $ \err ->

57+ cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))

58+

4959bearerToken :: ConnexpayM BearerToken

5060bearerToken = do v <- asks (.bearerToken)

5161 liftIO (readMVar v)

src/Web/Connexpay/Utils.hsnew file+15

@@ -0,0 +1,15 @@

1+module Web.Connexpay.Utils where

3+import Data.Text (Text)

4+import Data.Text qualified as Text

6+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()

7+whenLeft (Left l) f = f l

8+whenLeft (Right _) _ = pure ()

10+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()

11+whenJust (Just x) f = f x

12+whenJust Nothing _ = pure ()

13+

14+tshow :: Show a => a -> Text

15+tshow = Text.pack . show

stack.yaml+2−1

@@ -1,4 +1,4 @@

1−resolver: lts-21.9

1+resolver: lts-22.13

33packages:

44- .

@@ -9,3 +9,4 @@ extra-deps:

1010nix:

1111 packages: [zlib]

12+local-bin-path: bin