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 (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 (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 (addUTCTime, getCurrentTime, secondsToNominalDiffTime)
import GHC.Stack (HasCallStack)
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,
    _entryContent :: Text,
    _entryTags :: [Text],
    _entryTitle :: Text
  }
  deriving (Show)

makeFields ''Entry

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 =
        [ "grant_type" := ("password" :: Text),
          "client_id" := c ^. clientId,
          "client_secret" := c ^. clientSecret,
          "username" := c ^. username,
          "password" := c ^. password
        ]
  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
  pure $ Auth <$> r ^? responseBody . key "access_token" . _String <*> expireTime

data WallabagException7g = MissingTokenException deriving (Show)

instance Exception WallabagException7g

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)
  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
    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

sourceEntries ::
  forall r m.
  ( HasType Auth r,
    HasType Creds r,
    MonadIO m,
    MonadReader r m,
    K.KatipContext m,
    MonadThrow m,
    MonadCatch m,
    HasCallStack,
    HasWallabagMetrics r HTTPMetric
  ) =>
  Scan ->
  Stream.Stream m Entry
sourceEntries s = Stream.unfoldrM go (Just startUrl) & Stream.concatMap (Stream.fromList . mapMaybe toEntry)
  where
    startUrl =
      case s of
        Quick -> "https://app.wallabag.it/api/entries.json?archive=0"
        Full -> "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
      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 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)
    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

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,
    MonadIO m,
    MonadReader r m,
    HasCallStack,
    K.KatipContext m,
    MonadThrow m,
    MonadCatch m,
    HasWallabagMetrics r HTTPMetric
  ) =>
  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 url = "https://app.wallabag.it/api/entries/" <> show (e ^. identifier) <> "/tags"
  metrics <- mkTracerMetrics
  _ <- liftIO $ postWith metrics SafeTransient opts url ["tags" := T.intercalate "," (e ^. tags)]
  pure ()