Initial commit

src/Wallabag.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Wallabag where
+
+import Control.Concurrent.STM (TVar, atomically, readTVar, retry, writeTVar)
+import Control.Exception (Exception)
+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.Reader (MonadReader, liftIO)
+import Creds
+import Data.Aeson (Value)
+import Data.Aeson.Lens (key, _Array, _Integer, _String)
+import Data.Generics.Product (HasType (..))
+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 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'
+
+data Entry = Entry
+  { _entryIdentifier :: Integer,
+    _entryContent :: Text,
+    _entryTags :: [Text],
+    _entryTitle :: Text
+  }
+  deriving (Show)
+
+makeFields ''Entry
+
+authenticate :: (MonadReader r m, MonadIO m, K.KatipContext m) => 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
+        ]
+  r <- liftIO $ post "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) => 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
+  ) =>
+  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
+      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
+      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
+
+applyTags ::
+  ( HasType Auth r,
+    HasType Creds r,
+    MonadIO m,
+    MonadReader r m,
+    HasCallStack,
+    K.KatipContext m,
+    MonadThrow m,
+    MonadCatch 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 url = "https://app.wallabag.it/api/entries/" <> show (e ^. identifier) <> "/tags"
+  _ <- liftIO $ postWith opts url ["tags" := T.intercalate "," (e ^. tags)]
+  pure ()