Service

src/Wallabag.hs

@@ -8,16 +8,19 @@
 
 module Wallabag where
 
-import Control.Concurrent.STM (atomically, readTVar, retry, writeTVar)
+import Control.Concurrent.STM (readTVar, retry, writeTVar)
 import Control.Exception (Exception)
 import Control.Exception.Annotated (Annotation (..), checkpoint, throw)
+import Control.Exception.Annotated.UnliftIO (catch)
 import Control.Lens (re, to, traversed, view, (&), (.~), (^.), (^..), (^?))
 import Control.Lens.TH (makeFields)
+import Control.Monad ((<=<))
 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.Functor.Contravariant ((>$<))
 import Data.Generics.Product (HasType (..))
 import Data.Maybe (mapMaybe)
 import Data.Text (Text)
@@ -25,13 +28,17 @@ import Data.Text qualified as T
 import Data.Text.Strict.Lens (unpacked, utf8)
 import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime)
 import GHC.Stack (HasCallStack)
-import HTTP (HTTPMetric, Retry (SafeTransient), Trace, getWith, post, postWith, tracerMetrics)
+import HTTP (HTTPMetric, Retry (SafeTransient), Trace (..), getWith, logFormatter, post, postWith, tracerMetrics)
 import Katip qualified as K
-import M (HasWallabagMetrics, wallabagMetrics)
+import M (HasKatipTracer, HasWallabagMetrics, KatipTracer, katipTracer, wallabagMetrics)
+import Network.HTTP.Client (HttpException)
 import Network.Wreq (FormParam (..), defaults, header, responseBody)
-import Streamly.Data.Stream.Prelude qualified as Stream
+import Pipes ((>->))
+import Pipes qualified
+import Pipes.Prelude qualified as P
 import Tracer (Tracer (..))
-import UnliftIO (MonadIO)
+import UnliftIO (MonadIO, MonadUnliftIO)
+import UnliftIO.STM (atomically)
 import Wallabag.Auth
 
 data Entry = Entry
@@ -48,7 +55,8 @@ authenticate ::
   ( MonadReader r m,
     MonadIO m,
     K.KatipContext m,
-    HasWallabagMetrics r HTTPMetric
+    HasWallabagMetrics r HTTPMetric,
+    HasKatipTracer r KatipTracer
   ) =>
   Creds ->
   m (Maybe Auth')
@@ -73,15 +81,19 @@ data WallabagException7g = MissingTokenException deriving (Show)
 instance Exception WallabagException7g
 
 getToken ::
+  forall m r.
   ( HasType Creds r,
     HasType Auth r,
     MonadReader r m,
     MonadIO m,
     K.KatipContext m,
-    HasWallabagMetrics r HTTPMetric
+    HasWallabagMetrics r HTTPMetric,
+    HasKatipTracer r KatipTracer,
+    MonadUnliftIO m,
+    MonadThrow m
   ) =>
   m (Maybe Text)
-getToken = do
+getToken = handle revertToUnauthenticated $ do
   now <- liftIO getCurrentTime
   cache <- view (typed @Auth)
   token <- liftIO $ atomically $ do
@@ -94,13 +106,20 @@ getToken = do
         | otherwise -> Nothing <$ writeTVar cache Authenticating
   maybe (reAuthenticate cache) (pure . Just) token
   where
+    handle :: (Exception e) => (e -> m a) -> m a -> m a
+    handle = flip catch
+    revertToUnauthenticated :: HttpException -> m (Maybe Text)
+    revertToUnauthenticated e = do
+      cache <- view (typed @Auth)
+      atomically $ writeTVar cache Unauthenticated
+      throw e
     reAuthenticate cache = do
       a <- view (typed @Creds) >>= authenticate
       liftIO $ case a of
         Nothing -> Nothing <$ atomically (writeTVar cache Unauthenticated)
         Just a' -> Just (accessToken a') <$ atomically (writeTVar cache a')
 
-data Scan = Quick | Full
+data Scan = Unarchived | Everything
 
 sourceEntries ::
   forall r m.
@@ -112,16 +131,19 @@ sourceEntries ::
     MonadThrow m,
     MonadCatch m,
     HasCallStack,
-    HasWallabagMetrics r HTTPMetric
+    HasWallabagMetrics r HTTPMetric,
+    HasKatipTracer r KatipTracer,
+    MonadUnliftIO m
   ) =>
   Scan ->
-  Stream.Stream m Entry
-sourceEntries s = Stream.unfoldrM go (Just startUrl) & Stream.concatMap (Stream.fromList . mapMaybe toEntry)
+  Pipes.Producer Entry m ()
+sourceEntries s = P.unfoldr (toEither <=< go) (Just startUrl) >-> P.mapFoldable (mapMaybe toEntry)
   where
+    toEither = pure . maybe (Left ()) Right
     startUrl =
       case s of
-        Quick -> "https://app.wallabag.it/api/entries.json?archive=0"
-        Full -> "https://app.wallabag.it/api/entries.json"
+        Unarchived -> "https://app.wallabag.it/api/entries.json?archive=0"
+        Everything -> "https://app.wallabag.it/api/entries.json"
     go :: Maybe String -> m (Maybe ([Value], Maybe String))
     go Nothing = pure Nothing
     go (Just url) = checkpoint (Annotation url) $ do
@@ -141,10 +163,16 @@ 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 ::
+  ( MonadReader r m,
+    HasWallabagMetrics r HTTPMetric,
+    HasKatipTracer r KatipTracer
+  ) =>
+  m (Tracer HTTP.Trace)
 mkTracerMetrics = do
-  m <- view wallabagMetrics
-  pure $ HTTP.tracerMetrics m
+  l <- view katipTracer
+  metrics <- view wallabagMetrics
+  pure $ (HTTP.logFormatter >$< l) <> HTTP.tracerMetrics metrics
 
 applyTags ::
   ( HasType Auth r,
@@ -155,7 +183,9 @@ applyTags ::
     K.KatipContext m,
     MonadThrow m,
     MonadCatch m,
-    HasWallabagMetrics r HTTPMetric
+    HasWallabagMetrics r HTTPMetric,
+    HasKatipTracer r KatipTracer,
+    MonadUnliftIO m
   ) =>
   Entry ->
   m ()