setup all stuff

flake.lock

@@ -8,15 +8,16 @@
         ]
       },
       "locked": {
-        "lastModified": 1708680396,
+        "lastModified": 1713359411,
-        "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=",
+        "narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=",
-        "ref": "refs/heads/master",
+        "ref": "generic-sql",
-        "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827",
+        "rev": "03635c54b2e2bd809ec1196bc9082447279f6f24",
-        "revCount": 7,
+        "revCount": 9,
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       },
       "original": {
+        "ref": "generic-sql",
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       }

flake.nix

@@ -15,7 +15,7 @@ inputs = {
     suckless-conf.url = "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ";
     suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
 
-    db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft";
+    db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft?ref=generic-sql";
     db-pipe.inputs.nixpkgs.follows = "nixpkgs";
 
     lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls";

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -1,24 +1,28 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
 module Main where
 
 import HBS2.Prelude.Plated
 import HBS2.OrDie
 import HBS2.System.Dir
+import HBS2.System.Logger.Simple.ANSI hiding (info)
 
 import HBS2.Git.Web.Assets
+import HBS2.Git.DashBoard.State
+import HBS2.Git.DashBoard.Types
 import HBS2.Git.Web.Html.Root
 
 import HBS2.Peer.CLI.Detect
 
 import Data.Config.Suckless
-import Data.Config.Suckless.KeyValue
+
+import DBPipe.SQLite
 
 import Lucid
 import Options.Applicative as O
 import Data.Maybe
 import Data.Either
-import Options.Applicative.BashCompletion
 import Control.Applicative
 import Data.ByteString.Lazy qualified as LBS
 import Network.HTTP.Types.Status
@@ -31,27 +35,15 @@ import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
 import System.Directory
 import Control.Monad.Except
+import Control.Monad.Trans.Cont
 
 import UnliftIO
 
-data HttpPortOpt
-
-data DevelopAssetsOpt
-
-instance HasConf m => HasCfgKey HttpPortOpt a m where
-  key = "port"
 
 
-instance HasConf m => HasCfgKey DevelopAssetsOpt a m where
+configParser :: DashBoardPerks m => Parser (m ())
-  key = "develop-assets"
+configParser = do
-
+  opts <- RunDashBoardOpts <$> optional (strOption
-data RunDashBoardOpts = RunDashBoardOpts
-  { configPath :: Maybe FilePath }
-
-
-configParser :: Parser RunDashBoardOpts
-configParser = RunDashBoardOpts <$>
-  optional (strOption
       ( long "config"
      <> short 'c'
      <> metavar "FILEPATH"
@@ -59,6 +51,16 @@ configParser = RunDashBoardOpts <$>
      <> completer (bashCompleter "file")
       ))
 
+  cmd <- subparser
+              ( command "web" (info pRunWeb (progDesc "Run the web interface")) )
+
+  pure $ cmd opts
+
+
+pRunWeb :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
+pRunWeb = pure $ \x -> runDashBoardM x runScotty
+
+
 {- HLINT ignore "Eta reduce" -}
 {- HLINT ignore "Functor law" -}
 
@@ -66,45 +68,21 @@ getRPC :: Monad m => HasConf m => m (Maybe FilePath)
 getRPC = pure Nothing
 
 
-data DashBoardEnv =
+runDashBoardM :: DashBoardPerks m => RunDashBoardOpts -> DashBoardM m a -> m a
-  DashBoardEnv
-  { _dashBoardConf      :: TVar [Syntax C]
-  }
-
-newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a }
-                         deriving newtype
-                         ( Applicative
-                         , Functor
-                         , Monad
-                         , MonadIO
-                         , MonadUnliftIO
-                         , MonadTrans
-                         , MonadReader DashBoardEnv
-                         )
-
-instance (MonadIO m, Monad m, MonadReader DashBoardEnv m) => HasConf m where
-  getConf = do
-    asks _dashBoardConf >>= readTVarIO
-
-
-newDashBoardEnv :: MonadIO m => [Syntax C] -> m DashBoardEnv
-newDashBoardEnv cfg = do
-  tconf <- newTVarIO cfg
-  pure $ DashBoardEnv tconf
-
-withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
-withDashBoardEnv env m = runReaderT (fromDashBoardM m) env
-
-
-runDashBoardM :: MonadIO m => Maybe RunDashBoardOpts -> DashBoardM m a -> m a
 runDashBoardM cli m = do
 
-  xdg <- liftIO $ getXdgDirectory XdgConfig "hbs2-git-dashboard"
-  let cliConfPath = cli >>= configPath
 
-  let confPath = fromMaybe xdg cliConfPath
+  let hbs2_git_dashboard = "hbs2-git-dashboard"
+  xdgConf <- liftIO $ getXdgDirectory XdgConfig hbs2_git_dashboard
+  xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard
+
+  let cliConfPath = cli & configPath
+
+  let confPath = fromMaybe xdgConf cliConfPath
   let confFile = confPath </> "config"
 
+  let dbFile = xdgData </> "state.db"
+
   when (isNothing cliConfPath) do
     touch confFile
 
@@ -115,9 +93,33 @@ runDashBoardM cli m = do
 
   liftIO $ print (pretty conf)
 
-  env <- newDashBoardEnv conf
+  env <- newDashBoardEnv conf dbFile
 
-  withDashBoardEnv env m
+  let errorPrefix  = toStderr . logPrefix "[error] "
+  let warnPrefix   = toStderr . logPrefix "[warn] "
+  let noticePrefix = toStderr . logPrefix ""
+  let debugPrefix  = toStderr . logPrefix "[debug] "
+
+  setLogging @INFO   defLog
+  setLogging @ERROR  errorPrefix
+  setLogging @DEBUG  debugPrefix
+  setLogging @WARN   warnPrefix
+  setLogging @NOTICE noticePrefix
+
+  flip runContT pure do
+
+    void $ ContT $ withAsync do
+      q <- withDashBoardEnv env $ asks _pipeline
+      forever do
+        liftIO (atomically $ readTQueue q) & liftIO . join
+
+    lift $ withDashBoardEnv env (withState evolveDB >> m)
+      `finally` do
+        setLoggingOff @DEBUG
+        setLoggingOff @INFO
+        setLoggingOff @ERROR
+        setLoggingOff @WARN
+        setLoggingOff @NOTICE
 
 
 data WebOptions =
@@ -136,19 +138,14 @@ runDashboardWeb wo = do
     Nothing -> do
       middleware (E.static assetsDir)
     Just f -> do
-     middleware $ staticPolicy (noDots >-> addBase f)
+      middleware $ staticPolicy (noDots >-> addBase f)
 
   get "/" do
     html =<< renderTextT (dashboardRootPage mempty)
 
-main :: IO ()
-main = do
 
-  cli <- execParser opts
+runScotty :: DashBoardPerks m => DashBoardM m ()
-
+runScotty  = do
-  runDashBoardM (Just cli) do
-
-    -- FIXME: to-config
     pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090
     wo  <- cfgValue @DevelopAssetsOpt @(Maybe FilePath) <&> WebOptions
 
@@ -156,10 +153,15 @@ main = do
                 `orDie` "hbs2-peer RPC not detected"
 
     env <- ask
-    conf <- getConf
+
+    addJob (withDashBoardEnv env updateIndex)
 
     scottyT pno (withDashBoardEnv env) (runDashboardWeb wo)
 
+
+main :: IO ()
+main = do
+  execParser opts & join
   where
     opts = info (configParser <**> helper)
       ( fullDesc

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs

@@ -0,0 +1,35 @@
+module HBS2.Git.DashBoard.State where
+
+import HBS2.Prelude.Plated
+
+import HBS2.Git.DashBoard.Types
+
+import HBS2.System.Logger.Simple.ANSI
+import Data.Config.Suckless
+
+import DBPipe.SQLite
+import DBPipe.SQLite.Generic
+
+import Text.InterpolatedString.Perl6 (qc)
+import Control.Monad.Reader
+
+
+evolveDB :: MonadIO m => DBPipeM m ()
+evolveDB = do
+
+  ddl [qc|
+    create table if not exists project
+      (  lww text not null
+      ,  primary key (lww)
+      )
+  |]
+
+  pure ()
+
+
+updateIndex :: (MonadIO m, HasConf m, MonadReader DashBoardEnv m) => m ()
+updateIndex = do
+  debug "updateIndex"
+  pure ()
+
+

hbs2-git/hbs2-git.cabal

@@ -144,6 +144,8 @@ executable hbs2-git-dashboard
     main-is:          GitDashBoard.hs
 
     other-modules:
+      HBS2.Git.DashBoard.Types
+      HBS2.Git.DashBoard.State
       HBS2.Git.Web.Html.Root
 
     -- other-extensions:
@@ -162,7 +164,9 @@ executable hbs2-git-dashboard
         , lucid-htmx
         , scotty >= 0.22
 
-    hs-source-dirs:   hbs2-git-dashboard, hbs2-git-dashboard/src
+    hs-source-dirs:
+      hbs2-git-dashboard
+      hbs2-git-dashboard/src
 
     default-language: GHC2021