From 81f31e0bdadb342b0e347a03cdbe53468d75aa9b Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 18 Apr 2024 10:35:08 +0300 Subject: [PATCH] setup all stuff --- flake.lock | 11 +- flake.nix | 2 +- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 128 +++++++++--------- .../src/HBS2/Git/DashBoard/State.hs | 35 +++++ hbs2-git/hbs2-git.cabal | 6 +- 5 files changed, 112 insertions(+), 70 deletions(-) create mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs diff --git a/flake.lock b/flake.lock index 001f1feb..3295e835 100644 --- a/flake.lock +++ b/flake.lock @@ -8,15 +8,16 @@ ] }, "locked": { - "lastModified": 1708680396, - "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=", - "ref": "refs/heads/master", - "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827", - "revCount": 7, + "lastModified": 1713359411, + "narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=", + "ref": "generic-sql", + "rev": "03635c54b2e2bd809ec1196bc9082447279f6f24", + "revCount": 9, "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" }, "original": { + "ref": "generic-sql", "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" } diff --git a/flake.nix b/flake.nix index 51294f2f..a5683ccc 100644 --- a/flake.nix +++ b/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"; diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index c43a1027..71ceee31 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/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 - key = "develop-assets" - -data RunDashBoardOpts = RunDashBoardOpts - { configPath :: Maybe FilePath } - - -configParser :: Parser RunDashBoardOpts -configParser = RunDashBoardOpts <$> - optional (strOption +configParser :: DashBoardPerks m => Parser (m ()) +configParser = do + opts <- 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 = - 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 :: DashBoardPerks m => 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 - - runDashBoardM (Just cli) do - - -- FIXME: to-config +runScotty :: DashBoardPerks m => DashBoardM m () +runScotty = do 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 diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs new file mode 100644 index 00000000..fd468398 --- /dev/null +++ b/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 () + + diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 2c3653fd..063a0b83 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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