wip

Makefile

@@ -13,6 +13,7 @@ BINS := \
   hbs2-keyman        \
 	hbs2-fixer         \
 	hbs2-git-subscribe \
+	hbs2-git-dashboard \
   git-remote-hbs2    \
   git-hbs2           \
 

hbs2-core/lib/HBS2/System/Dir.hs

@@ -47,9 +47,7 @@ touch what = do
 
   when (not here || hard) do
     mkdir (takeDirectory fn)
-    liftIO $ print (takeDirectory fn)
     unless dir do
-      liftIO $ print fn
       liftIO $ LBS.appendFile fn mempty
 
   where

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

@@ -1,6 +1,132 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
 module Main where
 
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.System.Dir
 
+import HBS2.Peer.CLI.Detect
+
+import Data.Config.Suckless
+
+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
+import Network.Wai.Middleware.RequestLogger
+import Text.InterpolatedString.Perl6 (qc)
+import Web.Scotty.Trans
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+import System.Directory
+import Control.Monad.Except
+import UnliftIO
+
+data HttpPortOpt
+
+instance HasConf m => HasCfgKey HttpPortOpt a m where
+  key = "port"
+
+data RunDashBoardOpts = RunDashBoardOpts
+  { configPath :: Maybe FilePath }
+
+
+configParser :: Parser RunDashBoardOpts
+configParser = RunDashBoardOpts <$>
+  optional (strOption
+      ( long "config"
+     <> short 'c'
+     <> metavar "FILEPATH"
+     <> help "Path to the configuration file"
+     <> completer (bashCompleter "file")
+      ))
+
+{- HLINT ignore "Eta reduce" -}
+{- HLINT ignore "Functor law" -}
+
+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 cli m = do
+
+  xdg <- liftIO $ getXdgDirectory XdgConfig "hbs2-git-dashboard"
+  let cliConfPath = cli >>= configPath
+
+  let confPath = fromMaybe xdg cliConfPath
+  let confFile = confPath </> "config"
+
+  when (isNothing cliConfPath) do
+    touch confFile
+
+  conf <- runExceptT (liftIO $ readFile confFile)
+           <&> fromRight mempty
+           <&> parseTop
+           <&> fromRight mempty
+
+  liftIO $ print (pretty conf)
+
+  env <- newDashBoardEnv conf
+
+  withDashBoardEnv env m
+
+main :: IO ()
 main = do
-  pure ()
+
+  cli <- execParser opts
+
+  runDashBoardM (Just cli) do
+
+    -- FIXME: to-config
+    pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090
+
+    soname <- runMaybeT (getRPC <|> detectRPC)
+                `orDie` "hbs2-peer RPC not detected"
+
+    env <- ask
+
+    scottyT pno (withDashBoardEnv env) do
+      middleware logStdout
+
+  where
+    opts = info (configParser <**> helper)
+      ( fullDesc
+     <> progDesc "hbs2-git-dashboard"
+     <> O.header "hbs2-git-dashboard" )
+
 

hbs2-git/hbs2-git.cabal

@@ -132,12 +132,16 @@ executable hbs2-git-dashboard
     -- other-modules:
     -- other-extensions:
     build-depends:
-        base, hbs2-peer, hbs2-git
+        base, hbs2-peer, hbs2-git, suckless-conf
         , binary
         , vector
         , optparse-applicative
+        , http-types
+        , wai-extra
+        , scotty
+
+    hs-source-dirs:   hbs2-git-dashboard hbs2-git-dashboard/src
 
-    hs-source-dirs:   hbs2-git-dashboard
     default-language: GHC2021
 
 

hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs

@@ -7,9 +7,8 @@ import Data.Config.Suckless
 import System.Process.Typed
 import Data.Text qualified as Text
 import Data.Either
-import UnliftIO
 
-detectRPC :: (MonadUnliftIO m) => m (Maybe FilePath)
+detectRPC :: MonadIO m => m (Maybe FilePath)
 detectRPC = do
 
   (_, o, _) <- readProcess (shell "hbs2-peer poke")