Metrics

src/Wallabag.hs

@@ -1,44 +1,38 @@
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE StrictData #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -Wall #-}
 
 module Wallabag where
 
-import Control.Concurrent.STM (TVar, atomically, readTVar, retry, writeTVar)
+import Control.Concurrent.STM (atomically, readTVar, retry, writeTVar)
 import Control.Exception (Exception)
+import Control.Exception.Annotated (Annotation (..), checkpoint, throw)
 import Control.Lens (re, to, traversed, view, (&), (.~), (^.), (^..), (^?))
 import Control.Lens.TH (makeFields)
-import Control.Monad.Catch (MonadThrow, MonadCatch)
-import Control.Exception.Annotated (throw, checkpoint, Annotation (..))
+import Control.Monad.Catch (MonadCatch, MonadThrow)
 import Control.Monad.Reader (MonadReader, liftIO)
 import Creds
 import Data.Aeson (Value)
 import Data.Aeson.Lens (key, _Array, _Integer, _String)
 import Data.Generics.Product (HasType (..))
+import Data.Maybe (mapMaybe)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Strict.Lens (unpacked, utf8)
-import Data.Time (UTCTime, addUTCTime, getCurrentTime, secondsToNominalDiffTime)
-import Katip qualified as K
-import Network.Wreq (FormParam (..), defaults, getWith, header, post, postWith, responseBody)
-import UnliftIO (MonadIO)
+import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime)
 import GHC.Stack (HasCallStack)
-import qualified Streamly.Data.Stream.Prelude as Stream
-import Data.Maybe (mapMaybe)
-
-data Auth'
-  = Unauthenticated
-  | Authenticating
-  | Auth
-      { accessToken :: Text,
-        expires :: UTCTime
-      }
-  deriving (Show)
-
-type Auth = TVar Auth'
+import HTTP (HTTPMetric, Retry (SafeTransient), Trace, getWith, post, postWith, tracerMetrics)
+import Katip qualified as K
+import M (HasWallabagMetrics, wallabagMetrics)
+import Network.Wreq (FormParam (..), defaults, header, responseBody)
+import Streamly.Data.Stream.Prelude qualified as Stream
+import Tracer (Tracer (..))
+import UnliftIO (MonadIO)
+import Wallabag.Auth
 
 data Entry = Entry
   { _entryIdentifier :: Integer,
@@ -50,7 +44,14 @@ data Entry = Entry
 
 makeFields ''Entry
 
-authenticate :: (MonadReader r m, MonadIO m, K.KatipContext m) => Creds -> m (Maybe Auth')
+authenticate ::
+  ( MonadReader r m,
+    MonadIO m,
+    K.KatipContext m,
+    HasWallabagMetrics r HTTPMetric
+  ) =>
+  Creds ->
+  m (Maybe Auth')
 authenticate c = do
   K.logFM K.DebugS "Authenticating"
   let form =
@@ -60,7 +61,8 @@ authenticate c = do
           "username" := c ^. username,
           "password" := c ^. password
         ]
-  r <- liftIO $ post "https://app.wallabag.it/oauth/v2/token" form
+  metrics <- mkTracerMetrics
+  r <- liftIO $ post metrics SafeTransient "https://app.wallabag.it/oauth/v2/token" form
   now <- liftIO getCurrentTime
   let expiresIn = r ^? responseBody . key "expires_in" . _Integer . to fromIntegral . to secondsToNominalDiffTime
       expireTime = fmap (`addUTCTime` now) expiresIn
@@ -70,7 +72,15 @@ data WallabagException7g = MissingTokenException deriving (Show)
 
 instance Exception WallabagException7g
 
-getToken :: (HasType Creds r, HasType Auth r, MonadReader r m, MonadIO m, K.KatipContext m) => m (Maybe Text)
+getToken ::
+  ( HasType Creds r,
+    HasType Auth r,
+    MonadReader r m,
+    MonadIO m,
+    K.KatipContext m,
+    HasWallabagMetrics r HTTPMetric
+  ) =>
+  m (Maybe Text)
 getToken = do
   now <- liftIO getCurrentTime
   cache <- view (typed @Auth)
@@ -101,7 +111,8 @@ sourceEntries ::
     K.KatipContext m,
     MonadThrow m,
     MonadCatch m,
-    HasCallStack
+    HasCallStack,
+    HasWallabagMetrics r HTTPMetric
   ) =>
   Scan ->
   Stream.Stream m Entry
@@ -114,10 +125,11 @@ sourceEntries s = Stream.unfoldrM go (Just startUrl) & Stream.concatMap (Stream.
     go :: Maybe String -> m (Maybe ([Value], Maybe String))
     go Nothing = pure Nothing
     go (Just url) = checkpoint (Annotation url) $ do
+      metrics <- mkTracerMetrics
       t <- maybe (throw MissingTokenException) pure =<< getToken
       let opts = defaults & header "Authorization" .~ ["Bearer " <> t ^. re utf8]
       K.logFM K.DebugS $ K.ls ("Fetching entries '" <> url <> "'")
-      r <- liftIO $ getWith opts url
+      r <- liftIO $ getWith metrics SafeTransient opts url
       let items = r ^.. responseBody . key "_embedded" . key "items" . _Array . traversed
       let next = r ^? responseBody . key "_links" . key "next" . key "href" . _String . unpacked
       pure $ Just (items, next)
@@ -129,6 +141,11 @@ sourceEntries s = Stream.unfoldrM go (Just startUrl) & Stream.concatMap (Stream.
         <*> Just (v ^.. key "tags" . _Array . traversed . key "label" . _String)
         <*> v ^? key "title" . _String
 
+mkTracerMetrics :: (MonadReader r m, HasWallabagMetrics r HTTPMetric) => m (Tracer HTTP.Trace)
+mkTracerMetrics = do
+  m <- view wallabagMetrics
+  pure $ HTTP.tracerMetrics m
+
 applyTags ::
   ( HasType Auth r,
     HasType Creds r,
@@ -137,7 +154,8 @@ applyTags ::
     HasCallStack,
     K.KatipContext m,
     MonadThrow m,
-    MonadCatch m
+    MonadCatch m,
+    HasWallabagMetrics r HTTPMetric
   ) =>
   Entry ->
   m ()
@@ -146,5 +164,6 @@ applyTags e = checkpoint (Annotation $ e ^. identifier) $ do
   let opts = defaults & header "Authorization" .~ ["Bearer " <> t ^. re utf8]
   K.logFM K.InfoS (K.ls ("Applying tags for '" <> e ^. title <> "': " <> T.pack (show (e ^. tags))))
   let url = "https://app.wallabag.it/api/entries/" <> show (e ^. identifier) <> "/tags"
-  _ <- liftIO $ postWith opts url ["tags" := T.intercalate "," (e ^. tags)]
+  metrics <- mkTracerMetrics
+  _ <- liftIO $ postWith metrics SafeTransient opts url ["tags" := T.intercalate "," (e ^. tags)]
   pure ()