diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs index bbae5f67..2fd05cca 100644 --- a/fixme-new/lib/Fixme/Config.hs +++ b/fixme-new/lib/Fixme/Config.hs @@ -10,16 +10,16 @@ import System.Directory (getXdgDirectory, XdgDirectory(..)) binName :: FixmePerks m => m FilePath binName = liftIO getProgName -localConfigDir :: FixmePerks m => m FilePath +localConfigDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath localConfigDir = do - p <- pwd + p <- asks fixmeEnvWorkDir >>= readTVarIO b <- binName pure (p ("." <> b)) -fixmeWorkDir :: FixmePerks m => m FilePath -fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath +fixmeWorkDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath +fixmeWorkDir = asks fixmeEnvWorkDir >>= readTVarIO -localConfig:: FixmePerks m => m FilePath +localConfig:: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath localConfig = localConfigDir <&> ( "config") userConfigs :: FixmePerks m => m [FilePath] @@ -36,6 +36,6 @@ userConfigs= do localDBName :: FilePath localDBName = "state.db" -localDBPath :: FixmePerks m => m FilePath +localDBPath :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath localDBPath = localConfigDir <&> ( localDBName) diff --git a/fixme-new/lib/Fixme/GK.hs b/fixme-new/lib/Fixme/GK.hs index 58baf1f9..aa7e05aa 100644 --- a/fixme-new/lib/Fixme/GK.hs +++ b/fixme-new/lib/Fixme/GK.hs @@ -30,7 +30,7 @@ data GroupKeyOpError = instance Exception GroupKeyOpError -groupKeyFile :: forall m . FixmePerks m => m FilePath +groupKeyFile :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => m FilePath groupKeyFile = do dir <- localConfigDir pure $ dir "gk0" diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 7ca139d8..52758393 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -113,12 +113,11 @@ runWithRPC FixmeEnv{..} m = do runFixmeCLI :: forall a m . FixmePerks m => FixmeM m a -> m a runFixmeCLI m = do - dbPath <- localDBPath git <- findGitDir env <- FixmeEnv <$> newMVar () <*> newTVarIO mempty - <*> newTVarIO dbPath + <*> (pwd >>= newTVarIO) <*> newTVarIO Nothing <*> newTVarIO git <*> newTVarIO mempty @@ -146,7 +145,6 @@ runFixmeCLI m = do -- не все действия требуют БД, -- хорошо бы, что бы она не создавалась, -- если не требуется - mkdir (takeDirectory dbPath) recover env do runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env `finally` flushLoggers @@ -233,7 +231,7 @@ runTop forms = do entry $ bindMatch "fixme-files" $ nil_ \case StringLikeList xs -> do - w <- fixmeWorkDir + w <- lift fixmeWorkDir t <- lift $ asks fixmeEnvFileMask atomically (modifyTVar t (<> fmap (w ) xs)) @@ -241,7 +239,7 @@ runTop forms = do entry $ bindMatch "fixme-exclude" $ nil_ \case StringLikeList xs -> do - w <- fixmeWorkDir + w <- lift fixmeWorkDir t <- lift $ asks fixmeEnvFileExclude atomically (modifyTVar t (<> fmap (w ) xs)) @@ -451,7 +449,7 @@ runTop forms = do [StringLike path] -> do ppath <- if List.isPrefixOf "." path then do - dir <- localConfigDir + dir <- lift localConfigDir let rest = tail $ splitDirectories path pure $ joinPath (dir:rest) else do @@ -544,10 +542,11 @@ runTop forms = do <&> fromMaybe "hbs2-peer not connected" liftIO $ putStrLn poked - conf <- readConfig argz <- liftIO getArgs + conf <- readConfig + let args = zipWith (\i s -> bindValue (mkId ("$_" <> show i)) (mkStr @C s )) [1..] argz & HM.unions diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 51c84fe7..d3a51b1e 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -199,6 +199,10 @@ printEnv = do attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList + dir <- asks fixmeEnvWorkDir >>= readTVarIO + + liftIO $ print $ "; workdir" <+> pretty dir + for_ tags $ \m -> do liftIO $ print $ "fixme-prefix" <+> pretty m @@ -229,8 +233,8 @@ printEnv = do for_ g $ \git -> do liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git) - dbPath <- asks fixmeEnvDbPath >>= readTVarIO - liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath) + dbPath <- localDBPath + liftIO $ print $ "; fixme-state-path" <+> dquotes (pretty dbPath) (before,after) <- asks fixmeEnvCatContext >>= readTVarIO diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 737ce8b4..12823d9a 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -103,19 +103,24 @@ instance FromField HashRef where fromField = fmap (fromString @HashRef) . fromField @String evolve :: FixmePerks m => FixmeM m () -evolve = withState do +evolve = do + dbPath <- localDBPath + debug $ "evolve" <+> pretty dbPath + mkdir (takeDirectory dbPath) + withState do createTables withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a withState what = do lock <- asks fixmeLock + db <- withMVar lock $ \_ -> do t <- asks fixmeEnvDb mdb <- readTVarIO t case mdb of Just d -> pure (Right d) Nothing -> do - path <- asks fixmeEnvDbPath >>= readTVarIO + path <- localDBPath newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path) case newDb of Left e -> pure (Left e) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 6c507343..cbbe2635 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -13,6 +13,7 @@ import DBPipe.SQLite hiding (field) import HBS2.Git.Local import HBS2.OrDie +import HBS2.System.Dir import HBS2.Storage as Exported import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client as Exported hiding (encode,decode) @@ -344,7 +345,7 @@ data FixmeEnv = FixmeEnv { fixmeLock :: MVar () , fixmeEnvOpts :: TVar FixmeOpts - , fixmeEnvDbPath :: TVar FilePath + , fixmeEnvWorkDir :: TVar FilePath , fixmeEnvDb :: TVar (Maybe DBPipeEnv) , fixmeEnvGitDir :: TVar (Maybe FilePath) , fixmeEnvFileMask :: TVar [FilePattern] @@ -411,11 +412,11 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } fixmeEnvBare :: forall m . FixmePerks m => m FixmeEnv -fixmeEnvBare = +fixmeEnvBare = do FixmeEnv <$> newMVar () <*> newTVarIO mempty - <*> newTVarIO ":memory:" + <*> (pwd >>= newTVarIO) <*> newTVarIO Nothing <*> newTVarIO Nothing <*> newTVarIO mempty diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index df465b9c..2a8f4332 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -508,6 +508,7 @@ theDict = do getRpcSocketEntry rpcPingEntry rpcIndexEntry + debugEntries where @@ -582,6 +583,13 @@ theDict = do withMyRPCClient so $ \caller -> do void $ callService @IndexNowRPC caller () + debugEntries = do + entry $ bindMatch "debug:select-repo-fixme" $ nil_ $ const $ lift do + rs <- selectRepoFixme + for_ rs $ \(r,f) -> do + liftIO $ print $ pretty r <+> pretty (AsBase58 f) + + main :: IO () main = do argz <- getArgs diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Fixme.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Fixme.hs new file mode 100644 index 00000000..2091701c --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Fixme.hs @@ -0,0 +1,11 @@ +module HBS2.Git.DashBoard.Fixme where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types + +-- import Fixme.State + + +-- runFixme :: + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs index 91e94425..45fb8fd5 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs @@ -1,3 +1,5 @@ +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} module HBS2.Git.DashBoard.Manifest where import HBS2.Git.DashBoard.Prelude @@ -7,6 +9,28 @@ import Data.Text qualified as Text import Data.Either import Streaming.Prelude qualified as S + +pattern FixmeRefChanP :: forall {c} . PubKey Sign HBS2Basic -> Syntax c +pattern FixmeRefChanP x <- ListVal [ SymbolVal "fixme:" + , ListVal [ SymbolVal "refchan", SignPubKeyLike x + ]] + + +pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c +pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob" + , SymbolVal (Id syn) + , LitStrVal name + , asGitHash -> Just hash + ] +{-# COMPLETE PinnedRefBlob #-} + +asGitHash :: forall c . Syntax c -> Maybe GitHash +asGitHash = \case + LitStrVal s -> fromStringMay (Text.unpack s) + _ -> Nothing + + + parseManifest :: Monad m => RepoHead -> m ([Syntax C], Text) parseManifest mhead = do 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 61868c38..a4b9ce63 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 @@ -57,8 +57,6 @@ instance Semigroup RepoListPred where instance Monoid RepoListPred where mempty = RepoListPred Nothing Nothing -type MyRefChan = RefChanId L4Proto -type MyRefLogKey = RefLogKey 'HBS2Basic evolveDB :: DashBoardPerks m => DBPipeM m () evolveDB = do @@ -183,6 +181,8 @@ newtype RepoLwwSeq = RepoLwwSeq Integer newtype RepoChannel = RepoChannel MyRefChan +newtype RefChanField = RefChanField MyRefChan + deriving stock (Generic) newtype RepoHeadRef = RepoHeadRef HashRef deriving stock (Generic) @@ -201,9 +201,20 @@ newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef) deriving stock (Generic) deriving newtype (ToField,FromField) +newtype Base58Field a = Base58Field { fromBase58Field :: a } + deriving stock (Eq,Ord,Generic) + + instance ToField RepoChannel where toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x) +instance ToField RefChanField where + toField (RefChanField x) = toField $ show $ pretty (AsBase58 x) + +instance FromField RefChanField where + fromField w = fromField @String w + >>= maybe (fail "invalid key") (pure . RefChanField) . fromStringMay + data TxProcessedTable data RepoTable data RepoChannelTable @@ -452,6 +463,15 @@ createRepoHeadTable = do ) |] + ddl [qc| + create table if not exists repoheadfixme + ( lww text not null + , lwwseq integer not null + , refchan text not null + , primary key (lww, lwwseq) + ) + |] + data RepoHeadTable instance HasTableName RepoHeadTable where @@ -496,6 +516,29 @@ insertRepoHead lww lwwseq rlog tx rf rh = do pure () + +insertRepoFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> RepoLwwSeq + -> MyRefChan + -> DBPipeM m () +insertRepoFixme lww lwwseq r = do + S.insert [qc| + insert into repoheadfixme (lww, lwwseq, refchan) values(?,?,?) + on conflict (lww, lwwseq) do update set refchan = excluded.refchan + |] + (lww, lwwseq, RefChanField r) + +selectRepoFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => m [(RepoLww, MyRefChan)] + +selectRepoFixme = do + let sql = [qc| + select lww, refchan from (select lww, refchan, max(lwwseq) from repoheadfixme group by lww) + |] + withState $ select_ @_ @(RepoLww, RefChanField) sql + <&> fmap (over _2 coerce) + -- FIXME: what-if-two-repo-shares-one-reflog? selectLwwByRefLog :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoRefLog -> m (Maybe RepoLww) selectLwwByRefLog rlog = withState do @@ -961,7 +1004,7 @@ deleteFixmeAllowed = do withState $ S.insert_ sql checkFixmeAllowed :: (DashBoardPerks m, MonadReader DashBoardEnv m) - => RepoRefLog + => RepoLww -> m Bool checkFixmeAllowed r = do @@ -981,6 +1024,10 @@ checkFixmeAllowed r = do pure $ not $ List.null w +-- listFixmeRefChans :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [Rep +-- listFixmeRefChans + + rpcSocketKey :: String rpcSocketKey = hashObject @HbSync (serialise "rpc-socket-name") & pretty & show 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 a05d6212..fc2caf5b 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 @@ -3,15 +3,41 @@ module HBS2.Git.DashBoard.State.Index.Peer where import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State +import HBS2.Git.DashBoard.Manifest import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx.Git +import HBS2.System.Dir + import Streaming.Prelude qualified as S +import System.Process.Typed + {- HLINT ignore "Functor law" -} seconds = TimeoutSec +updateFixmeFor :: ( MonadUnliftIO m + , MonadReader DashBoardEnv m + ) + => RepoLww + -> MyRefChan + -> m () +updateFixmeFor (RepoLww lw) f = do + p <- fixmeDataPath f + debug $ red "UPDATE-FIXME-FOR" <+> pretty (AsBase58 lw) <+> pretty (AsBase58 f) <+> pretty p + + let rcp = show $ pretty (AsBase58 f) + + mkdir p + + let cmdStr = [qc|fixme-new refchan {rcp} and fixme:refchan:import|] + let cmd = shell cmdStr & setWorkingDir p + + debug $ "run fixme for:" <+> pretty rcp <+> pretty cmdStr + + void $ runProcess cmd + updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m () updateIndexFromPeer = do debug "updateIndexFromPeer" @@ -36,6 +62,7 @@ updateIndexFromPeer = do lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk) + for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk) @@ -64,10 +91,24 @@ updateIndexFromPeer = do for_ txs $ \(n,tx,blk) -> void $ runMaybeT do (rhh, rhead) <- readRepoHeadFromTx sto tx >>= toMPlus debug $ yellow "found repo head" <+> pretty rhh <+> pretty "for" <+> pretty lw - lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead) + (man, _) <- parseManifest rhead + let fme = headMay [ x | FixmeRefChanP x <- man ] + lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme) withState $ transactional do - for_ headz $ \(l, tx, rh, rhead) -> do + for_ headz $ \(l, tx, rh, rhead, fme) -> do let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead + for_ fme $ \f -> do + insertRepoFixme l rlwwseq f + + fxe <- selectRepoFixme + + for_ fxe $ \(r,f) -> do + allowed <- checkFixmeAllowed r + when allowed do + env <-ask + addJob (withDashBoardEnv env $ updateFixmeFor r f) + + 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 de3a0cfc..e1d42a17 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 @@ -21,6 +21,9 @@ import System.FilePath import Data.Word +type MyRefChan = RefChanId L4Proto +type MyRefLogKey = RefLogKey 'HBS2Basic + data HttpPortOpt data DevelopAssetsOpt @@ -61,6 +64,9 @@ makeLenses 'DashBoardEnv repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath repoDataPath lw = asks _dataDir <&> ( (show $ pretty lw)) >>= canonicalizePath +fixmeDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => MyRefChan -> m FilePath +fixmeDataPath rchan = asks _dataDir <&> ( (show $ "fixme-" <> pretty (AsBase58 rchan))) >>= canonicalizePath + type DashBoardPerks m = MonadUnliftIO m newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a } 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 dd4c2c05..7d90b473 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 @@ -885,25 +885,6 @@ instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a)) -pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c -pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob" - , SymbolVal (Id syn) - , LitStrVal name - , asGitHash -> Just hash - ] -{-# COMPLETE PinnedRefBlob #-} - -asGitHash :: forall c . Syntax c -> Maybe GitHash -asGitHash = \case - LitStrVal s -> fromStringMay (Text.unpack s) - _ -> Nothing - - -pattern FixmeRefChanP :: forall {c} . PubKey Sign HBS2Basic -> Syntax c -pattern FixmeRefChanP x <- ListVal [ SymbolVal "fixme:" - , ListVal [ SymbolVal "refchan", SignPubKeyLike x - ]] - repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m) => RepoPageTabs -> LWWRefKey 'HBS2Basic @@ -928,7 +909,7 @@ 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 - allowed <- lift $ checkFixmeAllowed (RepoRefLog (coerce lww)) + allowed <- lift $ checkFixmeAllowed (RepoLww lww) let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ] debug $ red "META" <+> pretty meta @@ -1075,3 +1056,4 @@ repoPage tab lww params = rootPage do repoForks lww div_ [id_ "repo-tab-data-embedded"] mempty + diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index d0d8751c..01271888 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -154,6 +154,7 @@ executable hbs2-git-dashboard HBS2.Git.DashBoard.State.Index.Channels HBS2.Git.DashBoard.State.Index.Peer HBS2.Git.DashBoard.Manifest + HBS2.Git.DashBoard.Fixme HBS2.Git.Web.Html.Root -- other-extensions: