git.iko.soy/typeable/connexpay
on master help sign in
tmp
ade5e0eNick
connexpay.cabalnew file+67
compare with master
unifiedsplit
@@ -0,0 +1,67 @@
1+cabal-version: 3.0
2+name: connexpay
3+version: 0.1
4+synopsis: ConnexPay library for Haskell
5+homepage: https://github.com/downtowntravel/connexpay
6+license: NONE
7+author: Nick
8+maintainer: nick@typeable.io
9+copyright: Typeable.io
10+category: Web
11+build-type: Simple
12+-- extra-source-files:
13+
14+common warnings
15+ ghc-options: -Wall
16+
17+library
18+ import: warnings
19+ exposed-modules: Web.Connexpay
20+ Web.Connexpay.Auth
21+ Web.Connexpay.Data
22+ Web.Connexpay.Init
23+ Web.Connexpay.Payments
24+ Web.Connexpay.Types
25+ default-extensions: DuplicateRecordFields
26+ OverloadedLabels
27+ OverloadedRecordDot
28+ NoFieldSelectors
29+ -- other-modules:
30+ -- other-extensions:
31+ build-depends: base >=4.14 && < 5.0
32+ , aeson
33+ , async
34+ , bucks
35+ , bytestring
36+ , http-api-data
37+ , http-client
38+ , http-client-tls
39+ , mtl
40+ , req
41+ , text
42+ , uuid
43+ hs-source-dirs: src
44+ default-language: GHC2021
45+
46+executable connexpay-tool
47+ import: warnings
48+ default-extensions: DuplicateRecordFields
49+ OverloadedLabels
50+ OverloadedRecordDot
51+ NoFieldSelectors
52+ build-depends: base >= 4.17
53+ , aeson
54+ , async
55+ , bucks
56+ , bytestring
57+ , http-api-data
58+ , http-client
59+ , http-client-tls
60+ , mtl
61+ , req
62+ , text
63+ , uuid
64+ , yaml
65+ hs-source-dirs: src
66+ main-is: Tool.hs
67+ default-language: GHC2021
src/Tool.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main where
3+
4+import Data.Aeson
5+import Data.Text (Text)
6+import Data.Text.IO qualified as Text
7+import Data.UUID
8+import Data.Yaml
9+import GHC.Generics
10+import Network.HTTP.Client.TLS
11+import System.Environment
12+import Web.Connexpay
13+
14+data Config = Config { login :: Text
15+ , password :: Text
16+ , host :: Text
17+ , device_guid :: UUID
18+ } deriving Generic
19+
20+instance FromJSON Config
21+
22+writeLog :: Text -> IO ()
23+writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)
24+
25+main :: IO ()
26+main = do cmdLine <- getArgs
27+ cnf :: Config <- decodeFileThrow (head cmdLine)
28+ mgr <- newTlsManager
29+ res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.login cnf.password
30+ case res of
31+ Left err -> putStrLn ("Error: " <> show err)
32+ Right _ -> pure ()
src/Web/Connexpay.hsnew file+5
@@ -0,0 +1,5 @@
1+module Web.Connexpay ( module Export
2+ ) where
3+
4+import Web.Connexpay.Init as Export
5+import Web.Connexpay.Types as Export
src/Web/Connexpay/Auth.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Web.Connexpay.Auth (authenticate) where
4+
5+import Web.Connexpay.Types
6+
7+import Control.Monad.Reader
8+import Data.Aeson
9+import Data.Aeson.Types
10+import Data.ByteString (ByteString)
11+import Data.ByteString qualified as ByteString
12+import Data.Text (Text)
13+import Data.Text qualified as Text
14+import Network.HTTP.Req
15+import Numeric.Natural
16+import Web.FormUrlEncoded
17+import Web.HttpApiData
18+
19+data AuthForm = AuthForm { login :: Text
20+ , password :: Text
21+ }
22+
23+instance ToForm AuthForm where
24+ toForm auth = [ ("grant_type", toQueryParam ("password" :: Text))
25+ , ("username", toQueryParam auth.login)
26+ , ("password", toQueryParam auth.password)
27+ ]
28+
29+mkAuthForm :: Text -> Text -> ByteString
30+mkAuthForm login passwd = ByteString.toStrict (urlEncodeAsForm form)
31+ where form = AuthForm login passwd
32+
33+data TokenReply = TokenReply { token :: BearerToken
34+ , expires_in :: Natural
35+ } deriving (Show)
36+
37+instance FromJSON TokenReply where
38+ parseJSON (Object v) = do typ <- v .: "token_type"
39+ unless (typ == "bearer") $
40+ fail ("Unsupported token type returned: " <> Text.unpack typ)
41+ TokenReply <$> v .: "access_token"
42+ <*> v .: "expires_in"
43+ parseJSON v = typeMismatch "TokenReply" v
44+
45+authenticate :: ConnexpayM (BearerToken, Natural)
46+authenticate = do login <- asks (.login)
47+ password <- asks (.password)
48+ host <- asks (.url)
49+ let body = ReqBodyBs (mkAuthForm login password)
50+ url = https host /: "api" /: "v1" /: "token"
51+ resp <- req POST url body jsonResponse mempty
52+ let TokenReply tok ts = responseBody resp
53+ pure (tok, ts)
src/Web/Connexpay/Data.hsnew file+31
@@ -0,0 +1,31 @@
1+module Web.Connexpay.Data where
2+
3+import Web.Connexpay.Types
4+
5+import Data.Money (Money, USD)
6+import Data.Text (Text)
7+
8+-- | Create sale request type.
9+-- This is far from the complete description, but should be enough for our cause.
10+-- See documentation here: https://docs.connexpay.com/reference/getting-started-with-your-api
11+data CreateSale = CreateSale { deviceGuid :: DeviceGuid
12+ , amount :: Money USD
13+ , sequenceCode :: Text
14+ , orderCode :: Text
15+ , statementDesc :: Maybe Text
16+ } deriving (Show)
17+
18+data CreateSaleResponse = CreateSaleResponse { -- Fill this later as needed
19+ } deriving (Show)
20+
21+-- | Void a previously create sale
22+-- Documentation: https://docs.connexpay.com/reference/void
23+data VoidSale = VoidSale { deviceGuid :: DeviceGuid
24+ , saleGuid :: SaleGuid
25+ , reason :: Maybe Text
26+ , amount :: Maybe (Money USD)
27+ , sequenceCode :: Text
28+ } deriving (Show)
29+
30+data VoidSaleResponse = VoidSaleResponse { -- Fill this later as needed
31+ } deriving (Show)
src/Web/Connexpay/Init.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Web.Connexpay.Init where
3+
4+import Web.Connexpay.Auth
5+import Web.Connexpay.Types
6+
7+import Control.Concurrent
8+import Control.Concurrent.Async
9+import Control.Monad
10+import Control.Monad.Except (catchError)
11+import Control.Monad.IO.Class
12+import Control.Monad.Reader (asks)
13+import Data.Text (Text)
14+import Data.Text qualified as Text
15+import Network.HTTP.Client (Manager)
16+import Numeric.Natural
17+
18+initConnexpay :: (Text -> IO ()) -> Manager -> DeviceGuid -> Text -> Text -> Text -> IO (Either PaymentError Connexpay)
19+initConnexpay logf mgr devguid url login password =
20+ do v <- newEmptyMVar
21+ let env = Connexpay { logAction = logf
22+ , manager = mgr
23+ , bearerToken = v
24+ , refreshAsync = Nothing
25+ , deviceGuid = devguid
26+ , url = url
27+ , login = login
28+ , password = password
29+ }
30+ runConnexpay env $ do
31+ (tok, ts) <- authenticate
32+ a <- liftIO $ do logf "Connexpay authentication success"
33+ putMVar v tok
34+ async (void $ runConnexpay env $ updateToken ts)
35+ pure (env { refreshAsync = Just a })
36+
37+updateToken :: Natural -> ConnexpayM ()
38+updateToken w = liftIO (threadDelay w') >> upd
39+ where w' = fromIntegral w * 1000000
40+ upd = do (tok, ts) <- authenticate
41+ logf <- asks (.logAction)
42+ tokVar <- asks (.bearerToken)
43+ liftIO (putMVar tokVar tok)
44+ liftIO (logf "Connexpay token update success")
45+ updateToken (ts - 5)
46+ `catchError` \err -> do
47+ logf <- asks (.logAction)
48+ liftIO (logf ("Connexpay token update failure: " <> Text.pack (show err)))
49+ updateToken 5
src/Web/Connexpay/Payments.hsnew file+69
@@ -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+ ]
src/Web/Connexpay/Types.hsnew file+51
@@ -0,0 +1,51 @@
1+module Web.Connexpay.Types where
2+
3+import Control.Concurrent.Async
4+import Control.Concurrent.MVar (MVar, readMVar)
5+import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
6+import Control.Monad.IO.Class
7+import Control.Monad.Reader
8+import Data.Text (Text)
9+import Data.UUID (UUID)
10+import Network.HTTP.Client (Manager, HttpException(..), HttpExceptionContent)
11+import Network.HTTP.Req
12+
13+type BearerToken = Text
14+type DeviceGuid = UUID
15+type SaleGuid = UUID
16+
17+data Connexpay = Connexpay { logAction :: Text -> IO ()
18+ , manager :: Manager
19+ , bearerToken :: MVar BearerToken
20+ , refreshAsync :: Maybe (Async ())
21+ , deviceGuid :: DeviceGuid
22+ , url :: Text
23+ , login :: Text
24+ , password :: Text
25+ }
26+
27+data PaymentError = AuthFailure
28+ | ParseError String
29+ | InvalidUrl String String
30+ | HttpFailure HttpExceptionContent
31+ deriving (Show)
32+
33+
34+newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT PaymentError IO) a)
35+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError PaymentError)
36+
37+instance MonadHttp ConnexpayM where
38+ handleHttpException (JsonHttpException e) = throwError (ParseError e)
39+ handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (InvalidUrl url why)
40+ handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (HttpFailure c)
41+
42+ getHttpConfig = do mgr <- asks (.manager)
43+ pure (defaultHttpConfig { httpConfigAltManager = Just mgr })
44+
45+
46+runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either PaymentError a)
47+runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)
48+
49+bearerToken :: ConnexpayM BearerToken
50+bearerToken = do v <- asks (.bearerToken)
51+ liftIO (readMVar v)
stack.yamlnew file+11
@@ -0,0 +1,11 @@
1+resolver: lts-21.9
2+
3+packages:
4+- .
5+
6+extra-deps:
7+ - git: https://github.com/typeable/bucks.git
8+ commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
9+
10+nix:
11+ packages: [zlib]