Initial commit

.gitignore

@@ -0,0 +1 @@
+dist-newstyle

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for wallabag-tagger
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,29 @@
+Copyright (c) 2024, Mats Rauhala
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import qualified MyLib (defaultMain)
+
+main :: IO ()
+main = MyLib.defaultMain

default.nix

@@ -0,0 +1,22 @@
+{ mkDerivation, aeson, annotated-exception, base, bytestring
+, containers, directory, exceptions, filepath, generic-lens, katip
+, lens, lens-aeson, lib, mtl, optparse-generic, pandoc, pipes, stm
+, streamly, streamly-core, text, time, unliftio, wreq
+}:
+mkDerivation {
+  pname = "wallabag-tagger";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    aeson annotated-exception base bytestring containers directory
+    exceptions filepath generic-lens katip lens lens-aeson mtl
+    optparse-generic pandoc pipes stm streamly streamly-core text time
+    unliftio wreq
+  ];
+  executableHaskellDepends = [ base ];
+  testHaskellDepends = [ base ];
+  license = lib.licenses.bsd3;
+  mainProgram = "wallabag-tagger";
+}

flake.lock

@@ -0,0 +1,57 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1731533236,
+        "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 0,
+        "narHash": "sha256-cHar1vqHOOyC7f1+tVycPoWTfKIaqkoe1Q6TnKzuti4=",
+        "path": "/nix/store/6zgbbqlr7nnfxpzkyj7fsl4fpg89jbw0-source",
+        "type": "path"
+      },
+      "original": {
+        "id": "nixpkgs",
+        "type": "indirect"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,37 @@
+{
+  description = "A very basic flake";
+
+  inputs = {
+    flake-utils = {
+      url = "github:numtide/flake-utils";
+    };
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+  flake-utils.lib.eachSystem ["x86_64-linux"] (system:
+    let pkgs = nixpkgs.legacyPackages.${system};
+        hp = nixpkgs.legacyPackages.${system}.haskellPackages.override (old: {
+      overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: {})) (f: p: {
+        wallabag-tagger = f.callPackage ./. {};
+      });
+    });
+    in rec {
+      packages.wallabag-tagger = pkgs.haskell.lib.justStaticExecutables hp.wallabag-tagger;
+      defaultPackage = packages.wallabag-tagger;
+      devShell = hp.shellFor {
+        packages = h: [h.wallabag-tagger];
+        withHoogle = false;
+        buildInputs = with pkgs; [
+          cabal-install
+          hp.hlint
+          cabal2nix
+          ghcid
+
+          hp.graphmod
+
+          hp.haskell-language-server
+        ];
+      };
+    }
+  );
+}

src/AI.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module AI where
+
+import Control.Lens (re, traversed, (&), (.~), (^.), (^?))
+import Control.Monad.Reader (liftIO)
+import Creds
+import Data.Aeson (object, (.=))
+import Data.Aeson.Lens (key, _Array, _String)
+import Data.Text (Text)
+import Data.Text.Strict.Lens (utf8)
+import Network.Wreq (defaults, header, postWith, responseBody)
+import UnliftIO (MonadIO)
+import Control.Exception.Annotated (checkpointCallStack)
+import Control.Monad.Catch (MonadCatch)
+
+completions :: (MonadIO m, MonadCatch m) => Creds -> Text -> m (Maybe Text)
+completions c prompt = checkpointCallStack $ do
+  let opts = defaults & header "Authorization" .~ ["Bearer " <> c ^. openrouterKey . re utf8]
+  let j =
+        object
+          [ "model" .= ("openai/gpt-4o-mini" :: Text),
+            "messages"
+              .= [object ["role" .= ("user" :: Text), "content" .= prompt]]
+          ]
+  r <- liftIO $ postWith opts "https://openrouter.ai/api/v1/chat/completions" j
+  pure $ r ^? responseBody . key "choices" . _Array . traversed . key "message" . key "content" . _String

src/Creds.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Creds where
+
+import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:))
+import Data.Text (Text)
+import Data.ByteString.Lazy qualified as LBS
+import Control.Lens.TH (makeFields)
+import System.Directory (getHomeDirectory)
+import System.FilePath ((</>))
+
+data Creds = Creds
+  { _credsClientId :: Text,
+    _credsClientSecret :: Text,
+    _credsUsername :: Text,
+    _credsPassword :: Text,
+    _credsOpenrouterKey :: Text
+  }
+
+instance FromJSON Creds where
+  parseJSON = withObject "Creds" $ \v ->
+    Creds
+      <$> v .: "client_id"
+      <*> v .: "client_secret"
+      <*> v .: "username"
+      <*> v .: "password"
+      <*> v .: "openrouter_key"
+
+makeFields ''Creds
+
+
+getCreds :: IO Creds
+getCreds = do
+  home <- getHomeDirectory
+  let path = home </> ".config/wallabag/creds.json"
+  c <- eitherDecode <$> LBS.readFile path
+  either error pure c
+

src/M.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module M where
+
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Control.Lens (over, view)
+import Control.Lens.TH (makeFields)
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, local, runReaderT)
+import Creds
+import GHC.Generics (Generic)
+import Katip qualified as K
+import System.IO (stdout)
+import UnliftIO (MonadUnliftIO)
+import Wallabag (Auth, Auth' (..))
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Base (MonadBase)
+
+data S = S
+  { _sTokenCache :: Auth,
+    _sLogNamespace :: K.Namespace,
+    _sLogEnv :: K.LogEnv,
+    _sLogContext :: K.LogContexts,
+    _sCreds :: Creds
+  }
+  deriving (Generic)
+
+makeFields ''S
+
+newtype M a = M (ReaderT S IO a)
+  deriving
+    ( Functor,
+      Applicative,
+      Monad,
+      MonadReader S,
+      MonadIO,
+      MonadUnliftIO,
+      MonadThrow,
+      MonadCatch,
+      MonadBaseControl IO,
+      MonadBase IO
+    )
+
+runM :: S -> M a -> IO a
+runM s (M m) = runReaderT m s
+
+instance K.Katip M where
+  getLogEnv = view logEnv
+  localLogEnv = local . over logEnv
+
+instance K.KatipContext M where
+  getKatipContext = view logContext
+  localKatipContext = local . over logContext
+  getKatipNamespace = view logNamespace
+  localKatipNamespace = local . over logNamespace
+
+initialS :: K.Severity -> (S -> IO a) -> IO a
+initialS severity f = do
+  c <- getCreds
+  handleScribe <- K.mkHandleScribe K.ColorIfTerminal stdout (K.permitItem severity) K.V2
+  let makeLogEnv = K.registerScribe "stdout" handleScribe K.defaultScribeSettings =<< K.initLogEnv "wallabag" "production"
+  bracket makeLogEnv K.closeScribes $ \le -> do
+    cache <- newTVarIO Unauthenticated
+    f (S cache "main" le mempty c)

src/MyLib.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module MyLib (defaultMain, test) where
+
+import AI
+import Control.Lens (over, re, strict, view, (&), (.~), (^.))
+import Data.Aeson (decode, encode)
+import Data.Either (fromRight)
+import Data.Maybe (fromMaybe)
+import Data.Set qualified as S
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Strict.Lens (utf8)
+import Katip qualified as K
+import M
+import Options.Generic (Generic, ParseRecord (..), getRecord, unHelpful, type (<?>))
+import Text.Pandoc (PandocError, def, readHtml, runPure, writeMarkdown)
+import Wallabag
+import qualified Streamly.Data.Fold.Prelude as Fold
+import qualified Streamly.Data.Stream.Prelude as Stream
+
+data Options = Options
+  { full :: Bool <?> "Go through all the entries",
+    verbose :: Bool
+  }
+  deriving (Generic, Show)
+
+instance ParseRecord Options
+
+tooShort :: Entry -> Bool
+tooShort e = length (T.lines (view content e)) < 5
+
+missingTags :: Entry -> Bool
+missingTags Entry {_entryTags = []} = True
+missingTags Entry {} = False
+
+htmlToMarkdown :: Text -> Either PandocError Text
+htmlToMarkdown input = runPure $ do
+  doc <- readHtml def input
+  writeMarkdown def doc
+
+processableEntries :: (Monad m) => Stream.Stream m Entry -> Stream.Stream m Entry
+processableEntries = Stream.filter (not . tooShort) . Stream.filter missingTags
+
+markdownEntry :: (Monad m) => Stream.Stream m Entry -> Stream.Stream m Entry
+markdownEntry = fmap (over content (\x -> fromRight x $ htmlToMarkdown x))
+
+run :: K.Severity -> Scan -> IO ()
+run sev scan = initialS sev $ \s -> do
+  runM s $ do
+    Stream.fold Fold.drain $
+      sourceEntries scan & markdownEntry & processableEntries &
+      Stream.parMapM (Stream.maxThreads 5) doWork
+
+test :: IO ()
+test = run K.DebugS Quick
+
+suggestTags :: Text -> M [Text]
+suggestTags txt = do
+  c <- view creds
+  let prompt =
+        T.unlines
+          [ "Assign tags for the given article from this set of tags: " <> encode hardLabels ^. strict . utf8,
+            "Respond in JSON. Respond only in JSON, nothing more",
+            "Example response: [\"Politics\"]",
+            "",
+            "The article contents:",
+            txt
+          ]
+  unparsed <- completions c prompt
+  pure $ maybe [] parseTags unparsed
+  where
+    parseTags :: Text -> [Text]
+    parseTags = fromMaybe [] . decode . view (re utf8 . re strict) . T.dropWhileEnd (/= ']') . T.dropWhile (/= '[')
+
+suggestTagsForEntry :: Entry -> M Entry
+suggestTagsForEntry e = do
+  newTags <- suggestTags (e ^. content)
+  pure $ e & tags .~ newTags
+
+doWork :: Entry -> M ()
+doWork e = do
+  entryWithTags <- suggestTagsForEntry e
+  applyTags entryWithTags
+
+hardLabels :: S.Set Text
+hardLabels =
+  S.fromList
+    [ "Politics",
+      "Writing",
+      "Nature",
+      "Camping",
+      "Hiking",
+      "Economics",
+      "Climate",
+      "Software",
+      "Programming",
+      "Maths",
+      "Animals",
+      "Health",
+      "Sexuality",
+      "Relationships",
+      "Media and television",
+      "Social media",
+      "Gaming",
+      "Plants",
+      "Gadgets",
+      "AI"
+    ]
+
+defaultMain :: IO ()
+defaultMain = do
+  opts <- getRecord "Wallabag tagger"
+  let sev = severity opts
+  if unHelpful $ full opts
+    then run sev Full
+    else run sev Quick
+  where
+    severity Options {verbose = True} = K.DebugS
+    severity _ = K.InfoS

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

test/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."

wallabag-tagger.cabal

@@ -0,0 +1,78 @@
+cabal-version:      3.0
+name:               wallabag-tagger
+version:            0.1.0.0
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Mats Rauhala
+maintainer:         mats.rauhala@iki.fi
+-- copyright:
+category:           Web
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  AI
+                      Creds
+                      M
+                      Wallabag
+                      MyLib
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base ^>=4.18.2.1
+                    , wreq
+                    , lens
+                    , katip
+                    , pipes
+                    , streamly
+                    , streamly-core
+                    , monad-control
+                    , transformers-base
+                    , pandoc
+                    , annotated-exception
+                    , aeson
+                    , text
+                    , bytestring
+                    , directory
+                    , filepath
+                    , time
+                    , unliftio
+                    , stm
+                    , exceptions
+                    , lens-aeson
+                    , mtl
+                    , generic-lens
+                    , optparse-generic
+                    , containers
+    hs-source-dirs:   src
+    default-language: GHC2021
+
+executable wallabag-tagger
+    import:           warnings
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base ^>=4.18.2.1,
+        wallabag-tagger
+
+    hs-source-dirs:   app
+    default-language: GHC2021
+
+test-suite wallabag-tagger-test
+    import:           warnings
+    default-language: GHC2021
+    -- other-modules:
+    -- other-extensions:
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    build-depends:
+        base ^>=4.18.2.1,
+        wallabag-tagger