wip

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

@@ -22,8 +22,9 @@ import HBS2.Git.Web.Html.Root
 
 import HBS2.Peer.CLI.Detect
 
+import Data.Config.Suckless.Script
+
 import Lucid (renderTextT,HtmlT(..),toHtml)
-import Options.Applicative as O
 import Data.Either
 import Data.Text qualified as Text
 import Data.Text.Lazy qualified as LT
@@ -42,32 +43,8 @@ import System.FilePath
 import System.Process.Typed
 import System.Directory (XdgDirectory(..),getXdgDirectory)
 import Data.ByteString.Lazy.Char8 qualified as LBS8
-
+import System.Environment
-
+import System.Exit
-configParser :: DashBoardPerks m => Parser (m ())
-configParser = do
-  opts <- RunDashBoardOpts <$> optional (strOption
-      ( long "config"
-     <> short 'c'
-     <> metavar "FILEPATH"
-     <> help "Path to the configuration file"
-     <> completer (bashCompleter "file")
-      ))
-
-  cmd <- subparser
-              (  command "web" (O.info pRunWeb (progDesc "Run the web interface"))
-              <> command "index" (O.info pRunIndex (progDesc "update index"))
-              )
-
-  pure $ cmd opts
-
-
-pRunWeb :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
-pRunWeb = pure $ \x -> runDashBoardM x runScotty
-
-pRunIndex :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
-pRunIndex = pure $ \x -> runDashBoardM x do
-  updateIndex
 
 {- HLINT ignore "Eta reduce" -}
 {- HLINT ignore "Functor law" -}
@@ -76,30 +53,30 @@ getRPC :: Monad m => HasConf m => m (Maybe FilePath)
 getRPC = pure Nothing
 
 
-runDashBoardM :: DashBoardPerks m => RunDashBoardOpts -> DashBoardM m a -> m a
+hbs2_git_dashboard :: FilePath
-runDashBoardM cli m = do
+hbs2_git_dashboard = "hbs2-git-dashboard"
 
+readConfig :: DashBoardPerks m => m [Syntax C]
+readConfig = do
 
-  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 = xdgConf
-
-  let confPath = fromMaybe xdgConf cliConfPath
   let confFile = confPath </> "config"
 
-  let dbFile = xdgData </> "state.db"
-
-  when (isNothing cliConfPath) do
   touch confFile
 
-  conf <- runExceptT (liftIO $ readFile confFile)
+  runExceptT (liftIO $ readFile confFile)
      <&> fromRight mempty
      <&> parseTop
      <&> fromRight mempty
 
-  liftIO $ print (pretty conf)
+runDashBoardM :: DashBoardPerks m => DashBoardM m a -> m a
+runDashBoardM m = do
+
+  xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard
+
+  let dbFile = xdgData </> "state.db"
 
   -- FIXME: unix-socket-from-config
   soname <- detectRPC `orDie` "hbs2-peer rpc not found"
@@ -141,7 +118,6 @@ runDashBoardM cli m = do
     void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
 
     env <- newDashBoardEnv
-                conf
                 dbFile
                 peerAPI
                 refLogAPI
@@ -175,12 +151,10 @@ renderHtml :: forall m a . MonadIO m => HtmlT (ActionT m) a -> ActionT m ()
 renderHtml m = renderTextT m >>= html
 
 runDashboardWeb :: WebOptions ->  ScottyT (DashBoardM IO) ()
-runDashboardWeb wo = do
+runDashboardWeb WebOptions{..} = do
   middleware logStdout
 
-  let assets = _assetsOverride wo
+  case _assetsOverride of
-
-  case assets of
     Nothing -> do
       middleware (E.static assetsDir)
     Just f -> do
@@ -327,15 +301,13 @@ runDashboardWeb wo = do
 
 runScotty :: DashBoardPerks m => DashBoardM m ()
 runScotty  = do
-    pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090
+    pno <- getHttpPortNumber
-    wo  <- cfgValue @DevelopAssetsOpt @(Maybe FilePath) <&> WebOptions
+    wo <- WebOptions <$> getDevAssets
 
     env <- ask
 
     flip runContT pure do
-
       void $ ContT $ withAsync updateIndexPeriodially
-
       scottyT pno (withDashBoardEnv env) (runDashboardWeb wo)
 
 updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
@@ -395,14 +367,57 @@ updateIndexPeriodially = do
 
               lift $ buildCommitTreeIndex (coerce lww)
 
+quit :: DashBoardPerks m => m ()
+quit = liftIO exitSuccess
 
 main :: IO ()
 main = do
-  execParser opts & join
+  argz <- getArgs
-  where
+  cli <- parseTop (unlines $ unwords <$> splitForms argz)
-    opts = O.info (configParser <**> helper)
+           & either  (error.show) pure
-      ( fullDesc
+
-     <> progDesc "hbs2-git-dashboard"
+  conf <- readConfig
-     <> O.header "hbs2-git-dashboard" )
+
+  let dict = makeDict @C do
+
+          -- TODO: write-man-entries
+
+          entry $ bindMatch "--help" $ nil_ $ \case
+            HelpEntryBound what -> do
+              helpEntry what
+              quit
+
+            [StringLike s] -> helpList False (Just s) >> quit
+
+            _ -> helpList False Nothing >> quit
+
+          entry $ bindMatch "develop-assets" $ nil_ \case
+            [StringLike s] -> do
+              pure ()
+
+            _ -> none
+
+          brief "allows fixme for given reflog" $
+            args [arg "public-key" "reflog"] $
+            examples [qc|
+              fixme-allow BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP
+            |]
+            $ entry $ bindMatch "fixme-allow" $ nil_ \case
+              [SignPubKeyLike what] -> do
+                lift $ insertFixmeAllowed (RepoRefLog (RefLogKey what))
+
+              _ -> throwIO $ BadFormException @C nil
+
+          entry $ bindMatch "port" $ nil_ \case
+            [LitIntVal n] -> do
+              tp <- lift $ asks _dashBoardHttpPort
+              atomically $ writeTVar tp (Just (fromIntegral n))
+
+            _ -> throwIO $ BadFormException @C nil
+
+          entry $ bindMatch "web" $ nil_ $ const do
+            lift runScotty
+
+  void $ runDashBoardM $ run dict (conf <> cli)
 
 

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

@@ -25,6 +25,7 @@ import DBPipe.SQLite qualified as S
 import DBPipe.SQLite.Generic as G
 
 
+import Data.Aeson as Aeson
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString.Lazy (ByteString)
 import Lucid.Base
@@ -108,6 +109,16 @@ evolveDB = do
   createRepoCommitTable
   createForksTable
 
+  ddl [qc|
+    create table if not exists object
+    ( o text not null
+    , w integer not null
+    , k text not null
+    , v text not null
+    , nonce text null
+    , primary key (o,k)
+    )
+  |]
 
 instance ToField GitHash where
   toField x = toField $ show $ pretty x
@@ -182,7 +193,7 @@ newtype RepoHeadSeq = RepoHeadSeq Word64
 
 newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
                      deriving stock (Generic)
-                     deriving newtype (ToField,FromField,Pretty)
+                     deriving newtype (ToField,FromField,Pretty,Serialise)
 
 newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
                       deriving stock (Generic)
@@ -272,10 +283,11 @@ asRefChan = \case
   LitStrVal s -> fromStringMay @MyRefChan (Text.unpack s)
   _           -> Nothing
 
-getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan]
+getIndexEntries :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [MyRefChan]
 getIndexEntries = do
-  conf <- getConf
+  pure mempty
-  pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
+  -- conf <- getConf
+  -- pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
 
 
 data NiceTS = NiceTS
@@ -872,3 +884,83 @@ gitShowRefs what = do
     pure $ view repoHeadRefs hd
 
 
+insertOWKV :: (DashBoardPerks m, ToJSON a)
+           => Text
+           -> Maybe Integer
+           -> Text
+           -> a
+           -> DBPipeM m ()
+insertOWKV o w k v = do
+
+  let sql = [qc|
+
+      insert into object (o, w, k, v)
+      values (?, ?, ?, cast (? as text))
+      on conflict (o, k)
+      do update set
+        v = case
+              when excluded.w > object.w  then excluded.v
+              else object.v
+            end,
+        w = case
+              when excluded.w > object.w  then excluded.w
+              else object.w
+            end
+  |]
+
+  t <- maybe1 w (round <$> liftIO getPOSIXTime) pure
+
+  S.insert sql (o,t,k,Aeson.encode v)
+
+
+insertOption :: ( DashBoardPerks m
+                , MonadReader DashBoardEnv m
+                , Pretty a
+                , Serialise a)
+             => Text
+             -> a
+             -> m ()
+insertOption  key value = do
+  w <- liftIO getPOSIXTime <&> fromIntegral . round
+  let o = hashObject @HbSync (serialise ("option", key)) & pretty & show
+  let v = show $ pretty v
+  withState $ transactional do
+    insertOWKV (fromString o) (Just w) "$type" "option"
+    insertOWKV (fromString o) (Just w) "name"  key
+    insertOWKV (fromString o) (Just w) "value" (fromString v)
+
+
+insertFixmeAllowed :: ( DashBoardPerks m
+                      , MonadReader DashBoardEnv m
+                      )
+                   => RepoRefLog
+                   -> m ()
+insertFixmeAllowed  reflog = do
+  let o = hashObject @HbSync (serialise ("fixme-allowed", reflog)) & pretty & show
+  let v = show $ pretty reflog
+  withState $ transactional do
+    insertOWKV (fromString o) mzero "$type" "fixme-allowed"
+    insertOWKV (fromString o) mzero "value" v
+
+checkFixmeAllowed :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+                  => RepoRefLog
+                  -> m Bool
+
+checkFixmeAllowed r = do
+
+  let sql = [qc|
+    with
+      s1 as (
+        select o from object where k = '$type' and json_extract(v, '$') = 'fixme-allowed'
+      )
+    select 1
+      from s1 join object o on s1.o = o.o
+      where o.k = 'value' and json_extract(o.v, '$') = ?
+      limit 1;
+  |]
+
+  w <- withState $ select @(Only Int) sql (Only r)
+
+  pure $ not $ List.null w
+
+

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

@@ -10,7 +10,7 @@ import HBS2.Git.DashBoard.Types
 import HBS2.Git.DashBoard.State.Index.Channels
 import HBS2.Git.DashBoard.State.Index.Peer
 
-updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
+updateIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
 updateIndex = do
   debug "updateIndex"
   updateIndexFromPeer

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

@@ -9,7 +9,7 @@ import DBPipe.SQLite.Generic as G
 
 import Streaming.Prelude qualified as S
 
-updateIndexFromChannels :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
+updateIndexFromChannels :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
 updateIndexFromChannels = do
   debug "updateIndexChannels"
 

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

@@ -12,7 +12,7 @@ import Streaming.Prelude qualified as S
 
 seconds = TimeoutSec
 
-updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
+updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
 updateIndexFromPeer = do
   debug "updateIndexFromPeer"
 

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

@@ -19,6 +19,8 @@ import HBS2.System.Dir
 
 import System.FilePath
 
+import Data.Word
+
 data HttpPortOpt
 
 data DevelopAssetsOpt
@@ -47,10 +49,11 @@ data DashBoardEnv =
   , _refChanAPI         :: ServiceCaller RefChanAPI UNIX
   , _lwwRefAPI          :: ServiceCaller LWWRefAPI UNIX
   , _sto                :: AnyStorage
-  , _dashBoardConf  :: TVar [Syntax C]
-  , _db             :: DBPipeEnv
   , _dataDir            :: FilePath
+  , _db                 :: DBPipeEnv
   , _pipeline           :: TQueue (IO ())
+  , _dashBoardHttpPort  :: TVar (Maybe Word16)
+  , _dashBoardDevAssets :: TVar (Maybe FilePath)
   }
 
 makeLenses 'DashBoardEnv
@@ -71,26 +74,32 @@ newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a
                          , MonadReader DashBoardEnv
                          )
 
-instance (MonadIO m, Monad m, MonadReader DashBoardEnv m) => HasConf m where
-  getConf = do
-    asks _dashBoardConf >>= readTVarIO
-
 newDashBoardEnv :: MonadIO m
-                => [Syntax C]
+                => FilePath
-                -> FilePath
                 -> ServiceCaller PeerAPI UNIX
                 -> ServiceCaller RefLogAPI UNIX
                 -> ServiceCaller RefChanAPI UNIX
                 -> ServiceCaller LWWRefAPI UNIX
                 -> AnyStorage
                 -> m DashBoardEnv
-newDashBoardEnv cfg dbFile peer rlog rchan lww sto  = do
+newDashBoardEnv dbFile peer rlog rchan lww sto  = do
   let ddir = takeDirectory dbFile
-  DashBoardEnv peer rlog rchan lww sto
+  DashBoardEnv peer rlog rchan lww sto ddir
-        <$> newTVarIO cfg
+        <$> newDBPipeEnv dbPipeOptsDef dbFile
-        <*> newDBPipeEnv dbPipeOptsDef dbFile
-        <*> pure ddir
         <*> newTQueueIO
+        <*> newTVarIO (Just 8911)
+        <*> newTVarIO Nothing
+
+getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a
+getHttpPortNumber = do
+  asks _dashBoardHttpPort
+    >>= readTVarIO
+    <&> fromIntegral . fromMaybe 8911
+
+getDevAssets :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m (Maybe FilePath)
+getDevAssets = do
+  asks _dashBoardDevAssets
+    >>= readTVarIO
 
 withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
 withDashBoardEnv env m = runReaderT (fromDashBoardM m) env

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs

@@ -943,7 +943,8 @@ repoPage tab lww params = rootPage do
   let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
   let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5
 
-  let fixme  = headMay [ x | FixmeRefChanP x <- meta ]
+  allowed <- lift $ checkFixmeAllowed (RepoRefLog (coerce lww))
+  let fixme  = headMay [ x | allowed, FixmeRefChanP x <- meta ]
 
   debug $ red "META" <+> pretty meta
 

hbs2-git/hbs2-git.cabal

@@ -59,6 +59,7 @@ common shared-properties
       , db-pipe
       , suckless-conf
 
+      , aeson
       , attoparsec
       , atomic-write
       , bytestring