799bfc1 · typeable/connexpay

connexpay.cabal+1

compare with master

unifiedsplit

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

22 Web.Connexpay.Init

23 Web.Connexpay.Payments

24 Web.Connexpay.Types

25+ Web.Connexpay.Utils

25 default-extensions: DuplicateRecordFields

26 default-extensions: DuplicateRecordFields

26 OverloadedLabels

27 OverloadedLabels

27 OverloadedRecordDot

28 OverloadedRecordDot

src/Tool.hs+3

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

18import Network.HTTP.Client.TLS

19import Options.Applicative

20import Web.Connexpay

21+import Web.Connexpay (capturePayment)

21

22

22data Config = Config { login :: Text

23data Config = Config { login :: Text

23 , password :: Text

24 , password :: Text

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

75doThing :: Command -> ConnexpayM ()

76doThing :: Command -> ConnexpayM ()

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

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

77 where usd = Money amt

78 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

4

5import Web.Connexpay.Types

6

7+import Control.Monad

7import Control.Monad.Reader

8import Control.Monad.Reader

8import Data.Aeson

9import Data.Aeson

9import Data.Aeson.Types

10import Data.Aeson.Types

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

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

3

4import Web.Connexpay.Auth

5import Web.Connexpay.Types

6+import Web.Connexpay.Utils

6

7

7import Control.Concurrent

8import Control.Concurrent

8import Control.Concurrent.Async

9import Control.Concurrent.Async

9−import Control.Monad

10import Control.Monad.Except (catchError)

11import Control.Monad.IO.Class

12import Control.Monad.Reader (asks)

13import Data.Text (Text)

14−import Data.Text qualified as Text

15import Network.HTTP.Client (Manager)

14import Network.HTTP.Client (Manager)

16import Numeric.Natural

15import Numeric.Natural

17

16

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

31 (tok, ts) <- authenticate

30 (tok, ts) <- authenticate

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

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

33 putMVar v tok

32 putMVar v tok

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

33+ async (runConnexpay_ env $ updateToken ts)

35 pure (env { refreshAsync = Just a })

34 pure (env { refreshAsync = Just a })

36

35

37updateToken :: Natural -> ConnexpayM ()

36updateToken :: Natural -> ConnexpayM ()

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

45 updateToken (ts - 5)

44 updateToken (ts - 5)

46 `catchError` \err -> do

45 `catchError` \err -> do

47 logf <- asks (.logAction)

46 logf <- asks (.logAction)

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

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

49 updateToken 5

48 updateToken 5

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

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

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

5 , AuthResponse(..)

6 , authorisePayment

7+ , voidPayment

8+ , capturePayment

9+ , cancelPayment

7 ) where

10 ) where

8

11

12+import Web.Connexpay.Utils

13+

14+import Control.Monad (void)

9import Control.Monad.Reader (asks)

15import Control.Monad.Reader (asks)

10import Control.Monad.Writer.Strict

16import Control.Monad.Writer.Strict

11import Data.Aeson

17import Data.Aeson

12−import Data.Aeson.Types (typeMismatch)

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

13import Data.Money

19import Data.Money

20+import Data.Proxy

14import Data.Text (Text)

21import Data.Text (Text)

15import Data.Text qualified as Text

22import Data.Text qualified as Text

16import Data.Text.Encoding qualified as Text

23import Data.Text.Encoding qualified as Text

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

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

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

50 | otherwise = t

57 | otherwise = t

51

58

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

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

53−whenJust (Just x) f = f x

60+sendRequest' resp endpoint body =

54−whenJust Nothing _ = pure ()

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

55

72

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

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

57−tshow = Text.pack . show

74+sendRequest_ ep = void . sendRequest' ignoreResponse ep

58

75

59−data AuthResponse = AuthResponse { paymentGuid :: Text

76+data AuthResponse = AuthResponse { paymentGuid :: SaleGuid

60 , status :: TransactionStatus

77 , status :: TransactionStatus

61 , processorStatusCode :: Maybe Text

78 , processorStatusCode :: Maybe Text

62 , processorMessage :: Maybe Text

79 , processorMessage :: Maybe Text

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

70 parseJSON v = typeMismatch "AuthReponse" v

87 parseJSON v = typeMismatch "AuthReponse" v

71

88

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

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

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

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

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

80 pure (responseBody resp)

91 pure (responseBody resp)

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

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

82− , "Amount" .= getAmount amt

93+ , "Amount" .= getAmount amt

83− , "DeviceGuid" .= show guid

94+ ]

84− ]

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 #-}

1module Web.Connexpay.Types where

2module Web.Connexpay.Types where

2

3

4+import Web.Connexpay.Utils

5+

3import Control.Concurrent.Async

6import Control.Concurrent.Async

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

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

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

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

6import Control.Monad.IO.Class

9import Control.Monad.IO.Class

7import Control.Monad.Reader

10import Control.Monad.Reader

8import Data.Text (Text)

11import Data.Text (Text)

12+import Data.Text qualified as Text

9import Data.UUID (UUID)

13import Data.UUID (UUID)

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

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

11import Network.HTTP.Req

15import Network.HTTP.Req

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

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

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

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

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

48

52

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+

49bearerToken :: ConnexpayM BearerToken

59bearerToken :: ConnexpayM BearerToken

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

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

51 liftIO (readMVar v)

61 liftIO (readMVar v)

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

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

1+module Web.Connexpay.Utils where

2+

3+import Data.Text (Text)

4+import Data.Text qualified as Text

5+

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

7+whenLeft (Left l) f = f l

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

9+

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

2

3packages:

4- .

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

9

10nix:

11 packages: [zlib]

12+local-bin-path: bin