wip

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 :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
-fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
+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)
 

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"

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
 

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
+  dbPath <- localDBPath
-  liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
+  liftIO $ print $ "; fixme-state-path" <+> dquotes (pretty dbPath)
 
   (before,after) <- asks fixmeEnvCatContext >>= readTVarIO
 

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)

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

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

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 ::
+
+

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
 

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

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)
+
+

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 }

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
+

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: