From 8e61ded45c7a0b8083b635858c1f14eca96c63de Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 26 Sep 2024 16:26:56 +0300 Subject: [PATCH] wip --- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 135 ++++++++++-------- .../src/HBS2/Git/DashBoard/State.hs | 100 ++++++++++++- .../src/HBS2/Git/DashBoard/State/Index.hs | 2 +- .../Git/DashBoard/State/Index/Channels.hs | 2 +- .../HBS2/Git/DashBoard/State/Index/Peer.hs | 2 +- .../src/HBS2/Git/DashBoard/Types.hs | 49 ++++--- .../src/HBS2/Git/Web/Html/Root.hs | 3 +- hbs2-git/hbs2-git.cabal | 1 + 8 files changed, 206 insertions(+), 88 deletions(-) diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index d2851eb0..01b413a5 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/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 - - -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 +import System.Environment +import System.Exit {- HLINT ignore "Eta reduce" -} {- HLINT ignore "Functor law" -} @@ -76,31 +53,31 @@ getRPC :: Monad m => HasConf m => m (Maybe FilePath) getRPC = pure Nothing -runDashBoardM :: DashBoardPerks m => RunDashBoardOpts -> DashBoardM m a -> m a -runDashBoardM cli m = do +hbs2_git_dashboard :: FilePath +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 = fromMaybe xdgConf cliConfPath + let confPath = xdgConf let confFile = confPath "config" + touch confFile + + runExceptT (liftIO $ readFile confFile) + <&> fromRight mempty + <&> parseTop + <&> fromRight mempty + +runDashBoardM :: DashBoardPerks m => DashBoardM m a -> m a +runDashBoardM m = do + + xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard + let dbFile = xdgData "state.db" - when (isNothing cliConfPath) do - touch confFile - - conf <- runExceptT (liftIO $ readFile confFile) - <&> fromRight mempty - <&> parseTop - <&> fromRight mempty - - liftIO $ print (pretty conf) - -- 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 @@ -174,13 +150,11 @@ orFall a mb = ContT $ maybe1 mb a 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 -> ScottyT (DashBoardM IO) () +runDashboardWeb WebOptions{..} = do middleware logStdout - let assets = _assetsOverride wo - - case assets of + case _assetsOverride 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 - wo <- cfgValue @DevelopAssetsOpt @(Maybe FilePath) <&> WebOptions + pno <- getHttpPortNumber + 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 - where - opts = O.info (configParser <**> helper) - ( fullDesc - <> progDesc "hbs2-git-dashboard" - <> O.header "hbs2-git-dashboard" ) + argz <- getArgs + cli <- parseTop (unlines $ unwords <$> splitForms argz) + & either (error.show) pure + + conf <- readConfig + + 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) 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 index b72b30a7..124c75f5 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/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 [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ] + pure mempty + -- 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 + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs index 183c30cd..757c3236 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs index ba7fd839..5766bcf9 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs +++ b/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" diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs index c30d8eb6..a05d6212 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/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" diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs index fb6d2117..66a168e5 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs +++ b/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 @@ -42,15 +44,16 @@ instance Semigroup RunDashBoardOpts where data DashBoardEnv = DashBoardEnv - { _peerAPI :: ServiceCaller PeerAPI UNIX - , _refLogAPI :: ServiceCaller RefLogAPI UNIX - , _refChanAPI :: ServiceCaller RefChanAPI UNIX - , _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX - , _sto :: AnyStorage - , _dashBoardConf :: TVar [Syntax C] - , _db :: DBPipeEnv - , _dataDir :: FilePath - , _pipeline :: TQueue (IO ()) + { _peerAPI :: ServiceCaller PeerAPI UNIX + , _refLogAPI :: ServiceCaller RefLogAPI UNIX + , _refChanAPI :: ServiceCaller RefChanAPI UNIX + , _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX + , _sto :: AnyStorage + , _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 - <$> newTVarIO cfg - <*> newDBPipeEnv dbPipeOptsDef dbFile - <*> pure ddir + DashBoardEnv peer rlog rchan lww sto ddir + <$> newDBPipeEnv dbPipeOptsDef dbFile <*> 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 diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index bfb3e8d7..973785d3 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 5a68f0f7..3240f477 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -59,6 +59,7 @@ common shared-properties , db-pipe , suckless-conf + , aeson , attoparsec , atomic-write , bytestring