wip, closing fixme database

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

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)

flake.lock

@@ -26,11 +26,11 @@
         ]
       },
       "locked": {
-        "lastModified": 1727252661,
+        "lastModified": 1727503203,
-        "narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=",
+        "narHash": "sha256-/HVVyxa55pDLzMiRgCWB4YKVsW2v9wFHTlSpLnyuhkU=",
         "ref": "refs/heads/master",
-        "rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c",
+        "rev": "7f28fdcb2ba9ccd426facffebf100e98522d7eac",
-        "revCount": 9,
+        "revCount": 11,
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       },

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

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 ()
+import DBPipe.SQLite (withDB, shutdown)
-withFixme repo m = do
+
-  p <- fixmeDataPath (coerce repo)
+import Data.Generics.Product.Fields (field)
-  debug $ pretty p
+
-
+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
 
 

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
+selectRepoFixmeRefChan :: (DashBoardPerks m, MonadReader DashBoardEnv m)
--- listFixmeRefChans
+                  => 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 =

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