MasseR/wallabag-tagger
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Minor performance improvements

Browse Source
This commit is contained in:
MasseR committed 2025-04-23 21:59:42 +03:00
1 parent 96454631ea
commit 53e6a66c9e
6 files changed
+38 -20
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/AI.hs
+5 -1
View File
@@ -18,6 +18,8 @@ import M (HasKatipTracer, HasOpenrouterMetrics, KatipTracer, katipTracer, openro
import Network.Wreq (defaults, header, responseBody)
import Tracer (Tracer (..))
import UnliftIO (MonadIO)
import Network.Wreq.Session (Session)
import Data.Generics.Product (typed, HasType)
mkTracerMetrics ::
( MonadReader r m,
@@ -32,6 +34,7 @@ mkTracerMetrics = do
completions ::
( MonadIO m,
HasType Session r0,
MonadCatch m,
MonadReader r0 m,
HasOpenrouterMetrics r0 HTTPMetric,
@@ -49,5 +52,6 @@ completions c prompt = checkpointCallStack $ do
.= [object ["role" .= ("user" :: Text), "content" .= prompt]]
]
metrics <- mkTracerMetrics
r <- liftIO $ postWith metrics SafeTransient opts "https://openrouter.ai/api/v1/chat/completions" j
session <- view $ typed @Session
r <- liftIO $ postWith metrics session SafeTransient opts "https://openrouter.ai/api/v1/chat/completions" j
pure $ r ^? responseBody . key "choices" . _Array . traversed . key "message" . key "content" . _String
src/HTTP.hs
+13 -12
View File
@@ -23,6 +23,7 @@ import Katip qualified as K
import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Response (..), method)
import Network.HTTP.Types (methodGet, methodHead, status408, status429, status500, status502, status503, status504)
import Network.Wreq qualified as Wreq
import Network.Wreq.Session qualified as Session
import Network.Wreq.Types qualified as Wreq
import System.Metrics.Counter (Counter)
import System.Metrics.Counter qualified as Counter
@@ -64,53 +65,53 @@ traceRetry :: String -> Tracer Trace -> RetryStatus -> IO ()
traceRetry url tracer RetryStatus {rsIterNumber = n} | n > 0 = trace tracer $ Retrying url n
traceRetry _url _wtracer _rs = pure ()
post :: (Wreq.Postable a) => Tracer Trace -> Retry -> String -> a -> IO (Wreq.Response ByteString)
post tracer rules url postable = do
post :: (Wreq.Postable a) => Tracer Trace -> Session.Session -> Retry -> String -> a -> IO (Wreq.Response ByteString)
post tracer session rules url postable = do
start <- getPOSIXTime
res <-
recovering
retryPolicyDefault
(retryRules rules)
(\rs -> traceRetry url tracer rs >> Wreq.post url postable)
(\rs -> traceRetry url tracer rs >> Session.post session url postable)
`catch` (\e -> trace tracer (Failing url e) >> throw e)
end <- getPOSIXTime
trace tracer $ Success url start end
pure res
postWith :: (Wreq.Postable a) => Tracer Trace -> Retry -> Wreq.Options -> String -> a -> IO (Wreq.Response ByteString)
postWith tracer rules opts url postable = do
postWith :: (Wreq.Postable a) => Tracer Trace -> Session.Session -> Retry -> Wreq.Options -> String -> a -> IO (Wreq.Response ByteString)
postWith tracer session rules opts url postable = do
start <- getPOSIXTime
res <-
recovering
retryPolicyDefault
(retryRules rules)
(\rs -> traceRetry url tracer rs >> Wreq.postWith opts url postable)
(\rs -> traceRetry url tracer rs >> Session.postWith opts session url postable)
`catch` (\e -> trace tracer (Failing url e) >> throw e)
end <- getPOSIXTime
trace tracer $ Success url start end
pure res
get :: Tracer Trace -> Retry -> String -> IO (Response ByteString)
get tracer rules url = do
get :: Tracer Trace -> Session.Session -> Retry -> String -> IO (Response ByteString)
get tracer session rules url = do
start <- getPOSIXTime
res <-
recovering
retryPolicyDefault
(retryRules rules)
(\rs -> traceRetry url tracer rs >> Wreq.get url)
(\rs -> traceRetry url tracer rs >> Session.get session url)
`catch` (\e -> trace tracer (Failing url e) >> throw e)
end <- getPOSIXTime
trace tracer $ Success url start end
pure res
getWith :: Tracer Trace -> Retry -> Wreq.Options -> String -> IO (Response ByteString)
getWith tracer rules opts url = do
getWith :: Tracer Trace -> Session.Session -> Retry -> Wreq.Options -> String -> IO (Response ByteString)
getWith tracer session rules opts url = do
start <- getPOSIXTime
res <-
recovering
retryPolicyDefault
(retryRules rules)
(\rs -> traceRetry url tracer rs >> Wreq.getWith opts url)
(\rs -> traceRetry url tracer rs >> Session.getWith opts session url)
`catch` (\e -> trace tracer (Failing url e) >> throw e)
end <- getPOSIXTime
trace tracer $ Success url start end
src/M.hs
+5 -2
View File
@@ -25,6 +25,7 @@ import System.Metrics qualified as EKG
import Tracer (Tracer (..))
import UnliftIO (MonadUnliftIO)
import Wallabag.Auth (Auth, Auth' (..))
import qualified Network.Wreq.Session as Wreq
type KatipTracer = Tracer (Maybe (K.Severity, K.LogStr))
@@ -37,7 +38,8 @@ data S = S
_sWallabagMetrics :: HTTPMetric,
_sOpenrouterMetrics :: HTTPMetric,
_sKatipTracer :: KatipTracer,
_sMetricsStore :: EKG.Store
_sMetricsStore :: EKG.Store,
_sSession :: Wreq.Session
}
deriving (Generic)
@@ -78,6 +80,7 @@ mkKatipTrace le ns = Tracer $ \case
initialS :: Maybe FilePath -> K.Severity -> (S -> IO a) -> IO a
initialS credsPath severity f = do
store <- EKG.newStore
wsession <- Wreq.newSession
EKG.registerGcMetrics store
wbMetrics <-
HTTPMetric
@@ -96,7 +99,7 @@ initialS credsPath severity f = do
let kTrace = mkKatipTrace le ns
ns = "main"
cache <- newTVarIO Unauthenticated
f (S cache ns le mempty c wbMetrics orMetrics kTrace store)
f (S cache ns le mempty c wbMetrics orMetrics kTrace store wsession)
-- TODO: This is just for debug purposes
EKG.sampleAll store >>= mapM_ print . HM.toList
pure res
src/MyLib.hs
+3 -1
View File
@@ -29,6 +29,7 @@ import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (displayException, isAsyncException)
import UnliftIO.IORef (IORef, newIORef, writeIORef)
import Wallabag
import Pipes.Concurrent (performGC)
data Options
= Quick {verbose :: Bool}
@@ -66,11 +67,12 @@ run sev scan = initialS Nothing sev $ \s -> do
runM s $ runScan scan
runScan :: Scan -> M ()
runScan scan =
runScan scan = do
Pipes.runEffect $
Pipes.for
(sourceEntries scan >-> markdownEntry >-> processableEntries)
(lift . doWork)
liftIO performGC
runDaemon :: Int -> FilePath -> K.Severity -> IO ()
runDaemon diagnosticsPort credsPath sev = initialS (Just credsPath) sev $ \s -> runM s $ do
src/Wallabag.hs
+11 -3
View File
@@ -33,6 +33,7 @@ import Katip qualified as K
import M (HasKatipTracer, HasWallabagMetrics, KatipTracer, katipTracer, wallabagMetrics)
import Network.HTTP.Client (HttpException)
import Network.Wreq (FormParam (..), defaults, header, responseBody)
import Network.Wreq.Session (Session)
import Pipes ((>->))
import Pipes qualified
import Pipes.Prelude qualified as P
@@ -56,6 +57,7 @@ authenticate ::
MonadIO m,
K.KatipContext m,
HasWallabagMetrics r HTTPMetric,
HasType Session r,
HasKatipTracer r KatipTracer
) =>
Creds ->
@@ -70,7 +72,8 @@ authenticate c = do
"password" := c ^. password
]
metrics <- mkTracerMetrics
r <- liftIO $ post metrics SafeTransient "https://app.wallabag.it/oauth/v2/token" form
session <- view $ typed @Session
r <- liftIO $ post metrics session 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 (\x -> (x - 5) `addUTCTime` now) expiresIn
@@ -90,6 +93,7 @@ getToken ::
HasWallabagMetrics r HTTPMetric,
HasKatipTracer r KatipTracer,
MonadUnliftIO m,
HasType Session r,
MonadThrow m
) =>
m (Maybe Text)
@@ -125,6 +129,7 @@ sourceEntries ::
forall r m.
( HasType Auth r,
HasType Creds r,
HasType Session r,
MonadIO m,
MonadReader r m,
K.KatipContext m,
@@ -151,7 +156,8 @@ sourceEntries s = P.unfoldr (toEither <=< go) (Just startUrl) >-> P.mapFoldable
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
session <- view $ typed @Session
r <- liftIO $ getWith metrics session 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)
@@ -177,6 +183,7 @@ mkTracerMetrics = do
applyTags ::
( HasType Auth r,
HasType Creds r,
HasType Session r,
MonadIO m,
MonadReader r m,
HasCallStack,
@@ -195,5 +202,6 @@ applyTags e = checkpoint (Annotation $ e ^. identifier) $ do
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)]
session <- view $ typed @Session
_ <- liftIO $ postWith metrics session SafeTransient opts url ["tags" := T.intercalate "," (e ^. tags)]
pure ()
wallabag-tagger.cabal
+1 -1
View File
@@ -78,7 +78,7 @@ executable wallabag-tagger
hs-source-dirs: app
default-language: GHC2021
ghc-options: -with-rtsopts=-T
ghc-options: -with-rtsopts=-T -rtsopts
test-suite wallabag-tagger-test
import: warnings