diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs index 2fd05cca..82205acb 100644 --- a/fixme-new/lib/Fixme/Config.hs +++ b/fixme-new/lib/Fixme/Config.hs @@ -8,7 +8,7 @@ import System.Environment import System.Directory (getXdgDirectory, XdgDirectory(..)) binName :: FixmePerks m => m FilePath -binName = liftIO getProgName +binName = pure "fixme-new" -- liftIO getProgName localConfigDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath localConfigDir = do diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index cbbe2635..e8a0660f 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -369,7 +369,7 @@ data FixmeEnv = , fixmeEnvReader :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic)) , fixmeEnvFlags :: TVar (HashSet FixmeFlags) } - + deriving stock (Generic) fixmeGetCommentsFor :: FixmePerks m => Maybe FilePath -> FixmeM m [Text] @@ -464,7 +464,7 @@ instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI StorageAPI UNIX getClientAPI = getApiOrThrow peerStorageAPI -instance (FixmePerks m, MonadReader FixmeEnv m) => HasStorage m where +instance (FixmePerks m) => HasStorage (FixmeM m) where getStorage = do api <- getClientAPI @StorageAPI @UNIX pure $ AnyStorage (StorageClient api) diff --git a/flake.lock b/flake.lock index 777ca7b7..e324acc9 100644 --- a/flake.lock +++ b/flake.lock @@ -26,11 +26,11 @@ ] }, "locked": { - "lastModified": 1727252661, - "narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=", + "lastModified": 1727503203, + "narHash": "sha256-/HVVyxa55pDLzMiRgCWB4YKVsW2v9wFHTlSpLnyuhkU=", "ref": "refs/heads/master", - "rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c", - "revCount": 9, + "rev": "7f28fdcb2ba9ccd426facffebf100e98522d7eac", + "revCount": 11, "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" }, diff --git a/hbs2-git-dashboard/app/GitDashBoard.hs b/hbs2-git-dashboard/app/GitDashBoard.hs index b1198a5a..0ca60efd 100644 --- a/hbs2-git-dashboard/app/GitDashBoard.hs +++ b/hbs2-git-dashboard/app/GitDashBoard.hs @@ -22,6 +22,7 @@ import HBS2.Git.DashBoard.State import HBS2.Git.DashBoard.State.Index import HBS2.Git.DashBoard.State.Commits import HBS2.Git.DashBoard.Types +import HBS2.Git.DashBoard.Fixme import HBS2.Git.Web.Html.Root import HBS2.Peer.CLI.Detect @@ -583,6 +584,8 @@ theDict = do withMyRPCClient so $ \caller -> do void $ callService @IndexNowRPC caller () + -- TODO: ASAP-hide-debug-functions-from-help + debugEntries = do entry $ bindMatch "debug:select-repo-fixme" $ nil_ $ const $ lift do rs <- selectRepoFixme @@ -596,6 +599,18 @@ theDict = do _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "debug:test-with-fixme" $ nil_ $ \case + [SignPubKeyLike s] -> lift do + r <- runInFixme (RepoLww (LWWRefKey s)) (listFixme ()) + & try @_ @SomeException + >>= orThrowPassIO + + for_ r $ \f -> do + liftIO $ print $ pretty f + + _ -> throwIO $ BadFormException @C nil + main :: IO () main = do argz <- getArgs diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs index 7da3c58f..8880d255 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs @@ -1,17 +1,70 @@ -module HBS2.Git.DashBoard.Fixme where +module HBS2.Git.DashBoard.Fixme + ( F.listFixme + , F.HasPredicate(..) + , F.SelectPredicate(..) + , runInFixme + , RunInFixmeError(..) + ) where import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State -import Fixme.State +import HBS2.OrDie + +import Fixme.State qualified as F import Fixme.Types +import Fixme.Config -withFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> FixmeM m a -> m () -withFixme repo m = do - p <- fixmeDataPath (coerce repo) - debug $ pretty p - - +import DBPipe.SQLite (withDB, shutdown) + +import Data.Generics.Product.Fields (field) + +data RunInFixmeError = + FixmeRefChanNotFound RepoLww + deriving stock (Generic, Typeable, Show) + +instance Exception RunInFixmeError + +-- TODO: less-hacky-approach +-- этот код подразумевает, что мы знаем довольно много деталей +-- реализации про fixme-new +-- +-- Хорошо бы как-то абстрагировать, изолировать и т.п. +-- +runInFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> FixmeM m a -> m a +runInFixme repo m = do + + denv <- ask + + fixmeRChan <- withDashBoardEnv denv $ selectRepoFixmeRefChan repo + >>= orThrow (FixmeRefChanNotFound repo) + + p <- fixmeDataPath fixmeRChan + + fenv <- fixmeEnvBare + fo <- newTVarIO (FixmeOpts True) + + twd <- newTVarIO p + let fenvNew = fenv & set (field @"fixmeEnvWorkDir") twd + & set (field @"fixmeEnvOpts") fo + + -- TODO: close-fixme-database-garanteed + -- похоже, что надо будет фиксить db-pipe + + flip runContT pure do + dbe <- lift $ withFixmeEnv fenvNew $ F.withState ask + + void $ ContT $ bracket none (const $ shutdown False dbe) + + lift $ withFixmeEnv fenvNew do + dbp <- localDBPath + wd <- fixmeWorkDir + cfg <- localConfig + trace $ "fixme:dir" <+> pretty wd + trace $ "fixme:config" <+> pretty cfg + trace $ "fixme:db" <+> pretty dbp + + m diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs index a4b9ce63..d6d3c7fc 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs @@ -175,6 +175,9 @@ newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic) deriving stock (Generic) deriving newtype (ToField,FromField,Pretty) +instance Show RepoLww where + show (RepoLww x) = show $ parens $ "RepoLww" <+> pretty x + newtype RepoLwwSeq = RepoLwwSeq Integer deriving stock (Generic) deriving newtype (ToField,FromField,Pretty) @@ -1024,9 +1027,23 @@ checkFixmeAllowed r = do pure $ not $ List.null w --- listFixmeRefChans :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [Rep --- listFixmeRefChans +selectRepoFixmeRefChan :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => RepoLww + -> m (Maybe MyRefChan) +selectRepoFixmeRefChan r = do + let sql = [qc| + select refchan from ( + select lww + , refchan + , max(lwwseq) + from repoheadfixme + where lww = ? + group by lww, refchan + limit 1) + |] + withState (select @(Only RefChanField) sql (Only r)) + <&> (fmap coerce . headMay) rpcSocketKey :: String rpcSocketKey = diff --git a/hbs2-git-dashboard/hbs2-git-dashboard.cabal b/hbs2-git-dashboard/hbs2-git-dashboard.cabal index eed38542..42003706 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard.cabal +++ b/hbs2-git-dashboard/hbs2-git-dashboard.cabal @@ -91,6 +91,7 @@ library hbs2-git-dashboard-core , filepattern , generic-data , generic-deriving + , generic-lens , http-types , interpolatedstring-perl6 , lucid