Service

src/MyLib.hs

@@ -5,7 +5,9 @@
 module MyLib (defaultMain, test) where
 
 import AI
+import Control.Exception.Annotated.UnliftIO (Exception, SomeException, catch, throw)
 import Control.Lens (over, re, strict, view, (&), (.~), (^.))
+import Control.Monad (forever)
 import Data.Aeson (decode, encode)
 import Data.Either (fromRight)
 import Data.Maybe (fromMaybe)
@@ -15,16 +17,27 @@ 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 Streamly.Data.Fold.Prelude qualified as Fold
-import Streamly.Data.Stream.Prelude qualified as Stream
+import Options.Generic (Generic, ParseRecord (..), getRecord, unDefValue, unHelpful, type (<!>), type (<?>))
+import Pipes (Pipe, for, lift, runEffect, (>->))
+import Pipes.Prelude qualified as P
 import Text.Pandoc (PandocError, def, readHtml, runPure, writeMarkdown)
+import UnliftIO (MonadUnliftIO, liftIO, atomicModifyIORef')
+import UnliftIO.Async (mapConcurrently_)
+import UnliftIO.Concurrent (threadDelay)
+import UnliftIO.Exception (displayException, isAsyncException)
 import Wallabag
+import Network.Wai.Handler.Warp (setPort, setLogger, defaultSettings, runSettings)
+import Server (app, Health (..))
+import UnliftIO.IORef (newIORef, IORef, writeIORef)
 
-data Options = Options
-  { full :: Bool <?> "Go through all the entries",
-    verbose :: Bool
-  }
+data Options
+  = Quick {verbose :: Bool}
+  | Full {verbose :: Bool}
+  | Daemon
+      { verbose :: Bool,
+        credentials :: FilePath <?> "Path to the credentials.json",
+        port :: Int <?> "Port to run the diagnostics" <!> "8094"
+      }
   deriving (Generic, Show)
 
 instance ParseRecord Options
@@ -41,22 +54,57 @@ 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
+processableEntries :: (Monad m) => Pipe Entry Entry m ()
+processableEntries = P.filter (not . tooShort) >-> P.filter missingTags
 
-markdownEntry :: (Monad m) => Stream.Stream m Entry -> Stream.Stream m Entry
-markdownEntry = fmap (over content (\x -> fromRight x $ htmlToMarkdown x))
+-- Convert html into markdown
+markdownEntry :: (Monad m) => Pipe Entry Entry m ()
+markdownEntry = P.map (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
+run sev scan = initialS Nothing sev $ \s -> do
+  runM s $ runScan scan
+
+runScan :: Scan -> M ()
+runScan scan =
+  Pipes.runEffect $
+    Pipes.for
+      (sourceEntries scan >-> markdownEntry >-> processableEntries)
+      (lift . doWork)
+
+runDaemon :: Int -> FilePath -> K.Severity -> IO ()
+runDaemon diagnosticsPort credsPath sev = initialS (Just credsPath) sev $ \s -> runM s $ do
+  let serverSettings = setPort diagnosticsPort defaultSettings
+  health <- newIORef OK
+
+  mapConcurrently_
+    id
+    [ backgroundRunner hourly $ worker health Unarchived,
+      backgroundRunner weekly $ worker health Everything,
+      worker health Unarchived, -- Do a quick scan on startup
+      liftIO $ runSettings serverSettings (app s health)
+    ]
+  K.logFM K.InfoS "finished"
+  where
+    worker health scan = handle (reportError health) $ do
+      runScan scan
+      writeIORef health OK
+    weekly = 7 * 86400 * 1_000_000
+    hourly = 60 * 60 * 1_000_000
+    backgroundRunner delay action = forever $ do
+      threadDelay delay
+      action
+    reportError :: (K.KatipContext m, K.Katip m, MonadUnliftIO m) => IORef Health -> SomeException -> m ()
+    reportError health e
+      | isAsyncException e = throw e
+      | otherwise = do
+        writeIORef health Degraded
+        K.logFM K.ErrorS $ K.ls $ displayException e
+    handle :: (Exception e, MonadUnliftIO m) => (e -> m a) -> m a -> m a
+    handle = flip catch
 
 test :: IO ()
-test = run K.DebugS Quick
+test = run K.DebugS Unarchived
 
 suggestTags :: Text -> M [Text]
 suggestTags txt = do
@@ -111,15 +159,14 @@ hardLabels =
       "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
+  case opts of
+    Quick {verbose} -> run (severity verbose) Unarchived
+    Full {verbose} -> run (severity verbose) Everything
+    Daemon {verbose, credentials, port} ->
+      runDaemon (unHelpful $ unDefValue port) (unHelpful credentials) (severity verbose)
   where
-    severity Options {verbose = True} = K.DebugS
+    severity True = K.DebugS
     severity _ = K.InfoS