commit 2305885dc6ef327a82a9fc881f720a1e81acbfd5 Author: Mats Rauhala Date: Thu Mar 27 13:54:44 2025 +0200 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..da586a1 --- /dev/null +++ b/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. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..40a7e0a --- /dev/null +++ b/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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..7db79e4 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified MyLib (defaultMain) + +main :: IO () +main = MyLib.defaultMain diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..664579f --- /dev/null +++ b/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"; +} diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..027e956 --- /dev/null +++ b/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 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..2d5cd1c --- /dev/null +++ b/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 + ]; + }; + } + ); +} diff --git a/src/AI.hs b/src/AI.hs new file mode 100644 index 0000000..3ab0a0b --- /dev/null +++ b/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 diff --git a/src/Creds.hs b/src/Creds.hs new file mode 100644 index 0000000..4ee8c69 --- /dev/null +++ b/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 + diff --git a/src/M.hs b/src/M.hs new file mode 100644 index 0000000..9ab06fc --- /dev/null +++ b/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) diff --git a/src/MyLib.hs b/src/MyLib.hs new file mode 100644 index 0000000..03c39a0 --- /dev/null +++ b/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 diff --git a/src/Wallabag.hs b/src/Wallabag.hs new file mode 100644 index 0000000..ae6c9e8 --- /dev/null +++ b/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 () diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..3e2059e --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/wallabag-tagger.cabal b/wallabag-tagger.cabal new file mode 100644 index 0000000..df37472 --- /dev/null +++ b/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