wallabag-tagger/src/Wallabag.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}

module Wallabag where

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)
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, logFormatter, post, postWith, tracerMetrics)
import Katip qualified as K
import M (HasKatipTracer, HasWallabagMetrics, KatipTracer, katipTracer, wallabagMetrics)
import Network.HTTP.Client (HttpException)
import Network.Wreq (FormParam (..), defaults, header, responseBody)
import Network.Wreq.Session (Session)
import Pipes ((>->))
import Pipes qualified
import Pipes.Prelude qualified as P
import Tracer (Tracer (..))
import UnliftIO (MonadIO, MonadUnliftIO)
import UnliftIO.STM (atomically)
import Wallabag.Auth

data Entry = Entry
  { _entryIdentifier :: Integer,
    _entryContent :: Text,
    _entryTags :: [Text],
    _entryTitle :: Text,
    _entryUrl :: Text
  }
  deriving (Show)

makeFields ''Entry

authenticate ::
  ( MonadReader r m,
    MonadIO m,
    K.KatipContext m,
    HasWallabagMetrics r HTTPMetric,
    HasType Session r,
    HasKatipTracer r KatipTracer
  ) =>
  Creds ->
  m (Maybe Auth')
authenticate c = do
  K.logFM K.DebugS "Authenticating"
  let form =
        [ "grant_type" := ("password" :: Text),
          "client_id" := c ^. clientId,
          "client_secret" := c ^. clientSecret,
          "username" := c ^. username,
          "password" := c ^. password
        ]
  metrics <- mkTracerMetrics
  session <- view $ typed @Session
  r <- liftIO $ post metrics session 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 (\x -> (x - 5) `addUTCTime` now) expiresIn
  pure $ Auth <$> r ^? responseBody . key "access_token" . _String <*> expireTime

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,
    HasKatipTracer r KatipTracer,
    MonadUnliftIO m,
    HasType Session r,
    MonadThrow m
  ) =>
  m (Maybe Text)
getToken = handle revertToUnauthenticated $ do
  now <- liftIO getCurrentTime
  cache <- view (typed @Auth)
  token <- liftIO $ atomically $ do
    x <- readTVar cache
    case x of
      Unauthenticated -> Nothing <$ writeTVar cache Authenticating
      Authenticating -> retry
      Auth {expires, accessToken}
        | expires > now -> pure $ Just accessToken
        | 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 = Unarchived | Everything

sourceEntries ::
  forall r m.
  ( HasType Auth r,
    HasType Creds r,
    HasType Session r,
    MonadIO m,
    MonadReader r m,
    K.KatipContext m,
    MonadThrow m,
    MonadCatch m,
    HasCallStack,
    HasWallabagMetrics r HTTPMetric,
    HasKatipTracer r KatipTracer,
    MonadUnliftIO m
  ) =>
  Scan ->
  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
        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 u) = checkpoint (Annotation u) $ 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 '" <> u <> "'")
      session <- view $ typed @Session
      r <- liftIO $ getWith metrics session SafeTransient opts u
      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)
    toEntry :: Value -> Maybe Entry
    toEntry v =
      Entry
        <$> v ^? key "id" . _Integer
        <*> v ^? key "content" . _String
        <*> Just (v ^.. key "tags" . _Array . traversed . key "label" . _String)
        <*> v ^? key "title" . _String
        <*> v ^? key "url" . _String

mkTracerMetrics ::
  ( MonadReader r m,
    HasWallabagMetrics r HTTPMetric,
    HasKatipTracer r KatipTracer
  ) =>
  m (Tracer HTTP.Trace)
mkTracerMetrics = do
  l <- view katipTracer
  metrics <- view wallabagMetrics
  pure $ (HTTP.logFormatter >$< l) <> HTTP.tracerMetrics metrics

applyTags ::
  ( HasType Auth r,
    HasType Creds r,
    HasType Session r,
    MonadIO m,
    MonadReader r m,
    HasCallStack,
    K.KatipContext m,
    MonadThrow m,
    MonadCatch m,
    HasWallabagMetrics r HTTPMetric,
    HasKatipTracer r KatipTracer,
    MonadUnliftIO m
  ) =>
  Entry ->
  m ()
applyTags e = checkpoint (Annotation $ e ^. identifier) $ do
  t <- maybe (throw MissingTokenException) pure =<< getToken
  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 u = "https://app.wallabag.it/api/entries/" <> show (e ^. identifier) <> "/tags"
  metrics <- mkTracerMetrics
  session <- view $ typed @Session
  _ <- liftIO $ postWith metrics session SafeTransient opts u ["tags" := T.intercalate "," (e ^. tags)]
  pure ()