Initial commit
This commit is contained in:
MasseR committed
commit
2305885dc6
14 files changed
+648
No files matched your search
@@ -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
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
+122
@@ -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
|
||||
+150
@@ -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 ()
|
||||
Reference in new issue
Block a user