4ad16cf · typeable/connexpay

connexpay/src/Web/Connexpay/Data.hs+1

compare with master

unifiedsplit

@@ -80,6 +80,7 @@ instance FromJSON ErrorMessage where

80data ConnectionError = ParseError String

81 | InvalidUrl String String

82 | HttpFailure HttpExceptionContent

83+ | TokenError String

83 deriving Show

84 deriving Show

84

85

85-- | Error type for Connexpay.

86-- | Error type for Connexpay.

connexpay/src/Web/Connexpay/Init.hs+18−7

@@ -1,5 +1,5 @@

1{-# LANGUAGE OverloadedStrings #-}

2−module Web.Connexpay.Init where

2+module Web.Connexpay.Init (initConnexpay) where

3

4import Web.Connexpay.Auth

5import Web.Connexpay.Data

@@ -26,7 +26,7 @@ initConnexpay :: (Text -> IO ()) -- ^ Logging function

26 -> Text -- ^ Password.

27 -> IO (Either ConnexpayError Connexpay)

28initConnexpay logf mgr devguid url tls login password =

29− do v <- newEmptyMVar

29+ do v <- newMVar Nothing

30 let env = Connexpay { logAction = logf

31 , manager = mgr

32 , bearerToken = v

@@ -38,19 +38,30 @@ initConnexpay logf mgr devguid url tls login password =

38 , password = password

39 }

40 runConnexpay env $ do

41− (tok, ts) <- authenticate

41+ ts <- initialAuth v logf

42− a <- liftIO $ do logf "Connexpay authentication success"

43− putMVar v tok

44− async (runConnexpay_ env $ updateToken ts)

42+ a <- liftIO (async (runConnexpay_ env $ updateToken ts))

45 pure (env { refreshAsync = Just a })

43 pure (env { refreshAsync = Just a })

46

44

45+initialAuth :: MVar (Maybe BearerToken) -> (Text -> IO ()) -> ConnexpayM Natural

46+initialAuth v logf =

47+ do (tok, ts) <- authenticate

48+ liftIO $ do logf "Connexpay authentication success"

49+ void (swapMVar v (Just tok))

50+ return ts

51+ `catchError` \err -> do

52+ liftIO (logf ("Initial connexpay authentication failed: " <> tshow err))

53+ -- if initial authentication failed, wait 1 second?

54+ -- there isn't much else to do, really.

55+ return 1

56+

57+

47updateToken :: Natural -> ConnexpayM ()

58updateToken :: Natural -> ConnexpayM ()

48updateToken w = liftIO (threadDelay w') >> upd

59updateToken w = liftIO (threadDelay w') >> upd

49 where w' = fromIntegral w * 1000000

60 where w' = fromIntegral w * 1000000

50 upd = do (tok, ts) <- authenticate

61 upd = do (tok, ts) <- authenticate

51 logf <- asks (.logAction)

62 logf <- asks (.logAction)

52 tokVar <- asks (.bearerToken)

63 tokVar <- asks (.bearerToken)

53− liftIO (void $ swapMVar tokVar tok)

64+ liftIO (void $ swapMVar tokVar (Just tok))

54 liftIO (logf "Connexpay token update success")

65 liftIO (logf "Connexpay token update success")

55 updateToken (ts - 5)

66 updateToken (ts - 5)

56 `catchError` \err -> do

67 `catchError` \err -> do

connexpay/src/Web/Connexpay/Payments.hs+4−1

@@ -64,7 +64,10 @@ padDate t | Text.length t == 1 = "0" <> t

64

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

66sendRequest' resp endpoint body =

67− do tok <- bearerToken

67+ do mtok <- bearerToken

68+ tok <- case mtok of

69+ Just t -> pure t

70+ Nothing -> throwError (ConnectionError $ TokenError "No authentication token available. Check connection parameters?")

68 host <- asks (.url)

71 host <- asks (.url)

69 tls <- asks (.useTLS)

72 tls <- asks (.useTLS)

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

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

connexpay/src/Web/Connexpay/Types.hs+2−2

@@ -25,7 +25,7 @@ type CaptureGuid = UUID

25

26data Connexpay = Connexpay { logAction :: Text -> IO ()

27 , manager :: Manager

28− , bearerToken :: MVar BearerToken

28+ , bearerToken :: MVar (Maybe BearerToken)

29 , refreshAsync :: Maybe (Async ())

30 , deviceGuid :: DeviceGuid

31 , url :: Text

@@ -58,7 +58,7 @@ runConnexpay_ cp m =

58 whenLeft r $ \err ->

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

60

61−bearerToken :: ConnexpayM BearerToken

61+bearerToken :: ConnexpayM (Maybe BearerToken)

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

63 liftIO (readMVar v)

64

stack.yaml+1−1

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

1−resolver: lts-22.24

1+resolver: lts-22.36

2

3packages:

4- connexpay