fixme-new

.fixme-new/config

@@ -13,7 +13,7 @@ fixme-attribs assigned workflow :class
 
 fixme-attribs class
 
-fixme-value-set workflow new backlog wip test fixed done
+fixme-value-set :workflow :new :backlog :wip :test :fixed :done
 
 fixme-value-set class hardcode performance boilerplate
 
@@ -65,7 +65,6 @@ fixme-comments ";" "--"
 (define (backlog s) (modify s workflow :backlog))
 
 ;; refchan settings
-source ./config.local
+refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42
-
+source ./refchan.local
-
 

docs/todo/hbs2-peer-queues.txt

@@ -0,0 +1,29 @@
+TODO: hbs2-peer-queues
+  $workflow: backlog
+
+  Сделать механизм очередей ( циклических FIFO буферов )
+  с управлением ( put/get ) по RPC
+
+  hbs2-peer постоянно в памяти;
+
+  Тогда мы решаем проблемы блокировок в sqlite:
+
+  Процесс продюсер -- пишет в очередь через hbs2-peer ( на диск )
+
+  Процесс консьюмер -- читает оттуда и обновляет БД, когда к этому
+  готов.
+
+  Таким образом, мы избегаем проблем с блокировками и
+  получаем понятный асинхронный механизм взаимодействия
+  между разными программами из hbs2.
+
+  Технически их можно сделать на основе компактов, в каждый
+  compact пишутся сообщения в формате (n, bytestring), после
+  чтения консьюмером -- сообщения удаляются.
+
+  По превышению файлом компакта некоего размера --
+  производим компактизацию, т.е начинаем писать в новый
+  файл, а старый удаляем, как только в нём не останется
+  ничего для чтения... Ну или как-то так.
+
+

fixme-new/fixme.cabal

@@ -107,6 +107,7 @@ library
 
     other-modules:
       Fixme.Run.Internal
+      Fixme.Run.Internal.RefChan
 
     exposed-modules:
       Fixme
@@ -117,6 +118,7 @@ library
       Fixme.State
       Fixme.Scan
       Fixme.Scan.Git.Local
+      Fixme.GK
 
     build-depends:    base
                     , base16-bytestring

fixme-new/lib/Fixme/GK.hs

@@ -0,0 +1,96 @@
+{-# Language MultiWayIf #-}
+module Fixme.GK where
+
+import Fixme.Prelude
+import Fixme.Config
+import Fixme.Types
+
+import HBS2.OrDie
+-- import HBS2.System.Dir
+import HBS2.Storage.Operations.ByteString
+import HBS2.Storage.Operations.Class
+
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Peer.Proto.RefChan as RefChan
+import HBS2.System.Dir
+-- import HBS2.Net.Auth.Credentials
+
+import Control.Monad.Trans.Maybe
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Lens.Micro.Platform
+
+data GroupKeyOpError =
+    NoRefChanHead
+  | NoReadersSet
+  | GKLoadFailed
+  deriving (Eq,Ord,Show,Typeable)
+
+instance Exception GroupKeyOpError
+
+
+groupKeyFile :: forall m . FixmePerks m => m FilePath
+groupKeyFile = do
+  dir <- localConfigDir
+  pure $ dir </> "gk0"
+
+-- TODO: rotate-group-key
+
+loadGroupKey :: forall s m . (s ~ 'HBS2Basic, FixmePerks m) => FixmeM m (Maybe (HashRef, GroupKey 'Symm s))
+loadGroupKey = do
+
+  sto <- getStorage
+  gkF <- groupKeyFile
+
+  runMaybeT do
+
+    rchan <- lift (asks fixmeEnvRefChan >>= readTVarIO) >>= toMPlus
+
+    rch <- getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+             >>= orThrow NoRefChanHead
+
+    guard ( not $ HS.null (view refChanHeadReaders  rch) )
+
+    flip fix 0 $ \next -> \case
+
+      attempt | attempt > 2 -> throwIO GKLoadFailed
+
+      attempt -> do
+
+        let readers = view refChanHeadReaders rch
+
+        gkHash <- liftIO (try @_ @IOError $ readFile gkF)
+                    <&> either (const Nothing) ( (=<<) (fromStringMay @HashRef) . headMay . lines )
+
+        debug $ "GK0" <+> pretty gkHash
+
+        case gkHash of
+          Nothing -> do
+            debug "generate new group key"
+            gknew <- generateGroupKey @'HBS2Basic Nothing (HS.toList readers)
+            ha <- writeAsMerkle sto (serialise gknew)
+            liftIO $ writeFile gkF (show $ pretty ha)
+            next (succ attempt)
+
+          Just h -> do
+            now <- liftIO $ getPOSIXTime <&> round
+            gk' <- loadGroupKeyMaybe @s sto h
+
+            (_,gk) <- maybe1 gk' (rm gkF >> next (succ attempt)) (pure . (h,))
+
+            let ts = getGroupKeyTimestamp gk & fromMaybe 0
+
+            -- FIXME: timeout-hardcode
+            --   $class: hardcode
+            if | now - ts > 2592000 -> do
+                 rm gkF
+                 next (succ attempt)
+
+               | HM.keysSet (recipients gk) /= readers -> do
+                 rm gkF
+                 next (succ attempt)
+
+               | otherwise -> do
+                  pure (h,gk)
+

fixme-new/lib/Fixme/Run.hs

@@ -6,8 +6,10 @@ import Fixme.Types
 import Fixme.Config
 import Fixme.State
 import Fixme.Run.Internal
+import Fixme.Run.Internal.RefChan
 import Fixme.Scan.Git.Local as Git
 import Fixme.Scan as Scan
+import Fixme.GK as GK
 
 import Data.Config.Suckless.Script.File
 
@@ -138,6 +140,7 @@ runFixmeCLI m = do
             <*>  newTVarIO mzero
             <*>  newTVarIO mzero
             <*>  newTVarIO mzero
+            <*>  newTVarIO mempty
 
   -- FIXME: defer-evolve
   --   не все действия требуют БД,
@@ -196,10 +199,6 @@ runCLI = do
 
   runTop forms
 
-notEmpty :: [a] -> Maybe [a]
-notEmpty = \case
-  [] -> Nothing
-  x  -> Just x
 
 runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m ()
 runTop forms = do
@@ -360,6 +359,14 @@ runTop forms = do
           magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
           liftIO $ print $ pretty magic
 
+       entry $ bindMatch "fixme:gk:show" $ nil_ $ const do
+        w <- lift loadGroupKey
+        case w of
+          Just (h,_) -> do
+            liftIO $ print $ pretty h
+          _ -> do
+            liftIO $ print $ pretty "none"
+
        entry $ bindMatch "fixme:path" $ nil_ $ const do
           path <- lift fixmeWorkDir
           liftIO $ print $ pretty path
@@ -434,6 +441,12 @@ runTop forms = do
 
           _ ->  void $ lift $ refchanExport ()
 
+       entry $ bindMatch "fixme:refchan:import" $ nil_ $ \case
+          _ ->  void $ lift $ refchanImport
+
+       entry $ bindMatch "fixme:gk:export" $ nil_ $ \case
+          _ ->  void $ lift $ refchanExportGroupKeys
+
        entry $ bindMatch "source" $ nil_ $ \case
         [StringLike path] -> do
 
@@ -467,6 +480,11 @@ runTop forms = do
        entry $ bindMatch "fixme:refchan:update" $ nil_ $ const $ lift do
         refchanUpdate
 
+
+       entry $ bindMatch "cache:ignore" $ nil_ $ const $ lift do
+        tf <- asks fixmeEnvFlags
+        atomically $ modifyTVar tf (HS.insert FixmeIgnoreCached)
+
        entry $ bindMatch "git:blobs" $  \_ -> do
         blobs <- lift (listBlobs Nothing)
 
@@ -487,102 +505,10 @@ runTop forms = do
               ) $
          args [] $
          returns "string" "refchan-key" $ do
-         entry $ bindMatch "refchan:init" $ nil_ $ const $ do
+         entry $ bindMatch "fixme:refchan:init" $ nil_ $ \case
-
+          [] -> lift $ fixmeRefChanInit Nothing
-           let rch0 = refChanHeadDefault @L4Proto
+          [SignPubKeyLike rc] -> lift $ fixmeRefChanInit (Just rc)
-           sto <- lift getStorage
+          _ -> throwIO $ BadFormException @C nil
-           peer <- lift $ getClientAPI @PeerAPI @UNIX
-           rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX
-
-           confFile <- localConfig
-           conf <- liftIO (readFile confFile)
-                      <&> parseTop
-                      <&> either (error.show) (fmap (fixContext @_ @C))
-
-           let already = headMay [ x
-                                 | ListVal [StringLike "refchan", SignPubKeyLike x] <- conf
-                                 ]
-
-           flip runContT pure $ callCC \done -> do
-
-             when (isJust already) do
-              warn $ red "refchan is already set" <+> pretty (fmap AsBase58 already)
-
-             poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
-                        >>= orThrowUser "hbs2-peer not connected"
-                        <&> parseTop
-                        <&> fromRight mempty
-
-             pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x
-                     | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked
-                     ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set"
-
-
-             notice $ green "default peer" <+> pretty (AsBase58 pkey)
-
-
-             signK' <- lift $ runKeymanClientRO $ listCredentials
-                     <&> headMay
-
-             signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman")
-
-             notice $ green "default author" <+> pretty (AsBase58 signK)
-
-             -- TODO: use-hbs2-git-api?
-             (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|])
-                              <&> over _2 (  (fromStringMay @HashRef)  <=< (notEmpty . headDef "" . lines . LBS8.unpack) )
-                              <&> \x ->  case view _1 x of
-                                    ExitFailure _ -> set _2 Nothing x
-                                    ExitSuccess   -> x
-
-             notice $ green "group key" <+> maybe "none" pretty gkh'
-
-             readers <- fromMaybe mempty <$> runMaybeT do
-                          gh <- toMPlus gkh'
-                          gk <- loadGroupKeyMaybe @'HBS2Basic sto gh
-                                   >>= toMPlus
-                          pure $ HM.keys (recipients gk)
-
-             notice $ green "readers" <+> pretty (length readers)
-
-             let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers)
-                             & set refChanHeadAuthors (HS.singleton signK)
-                             & set refChanHeadPeers   (HM.singleton pkey 1)
-
-
-             let unlucky =    HM.null (view refChanHeadPeers rch1)
-                           || HS.null (view refChanHeadAuthors rch1)
-
-
-             liftIO $ print $ pretty rch1
-
-             if unlucky then do
-                warn $ red $ "refchan definition is not complete;" <+>
-                             "you may add missed keys, edit the"   <+>
-                             "defition and add if manually or repeat init attempt"
-                             <> line
-             else do
-                notice "refchan definition seems okay, adding new refchan"
-                refchan <- lift $ keymanNewCredentials (Just "refchan") 0
-
-                creds <- lift $ runKeymanClientRO $ loadCredentials refchan
-                               >>= orThrowUser "can't load credentials"
-
-                let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1
-
-                href <- writeAsMerkle sto  (serialise box)
-
-                callService @RpcPollAdd peer (refchan, "refchan", 17)
-                    >>= orThrowUser "can't subscribe to refchan"
-
-                callService @RpcRefChanHeadPost rchanApi (HashRef href)
-                    >>= orThrowUser "can't post refchan head"
-
-                liftIO $ appendFile confFile $
-                     show $ pretty ( mkList @C [ mkSym "refchan"
-                                               , mkSym (show $ pretty (AsBase58 refchan)) ]
-                                   )
-
 
        entry $ bindMatch "set-template" $ nil_ \case
          [SymbolVal who, SymbolVal w] -> do

fixme-new/lib/Fixme/Run/Internal.hs

@@ -9,31 +9,37 @@ import Fixme.Config
 import Fixme.State
 import Fixme.Scan.Git.Local as Git
 import Fixme.Scan as Scan
+import Fixme.GK
 
 import HBS2.Git.Local.CLI
+import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents,getGroupKeyHash)
+import HBS2.Merkle.MetaData
 
-import HBS2.Polling
 import HBS2.OrDie
 import HBS2.Base58
+import HBS2.Net.Auth.GroupKeySymm
 import HBS2.Data.Types.SignedBox
-import HBS2.Peer.Proto.RefChan
+import HBS2.Peer.Proto.RefChan as RefChan
 import HBS2.Peer.RPC.Client.RefChan
 import HBS2.Storage.Operations.ByteString
 import HBS2.System.Dir
 import HBS2.Net.Auth.Credentials
 import DBPipe.SQLite hiding (field)
 
-
+import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
 import HBS2.KeyMan.Keys.Direct
 
 import Data.Config.Suckless.Script.File
 
+import Data.List qualified as L
 import Data.List.Split (chunksOf)
 import Data.Aeson.Encode.Pretty as Aeson
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString qualified as BS
 import Data.Either
+import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Maybe
 import Data.HashSet qualified as HS
 import Data.HashMap.Strict (HashMap)
@@ -52,6 +58,7 @@ import Control.Concurrent.STM (flushTQueue)
 import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import System.Directory (getModificationTime)
 
+import System.IO as IO
 
 import Streaming.Prelude qualified as S
 
@@ -60,6 +67,7 @@ pattern IsSimpleTemplate xs <- ListVal (SymbolVal "simple" : xs)
 
 {- HLINT ignore "Functor law" -}
 
+
 defaultTemplate :: HashMap Id FixmeTemplate
 defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
   where
@@ -72,6 +80,37 @@ defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
     |]
 
 
+templateExample :: String
+templateExample = [qc|
+
+; this is an optional template example
+; for nicer fixme list
+;(define-template short
+;  (quot
+;    (simple
+;         (trim 10  $fixme-key) " "
+;
+;         (if (~ FIXME $fixme-tag)
+;          (then (fgd red (align 6  $fixme-tag))  )
+;          (else (if (~ TODO $fixme-tag)
+;                  (then (fgd green (align 6  $fixme-tag)))
+;                  (else (align 6  $fixme-tag)) ) )
+;          )
+;
+;
+;         (align 10  ("[" $workflow "]"))  " "
+;         (align 8  $class)  " "
+;         (align 12 $assigned)  " "
+;         (align 20 (trim 20 $committer-name)) " "
+;         (trim 50  ($fixme-title)) " "
+;         (nl))
+;    )
+;)
+; (set-template default short)
+
+|]
+
+
 init :: FixmePerks m => FixmeM m ()
 init = do
 
@@ -85,14 +124,62 @@ init = do
   let gitignore = lo </> ".gitignore"
   here <- doesPathExist gitignore
 
+  confPath <- localConfig
+
+  unless here do
+
+    liftIO $ appendFile confPath $ show $ vcat
+      [ mempty
+      , ";; this is a default fixme config"
+      , ";;"
+      , "fixme-prefix"    <+> "FIXME:"
+      , "fixme-prefix"    <+> "TODO:"
+      , "fixme-value-set" <+> hsep [":workflow", ":new",":wip",":backlog",":done"]
+      , "fixme-file-comments" <+> dquotes "*.scm" <+> dquotes ";"
+      , "fixme-comments" <+> dquotes ";"  <+> dquotes "--" <+> dquotes "#"
+      , mempty
+      ]
+
+    exts <- listBlobs Nothing
+              <&> fmap (takeExtension . fst)
+              <&> HS.toList . HS.fromList
+
+    for_ exts $ \e -> do
+      unless (e `elem` [".gitignore",".local"] )  do
+        liftIO $ appendFile confPath $
+          show $ ( "fixme-files" <+> dquotes ("**/*" <> pretty e) <> line )
+
+    liftIO $ appendFile confPath $ show $ vcat
+      [ "fixme-exclude" <+> dquotes "**/.**"
+      ]
+
+    liftIO $ appendFile confPath $ show $ vcat
+      [ mempty
+      , pretty templateExample
+      , ";; uncomment to source any other local settings file"
+      , ";; source ./my.local"
+      , mempty
+      ]
+
   unless here do
     liftIO $ writeFile gitignore $ show $
       vcat [ pretty ("." </> localDBName)
            ]
 
-  notice $ yellow "run" <> line <> vcat [
+  notice $ green "default config created:" <+> ".fixme-new/config" <> line
-      "git add" <+> pretty (lo0  </> ".gitignore")
+             <> "edit it for your project" <> line
+             <> "typically you need to add it to git"
+             <> line
+             <> "use (source ./some.local) form to add your personal settings" <> line
+             <> "which should not be shared amongst the whole project" <> line
+             <> "and add " <> yellow ".fixme-new/some.local" <+> "file to .gitignore"
+             <> line
+
+  notice $ "run" <> line <> vcat [
+      mempty
+    , "git add" <+> pretty (lo0  </> ".gitignore")
     , "git add" <+> pretty (lo0  </> "config")
+    , mempty
     ]
 
 
@@ -312,7 +399,11 @@ cat_ hash = do
       let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String
 
       let start = fromMaybe 0 fixmeStart & fromIntegral  & (\x -> x - before) & max 0
-      let bbefore = if start > before then before  + 1 else 1
+
+      debug $ red "start"  <+> pretty start
+      debug $ red "before" <+> pretty before
+
+      let bbefore = if start == 0 then before  else before + 1
       let origLen = maybe  0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1
       let lno   = max 1 $ origLen + after + before
 
@@ -371,18 +462,20 @@ refchanExport opts = do
 
   let (pk,sk) = (view peerSignPk creds, view peerSignSk creds)
 
+  gk0 <- loadGroupKey
+
+  -- TODO: this-may-cause-to-tx-flood
+  --   сделать какой-то период релакса,
+  --   что ли
+  now <- liftIO $ getPOSIXTime <&> round
+
   withState do
-    -- FIXME: select-only-really-missed-records
+    what <- select  @FixmeExported [qc|
-    --   сейчас всегда фуллскан. будет всё дольше и дольше
+      select distinct o,?,k,cast (v as text)
-    --   с ростом количества записей. Нужно отбирать
-    --   только такие элементы, которые реально отсутствуют
-    --   в рефчане
-    what <- select_ @_ @FixmeExported [qc|
-      select distinct o,w,k,cast (v as text)
       from object obj
       where not exists (select null from scanned where hash = obj.nonce)
       order by o, k, v, w
-      |]
+      |] (Only now)
 
     let chu  = chunksOf 10000 what
 
@@ -391,17 +484,19 @@ refchanExport opts = do
       for_ chu $ \x -> callCC \next -> do
 
         -- FIXME: encrypt-tree
-        --   1. откуда ключ взять
+
-        --   2. куда его положить
-        --   3. один на всех?
-        --   4. по одному на каждого?
-        --   5. как будет устроена ротация
         --   6. как делать доступ к историческим данным
         --   6.1 новые ключи в этот же рефчан
         --   6.2 или новые ключи в какой-то еще рефчан
-        h  <- writeAsMerkle sto (serialise x)
 
-        let tx = AnnotatedHashRef Nothing (HashRef h)
+        let s = maybe "[ ]" (const $ yellow "[@]") gk0
+
+        let gk = snd <$> gk0
+
+        href <- liftIO $ createTreeWithMetadata sto gk mempty (serialise x)
+                  >>= orThrowPassIO
+
+        let tx = AnnotatedHashRef Nothing href
 
         lift do
 
@@ -409,7 +504,7 @@ refchanExport opts = do
 
           let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
 
-          warn $ "POST" <+> red "unencrypted!" <+> pretty (length x) <+> pretty (hashObject @HbSync (serialise box))
+          warn $ "POST" <+> pretty (length x) <+> s <> "tree" <+> pretty href <+> pretty (hashObject @HbSync (serialise box))
 
           unless dry do
             r <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box)
@@ -419,18 +514,30 @@ refchanExport opts = do
 
       pure $ length what
 
+
 refchanUpdate :: FixmePerks m => FixmeM m ()
 refchanUpdate = do
 
+  refchanImport
+
   rchan <- asks fixmeEnvRefChan
              >>= readTVarIO
              >>= orThrowUser "refchan not set"
 
   api   <- getClientAPI @RefChanAPI @UNIX
 
+  sto <- getStorage
+
   h0 <- callService @RpcRefChanGet api rchan
          >>= orThrowUser "can't request refchan head"
 
+  rch <-  RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+              >>= orThrowUser "can't request refchan head"
+
+  let w = view refChanHeadWaitAccept rch
+
+  refchanExportGroupKeys
+
   txn <- refchanExport ()
 
   unless (txn == 0) do
@@ -443,7 +550,7 @@ refchanUpdate = do
 
     -- TODO: fix-this-lame-polling
     flip fix 0 $ \next -> \case
-      n | n >= 3 -> pure ()
+      n | n >= w -> pure ()
       n  -> do
 
         h <- callService @RpcRefChanGet api rchan
@@ -453,6 +560,7 @@ refchanUpdate = do
           pure ()
         else do
           pause @'Seconds 1
+          liftIO $ hPutStr stderr (show $ pretty (w - n) <> "    \r")
           next (succ n)
 
     none
@@ -474,12 +582,16 @@ refchanImport = do
 
   tq <- newTQueueIO
 
-  -- TODO: assume-huge-list
+  ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
-  -- scanned <- listAllScanned
+
-  let goodToGo x = do
+  let goodToGo x | ignCached = pure True
+                 | otherwise  = do
         here <- selectIsAlreadyScanned x
         pure $ not here
 
+  fixmeGkSign <- putBlock sto "FIXMEGROUPKEYBLOCKv1" <&> fmap HashRef
+                    >>= orThrowUser "hbs2 storage error. aborted"
+
   walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
 
     case  u of
@@ -489,52 +601,269 @@ refchanImport = do
         atomically $ modifyTVar ttsmap (HM.insertWith max what (coerce @_ @Word64 ts))
         atomically $ modifyTVar accepts (HM.insertWith (<>) what (HS.singleton txh))
 
+        scanned <- selectIsAlreadyScanned what
+        when scanned do
+           withState $ insertScanned txh
+
       A _  -> none
 
+      P orig (ProposeTran _ box) -> void $ runMaybeT do
+        (_, bs) <- unboxSignedBox0 box & toMPlus
+
+        AnnotatedHashRef sn href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                    & toMPlus . either (const Nothing) Just
+
+        scanned <- lift $ selectIsAlreadyScanned href
+
+        when (not scanned || ignCached) do
+
+          let isGk = sn == Just fixmeGkSign
+
+          if isGk then do
+
+            atomically $ writeTQueue tq (Left (txh, orig, href, href))
+
+          else do
+            what <- liftIO (runExceptT $ getTreeContents sto href)
+                      <&> either (const Nothing) Just
+                      >>= toMPlus
+
+            let exported = deserialiseOrFail @[FixmeExported] what
+                              & either (const Nothing) Just
+
+            case exported of
+              Just e -> do
+                for_ e $ \x -> do
+                  atomically $ writeTQueue tq (Right (txh, orig, href, x))
+
+              Nothing -> do
+                lift $ withState $ insertScanned txh
+
+  imported <- atomically $ flushTQueue tq
+
+  withState $ transactional do
+    for_ imported $ \case
+      Left (txh, orig, href, gk) -> do
+        -- hx <- writeAsMerkle sto (serialise gk)
+        -- notice $ "import GK" <+> pretty hx <+> "from" <+> pretty href
+        -- let tx = AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+        --                             & toMPlus . either (const Nothing) Just
+        insertScanned txh
+        -- TODO: ASAP-notify-hbs2-keyman
+        --   у нас два варианта:
+        --     1. звать runKeymanClient и в нём записывать в БД
+        --        с возможностью блокировок
+        --     2. каким-то образом делать отложенную запись,
+        --        например, писать лог групповых ключей
+        --        куда-то, откуда hbs2-keyman сможет
+        --        обновить их при запуске
+        --
+        --        лог групповых ключей мы можем писать:
+        --          1.  в рефлог, на который подписан и кейман
+        --          2.  в рефчан, на который подписан и кейман
+        --                неожиданные плюсы:
+        --                  + у нас уже есть такой рефчан!
+        --                    всё, что надо сделать  -- это записать ключи туда
+        --                    с одной стороны туповато: перекладывать транзы из
+        --                    рефчана в рефчан. с другой стороны -- не нужны никакие
+        --                    новые механизмы. рефчан, в общем-то, локальный(?),
+        --                    блоки никуда за пределы хоста не поедут (?) и сеть
+        --                    грузить не будут (?)
+        --
+        --          3.  в рефчан, используя notify
+        --          4.  в еще какую переменную, которая будет
+        --              локальна
+        --          5.  в какой-то лог. который кейман будет
+        --              процессировать при hbs2-keyman update
+        --
+        --      поскольку БД кеймана блокируется целиком при апдейтах,
+        --      единственное, куда писать проблематично -- это сама БД.
+        --
+        pure ()
+
+      Right (txh, h, href, i) -> do
+        w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h
+        let item = i { exportedWeight = w }
+
+        if exportedWeight item /= 0 then do
+          notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item)
+          insertFixmeExported (localNonce (href,i)) item
+        else do
+          debug $ "SKIP TX!" <+> pretty txh
+
+        atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h
+        insertScanned txh
+        insertScanned href
+        for_ atx insertScanned
+
+
+
+
+refchanExportGroupKeys :: FixmePerks m => FixmeM m ()
+refchanExportGroupKeys = do
+
+  let gkHash x = hashObject @HbSync ("GKSCAN" <> serialise x) & HashRef
+
+  sto <- getStorage
+
+  chan <- asks fixmeEnvRefChan
+           >>= readTVarIO
+           >>= orThrowUser "refchan not set"
+
+  ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
+
+  let goodToGo x | ignCached = pure True
+                 | otherwise = do
+        here <- selectIsAlreadyScanned (gkHash x)
+        pure $ not here
+
+  debug "refchanExportGroupKeys"
+
+  skip <- newTVarIO HS.empty
+  gkz <- newTVarIO HS.empty
+
+  fixmeSign <- putBlock sto "FIXMEGROUPKEYBLOCKv1" <&> fmap HashRef
+
+  walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
+
+    case u of
       P orig (ProposeTran _ box) -> void $ runMaybeT do
         (_, bs) <- unboxSignedBox0 box & toMPlus
 
         AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
                                     & toMPlus . either (const Nothing) Just
 
-        scanned <- lift $ selectIsAlreadyScanned href
+        result <- lift $ try @_ @OperationError  (getGroupKeyHash href)
 
-        -- notice $ yellow "SCANNED" <+> pretty scanned
+        case result of
+          Right (Just gk,_) -> do
+            atomically do
+              modifyTVar gkz  (HS.insert gk)
+              modifyTVar skip (HS.insert txh)
 
-        if scanned then do
+          Right (Nothing,_) -> do
-          atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh
+            atomically $ modifyTVar skip (HS.insert txh)
-          lift $ withState $ transactional do
-            insertScanned txh
-            for_ atx insertScanned
 
-        else do
+          Left UnsupportedFormat -> do
+            debug $ "unsupported" <+> pretty href
+            atomically $ modifyTVar skip (HS.insert txh)
 
-          -- FIXME: decrypt-tree
+          Left e -> do
-          what <- runExceptT (readFromMerkle sto (SimpleKey (coerce href)))
+             debug $ "other error" <+> viaShow e
-                    <&> either (const Nothing) Just
-                    >>= toMPlus
 
-          exported <- deserialiseOrFail @[FixmeExported] what
+      _ -> none
-                        & toMPlus
 
-          for_ exported $ \e -> do
+  l <- readTVarIO skip <&> HS.toList
-              atomically $ writeTQueue tq (txh, orig, href, e)
+  r <- readTVarIO gkz <&> HS.toList
-
-  imported <- atomically $ flushTQueue tq
 
   withState $ transactional do
-    for_ imported $ \(txh, h, href, i) -> do
+    for_ l (insertScanned . gkHash)
-      w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h
-      let item = i { exportedWeight = w }
 
-      if exportedWeight item /= 0 then do
+  rchan <- asks fixmeEnvRefChan
-        notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item)
+             >>= readTVarIO
-        insertFixmeExported (localNonce (href,i)) item
+             >>= orThrowUser "refchan not set"
-      else do
+
-        debug $ "SKIP TX!" <+> pretty txh
+  api   <- getClientAPI @RefChanAPI @UNIX
+
+  rch <-  RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+              >>= orThrowUser "can't request refchan head"
+
+  au <- asks fixmeEnvAuthor
+           >>= readTVarIO
+           >>= orThrowUser "author's key not set"
+
+  creds <- runKeymanClientRO $ loadCredentials au
+             >>= orThrowUser "can't read credentials"
+
+
+  let (pk,sk) = (view peerSignPk creds, view peerSignSk creds)
+
+  keyz <- Set.fromList <$> S.toList_ do
+    for_ r $ \gkh -> void $ runMaybeT do
+
+      debug $ red $ "FOR GK" <+> pretty gkh
+
+      gk <- loadGroupKeyMaybe @'HBS2Basic sto gkh >>= toMPlus
+
+      -- the original groupkey should be indexed as well
+      lift $ S.yield gkh
+
+      gks <- liftIO (runKeymanClientRO $ findMatchedGroupKeySecret sto gk)
+
+      when (isNothing gks) do
+      --   lift $ withState (insertScanned (gkHash txh))
+        warn $ "unaccessible group key" <+> pretty gkh
+        mzero
+
+      gk1 <- generateGroupKey @'HBS2Basic gks (HS.toList $ view refChanHeadReaders rch)
+      let lbs = serialise gk1
+      gkh1 <- writeAsMerkle sto lbs  <&> HashRef
+      debug $  red "prepare new gk0" <+> pretty (LBS.length lbs) <+> pretty gkh <+> pretty (groupKeyId gk)
+      lift $ S.yield gkh1
+
+  notice $ yellow $ "new gk:" <+> pretty (Set.size keyz)
+
+  -- let nitems = 262144 `div` (125 * HS.size (view refChanHeadReaders rch) )
+  -- let chunks = Map.elems keyz & chunksOf nitems
+
+  -- TODO: gk:performance-vs-reliability
+  --   ситуация такова: групповой ключ это меркл-дерево
+  --   для одного и того же блоба могут быть разные меркл-деревья,
+  --   так как могут быть разные настройки.
+  --
+  --   если распространять ключи по-одному, то хотя бы тот же ключ,
+  --   который мы создали изначально -- будет доступен по своему хэшу,
+  --   как отдельный артефакт.
+  --
+  --   Если писать их пачками, где каждый ключ представлен непосредственно,
+  --   то на принимающей стороне нет гарантии, что меркл дерево будет писаться
+  --   с таким же параметрами, хотя и может.
+  --
+  --   Решение:  делать групповой ключ БЛОКОМ. тогда его размер будет ограничен,
+  --   но он хотя бы будет всегда однозначно определён хэшем.
+  --
+  --   Решение: ссылаться не на групповой ключ, а на хэш его секрета
+  --   что ломает текущую схему и обратная совместимость будет морокой.
+  --
+  --   Решение: добавить в hbs2-keyman возможно индексации единичного
+  --   ключа, и индексировать таким образом *исходные* ключи.
+  --
+  --   Тогда можно эти вот ключи писать пачками, их хэши не имеют особого значения,
+  --   если мы проиндексируем оригинальный ключ и будем знать, на какой секрет он
+  --   ссылается.
+  --
+  --   Заметим, что в один блок поместится аж >2000 читателей, что должно быть
+  --   более, чем достаточно => при таких группах вероятность утечки секрета
+  --   стремится к 1.0, так как большинство клало болт на меры безопасности.
+  --
+  --   Кстати говоря, проблема недостаточного количества авторов в ключе легко
+  --   решается полем ORIGIN, т.к мы можем эти самые ключи разделять.
+  --
+  --   Что бы не стоять перед такой проблемой, мы всегда можем распостранять эти ключи
+  --   по-одному, ЛИБО добавить в производный ключ поле
+  --   ORIGIN: где будет хэш изначального ключа.
+  --
+  --   Это нормально, так как мы сможем проверить, что у этих ключей
+  --   (текущий и ORIGIN) одинаковые хэши секретов.
+  --
+  --   Это всё равно оставляет возможность еще одной DoS атаки на сервис,
+  --   с распространением кривых ключей, но это хотя бы выяснимо, ну и атака
+  --   может быть только в рамках рефчана, т.е лечится выкидыванием пиров /
+  --   исключением зловредных авторов.
+
+  for_ (Set.toList keyz) $ \href -> do
+
+      let tx = AnnotatedHashRef fixmeSign href
+
+      let lbs = serialise tx
+
+      let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs)
+
+      warn $ "post gk tx" <+> "tree" <+> pretty href
+
+      result <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) api (chan, box)
+
+      when (isNothing result) do
+        err $ red "hbs2-peer rpc calling timeout"
 
-      atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h
-      insertScanned txh
-      insertScanned href
-      for_ atx insertScanned
 

fixme-new/lib/Fixme/Run/Internal/RefChan.hs

@@ -0,0 +1,284 @@
+{-# Language MultiWayIf #-}
+module Fixme.Run.Internal.RefChan (fixmeRefChanInit) where
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.Config
+
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto.RefChan as RefChan
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Dir
+import HBS2.Net.Auth.Credentials
+
+import HBS2.CLI.Run.KeyMan (keymanNewCredentials)
+import HBS2.KeyMan.Keys.Direct
+
+
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Either
+import Data.Maybe
+import Data.List qualified as List
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Text.InterpolatedString.Perl6 (qc)
+import Lens.Micro.Platform
+import System.Process.Typed
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Data.Word
+import System.IO qualified as IO
+
+{- HLINT ignore "Functor law"-}
+
+notEmpty :: [a] -> Maybe [a]
+notEmpty = \case
+  [] -> Nothing
+  x  -> Just x
+
+
+data RefChanInitFSM =
+    InitInit
+  | SetupNewRefChan
+  | SetupExitFailure
+  | CheckRefChan (PubKey 'Sign 'HBS2Basic)
+  | RefChanHeadFound (PubKey 'Sign 'HBS2Basic) (RefChanHeadBlock L4Proto)
+  | WaitRefChanHeadStart (PubKey 'Sign 'HBS2Basic) Word64
+  | WaitRefChanHead (PubKey 'Sign 'HBS2Basic) Word64
+
+fixmeRefChanInit :: FixmePerks m => Maybe (PubKey 'Sign 'HBS2Basic) -> FixmeM m ()
+fixmeRefChanInit mbRc = do
+   let rch0 = refChanHeadDefault @L4Proto
+   sto <- getStorage
+   peer <- getClientAPI @PeerAPI @UNIX
+   rchanApi <- getClientAPI @RefChanAPI @UNIX
+
+   dir <- localConfigDir
+   confFile <- localConfig
+
+   rchan <- asks fixmeEnvRefChan
+              >>= readTVarIO
+
+   poked <- callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
+              >>= orThrowUser "hbs2-peer not connected"
+              <&> parseTop
+              <&> fromRight mempty
+
+   pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x
+           | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked
+           ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set"
+
+
+   let refChanClause r = mkList @C [ mkSym "refchan"
+                                   , mkSym (show $ pretty (AsBase58 r))
+                                   ]
+
+   flip runContT pure $ callCC \done -> do
+
+    flip fix InitInit $ \next -> \case
+      InitInit -> do
+
+        case (rchan, mbRc) of
+          (Nothing, Nothing) -> next SetupNewRefChan
+          (_, Just r2)  -> next (CheckRefChan r2)
+          (Just r1, Nothing) -> next (CheckRefChan r1)
+
+      CheckRefChan rc -> do
+        notice $ "check refchan:" <+> pretty (AsBase58 rc)
+
+        notice $ "subscribe to refchan" <+> pretty (AsBase58 rc)
+
+        -- FIXME: poll-time-hardcode
+        --   $class: hardcode
+        void $ callService @RpcPollAdd peer (rc, "refchan", 17)
+
+        notice $ "fetch refchan head" <+> pretty (AsBase58 rc)
+        void $ lift $ callRpcWaitMay  @RpcRefChanHeadFetch (TimeoutSec 1) rchanApi rc
+
+        now <- liftIO $ getPOSIXTime <&> round
+        pause @'Seconds 1
+        next $ WaitRefChanHead rc now
+
+      WaitRefChanHeadStart rc t -> do
+        notice $ "wait for refchan head" <+> pretty (AsBase58 rc)
+        next (WaitRefChanHead rc t)
+
+      WaitRefChanHead rc t -> do
+        now <- liftIO $ getPOSIXTime <&> round
+        let s = 60 - (now -t)
+        hd <- getRefChanHead @L4Proto sto (RefChanHeadKey rc)
+
+        liftIO $ IO.hPutStr stderr $ show $ "waiting" <+> pretty s <+> "      \r"
+
+        if | now - t < 60 && isNothing hd -> do
+             pause @'Seconds 1
+             next $ WaitRefChanHead rc t
+
+           | now - t > 60 && isNothing hd -> do
+             err "refchan wait timeout"
+             next $ SetupExitFailure
+
+           | isJust hd -> do
+              next $ RefChanHeadFound rc (fromJust hd)
+
+           | otherwise -> next $ SetupExitFailure
+
+      RefChanHeadFound rc hd -> do
+        notice $ "found refchan head for" <+> pretty (AsBase58 rc)
+        void $ lift $ callRpcWaitMay  @RpcRefChanFetch (TimeoutSec 1) rchanApi rc
+
+        author <- lift $ asks fixmeEnvAuthor >>= readTVarIO
+
+        let readers = view refChanHeadReaders hd
+        let authors = view refChanHeadAuthors hd
+
+        -- hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs
+        rs <- liftIO (runKeymanClientRO $ loadKeyRingEntries (HS.toList readers))
+
+        let isReader = case rs of
+                           [] -> False
+                           _  -> True
+
+        let canRead = if isReader then
+                        green "yes"
+                      else
+                        red "no"
+
+        notice $ "reader:" <+> canRead
+
+        let isAuthor = maybe1 author False (`HS.member` authors)
+
+        let canWrite = if isAuthor
+                        then green "yes"
+                        else red "no"
+
+        notice $ "author:" <+> canWrite
+
+        unless isReader do
+          warn $ yellow "no reader key found" <> line
+                 <>  "it's may be ok, if this refchan is not encrypted" <> line
+                 <>  "otherwise, make your encryption key a member of this refchan head"
+                 <> line
+
+        unless isAuthor do
+          warn $ red "no author key found" <> line
+                 <>  "it's may be ok if you have only read-only access to this refchan" <> line
+                 <>  "otherwise, use" <+> yellow "author KEY" <+> "settings in the .fixme-new/config" <> line
+                 <>  "and make sure it is added to the refchan head"
+                 <> line
+
+        unless (isJust rchan) do
+          notice $ "adding refchan to" <+> pretty confFile
+          liftIO do
+            appendFile confFile $ show $
+                line
+                <> vcat [ pretty (refChanClause rc) ]
+
+      SetupExitFailure -> do
+        err "refchan init failed"
+
+      SetupNewRefChan -> do
+
+        notice $ green "default peer" <+> pretty (AsBase58 pkey)
+
+        signK' <- lift $ runKeymanClientRO $ listCredentials
+                <&> headMay
+
+        signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman")
+
+        notice $ green "default author" <+> pretty (AsBase58 signK)
+
+        -- TODO: use-hbs2-git-api?
+        (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|])
+                         <&> over _2 (  (fromStringMay @HashRef)  <=< (notEmpty . headDef "" . lines . LBS8.unpack) )
+                         <&> \x ->  case view _1 x of
+                               ExitFailure _ -> set _2 Nothing x
+                               ExitSuccess   -> x
+
+        notice $ green "group key" <+> maybe "none" pretty gkh'
+
+        readers <- fromMaybe mempty <$> runMaybeT do
+                     gh <- toMPlus gkh'
+                     gk <- loadGroupKeyMaybe @'HBS2Basic sto gh
+                              >>= toMPlus
+                     pure $ HM.keys (recipients gk)
+
+        notice $ green "readers" <+> pretty (length readers)
+
+        rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers
+                <&> fmap snd . headMay
+
+
+        let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers)
+                        & set refChanHeadAuthors (HS.singleton signK)
+                        & set refChanHeadPeers   (HM.singleton pkey 1)
+
+
+        let unlucky =    HM.null (view refChanHeadPeers rch1)
+                      || HS.null (view refChanHeadAuthors rch1)
+
+        liftIO $ print $ pretty rch1
+
+        if unlucky then do
+           warn $ red $ "refchan definition is not complete;" <+>
+                        "you may add missed keys, edit the"   <+>
+                        "defition and add if manually or repeat init attempt"
+                        <> line
+        else do
+           notice "refchan definition seems okay, adding new refchan"
+
+           refchan <- lift $ keymanNewCredentials (Just "refchan") 0
+
+           creds <- lift $ runKeymanClientRO $ loadCredentials refchan
+                          >>= orThrowUser "can't load credentials"
+
+           let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1
+
+           href <- writeAsMerkle sto  (serialise box)
+
+           callService @RpcPollAdd peer (refchan, "refchan", 17)
+               >>= orThrowUser "can't subscribe to refchan"
+
+           callService @RpcRefChanHeadPost rchanApi (HashRef href)
+               >>= orThrowUser "can't post refchan head"
+
+
+           let nonce = take 6 $ show $ pretty (AsBase58 refchan)
+           let rchanFile = "refchan-" <> nonce <> ".local"
+           let rchanFilePath = dir </> rchanFile
+
+           let note =    ";; author and reader are inferred automatically" <> line
+                      <> ";; from hbs2-keyman data" <> line
+                      <> ";; edit them if needed" <> line
+                      <> ";; reader is *your* reading public key." <> line
+                      <> ";; author is *your* signing public key." <> line
+
+           let theirReaderKeyClause = maybe1 rk ";; reader ..."$ \(KeyringEntry pk _ _) -> do
+                  pretty $ mkList @C [ mkSym "reader", mkSym (show $ pretty (AsBase58 pk) )  ]
+
+           let theirAuthorClause  = mkList @C [ mkSym "author", mkSym (show $ pretty (AsBase58 signK) ) ]
+
+           let content =    line
+                         <> note
+                         <> line
+                         <> vcat [ theirReaderKeyClause
+                                 , pretty theirAuthorClause
+                                 ]
+
+           liftIO do
+             writeFile rchanFilePath $
+               show content
+
+           notice $ "adding refchan to" <+> pretty confFile
+           liftIO do
+             appendFile confFile $ show $
+                 line
+                 <> vcat [ pretty (refChanClause refchan) ]
+
+           next $ CheckRefChan refchan
+
+

fixme-new/lib/Fixme/RunOld.hs

@@ -1,791 +0,0 @@
-{-# Language MultiWayIf #-}
-{-# Language PatternSynonyms #-}
-{-# Language ViewPatterns #-}
-module Fixme.RunOld where
-
-import Prelude hiding (init)
-import Fixme.Prelude hiding (indent)
-import Fixme.Types
-import Fixme.Config
-import Fixme.State
-import Fixme.Scan.Git.Local as Git
-import Fixme.Scan as Scan
-
-import HBS2.Git.Local.CLI
-
-import HBS2.Base58
-import HBS2.Merkle
-import HBS2.Data.Types.Refs
-import HBS2.Storage
-import HBS2.Storage.Compact
-import HBS2.System.Dir
-import DBPipe.SQLite hiding (field)
-import Data.Config.Suckless
-
-import Data.Aeson.Encode.Pretty as Aeson
-import Data.ByteString (ByteString)
-import Data.ByteString.Lazy qualified as LBS
-import Data.ByteString.Lazy.Char8 qualified as LBS8
-import Data.Either
-import Data.Maybe
-import Data.HashSet qualified as HS
-import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HM
-import Data.HashSet (HashSet)
-import Data.Set qualified as Set
-import Data.Generics.Product.Fields (field)
-import Data.List qualified as List
-import Data.Text qualified as Text
-import Data.Text.IO qualified as Text
-import Text.InterpolatedString.Perl6 (qc)
-import Data.Coerce
-import Control.Monad.Identity
-import Lens.Micro.Platform
-import System.Process.Typed
-import Control.Monad.Trans.Cont
-import Control.Monad.Trans.Maybe
-import System.IO.Temp as Temp
-import System.IO qualified as IO
-
-
-import Streaming.Prelude qualified as S
-
-
-{- HLINT ignore "Functor law" -}
-
-pattern Init :: forall {c}. Syntax c
-pattern Init <- ListVal [SymbolVal "init"]
-
-pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c
-pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e))
-
-pattern Update :: forall {c}. [ScanGitArgs] -> Syntax c
-pattern Update e <- ListVal (SymbolVal "update" : (scanGitArgs -> e))
-
-pattern ReadFixmeStdin :: forall {c}.  Syntax c
-pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"]
-
-pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c
-pattern FixmeFiles e  <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e))
-
-
-pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c
-pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s]
-
-pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c
-pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ]
-
-
-logRootKey :: SomeRefKey ByteString
-logRootKey = SomeRefKey "ROOT"
-
-scanGitArgs :: [Syntax c] -> [ScanGitArgs]
-scanGitArgs syn = [ w | ScanGitArgs w <- syn ]
-
-
-fileMasks :: [Syntax c] -> [FilePattern]
-fileMasks what = [ show (pretty s) | s <- what ]
-
-fixmePrefix :: Syntax c -> Maybe FixmeTag
-fixmePrefix = \case
-  SymbolVal s -> Just (FixmeTag (coerce s))
-  _ -> Nothing
-
-
-defaultTemplate :: HashMap Id FixmeTemplate
-defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
-  where
-    short = parseTop s & fromRight mempty
-    s = [qc|
-(trim 10  $fixme-key) " "
-(align 6  $fixme-tag) " "
-(trim 50  ($fixme-title))
-(nl)
-    |]
-
-
-runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
-runFixmeCLI m = do
-  dbPath <- localDBPath
-  git <- findGitDir
-  env <- FixmeEnv
-            <$>  newMVar ()
-            <*>  newTVarIO mempty
-            <*>  newTVarIO dbPath
-            <*>  newTVarIO Nothing
-            <*>  newTVarIO git
-            <*>  newTVarIO mempty
-            <*>  newTVarIO mempty
-            <*>  newTVarIO mempty
-            <*>  newTVarIO mempty
-            <*>  newTVarIO mempty
-            <*>  newTVarIO defCommentMap
-            <*>  newTVarIO Nothing
-            <*>  newTVarIO mempty
-            <*>  newTVarIO mempty
-            <*>  newTVarIO defaultCatAction
-            <*>  newTVarIO defaultTemplate
-            <*>  newTVarIO mempty
-            <*>  newTVarIO (1,3)
-
-  -- FIXME: defer-evolve
-  --   не все действия требуют БД,
-  --   хорошо бы, что бы она не создавалась,
-  --   если не требуется
-  runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env
-                 `finally` flushLoggers
-  where
-    setupLogger = do
-      setLogging @ERROR  $ toStderr . logPrefix "[error] "
-      setLogging @WARN   $ toStderr . logPrefix "[warn] "
-      setLogging @NOTICE $ toStdout . logPrefix ""
-      pure ()
-
-    flushLoggers = do
-      silence
-
-    -- FIXME: tied-fucking-context
-    defaultCatAction = CatAction $ \dict lbs -> do
-      LBS.putStr lbs
-      pure ()
-
-silence :: FixmePerks m => m ()
-silence = do
-  setLoggingOff @DEBUG
-  setLoggingOff @ERROR
-  setLoggingOff @WARN
-  setLoggingOff @NOTICE
-
-
-
-readConfig :: FixmePerks m => FixmeM m [Syntax C]
-readConfig = do
-
-  user <- userConfigs
-  lo   <- localConfig
-
-  w <- for (lo : user) $ \conf -> do
-    try @_ @IOException (liftIO $ readFile conf)
-      <&> fromRight mempty
-      <&> parseTop
-      <&> fromRight mempty
-
-  pure $ mconcat w
-
-init :: FixmePerks m => FixmeM m ()
-init = do
-
-  lo <- localConfigDir
-
-  let lo0 = takeFileName lo
-
-  mkdir lo
-  touch (lo </> "config")
-
-  let gitignore = lo </> ".gitignore"
-  here <- doesPathExist gitignore
-
-  unless here do
-    liftIO $ writeFile gitignore $ show $
-      vcat [ pretty ("." </> localDBName)
-           ]
-
-  notice $ yellow "run" <> line <> vcat [
-      "git add" <+> pretty (lo0  </> ".gitignore")
-    , "git add" <+> pretty (lo0  </> "config")
-    ]
-
-
-
-readFixmeStdin :: FixmePerks m => FixmeM m ()
-readFixmeStdin = do
-  what <- liftIO LBS8.getContents
-  fixmies <- Scan.scanBlob Nothing what
-  liftIO $ print $ vcat (fmap pretty fixmies)
-
-
-list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m ()
-list_ tpl a = do
-  tpl <- asks fixmeEnvTemplates >>= readTVarIO
-            <&> HM.lookup (fromMaybe "default" tpl)
-
-  fixmies <- selectFixmeThin a
-
-  case tpl of
-    Nothing-> do
-      liftIO $ LBS.putStr $ Aeson.encodePretty fixmies
-
-    Just (Simple (SimpleTemplate simple)) -> do
-      for_ fixmies $ \(FixmeThin attr) -> do
-        let subst = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList attr ]
-        let what = render (SimpleTemplate (inject  subst simple))
-                      & fromRight "render error"
-
-        liftIO $ hPutDoc stdout what
-
-
-catFixmeMetadata :: FixmePerks m => Text -> FixmeM m ()
-catFixmeMetadata = cat_ True
-
-catFixme :: FixmePerks m => Text -> FixmeM m ()
-catFixme = cat_ False
-
-cat_ :: FixmePerks m => Bool -> Text -> FixmeM m ()
-cat_ metaOnly hash = do
-
-  (before,after)  <- asks fixmeEnvCatContext >>= readTVarIO
-  gd  <- fixmeGetGitDirCLIOpt
-
-  CatAction action <- asks fixmeEnvCatAction >>= readTVarIO
-
-  void $ flip runContT pure do
-    callCC \exit -> do
-
-      mha <- lift $ selectFixmeHash hash
-
-      ha <- ContT $ maybe1 mha (pure ())
-
-      fme' <- lift $ selectFixme ha
-
-      Fixme{..} <- ContT $ maybe1 fme' (pure ())
-
-      when metaOnly do
-        for_ (HM.toList fixmeAttr) $ \(k,v) -> do
-          liftIO $ print $ (pretty k <+> pretty v)
-        exit ()
-
-      let gh' = HM.lookup "blob" fixmeAttr
-
-      -- FIXME: define-fallback-action
-      gh <- ContT $ maybe1 gh' none
-
-      let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String
-
-      let start = fromMaybe 0 fixmeStart & fromIntegral  & (\x -> x - before) & max 0
-      let bbefore = if start > before then before  + 1 else 1
-      let origLen = maybe  0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1
-      let lno   = max 1 $ origLen + after + before
-
-      let dict = [ (mkId k, mkStr @C   v) | (k,v) <- HM.toList fixmeAttr ]
-                 <>
-                 [ (mkId (FixmeAttrName "before"), mkStr @C (FixmeAttrVal $ Text.pack $ show bbefore))
-                 ]
-
-      debug (pretty cmd)
-
-      w <- gitRunCommand cmd
-            <&> either (LBS8.pack . show) id
-            <&> LBS8.lines
-            <&> drop start
-            <&> take lno
-
-      liftIO $ action  dict (LBS8.unlines w)
-
-delete :: FixmePerks m => Text -> FixmeM m ()
-delete txt = do
-  acts <- asks fixmeEnvUpdateActions >>= readTVarIO
-  hashes <- selectFixmeHashes txt
-  for_ hashes $ \ha -> do
-    insertFixmeDelStaged ha
-
-modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m ()
-modify_ txt a b = do
-  acts <- asks fixmeEnvUpdateActions >>= readTVarIO
-  void $ runMaybeT do
-    ha <- toMPlus =<< lift (selectFixmeHash txt)
-    lift $ insertFixmeModStaged ha (fromString a) (fromString b)
-
-
-importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m ()
-importFromLog sto = do
-  fset <- listAllFixmeHashes
-
-  -- sto <- compactStorageOpen @HbSync readonly fn
-  ks   <- keys sto
-
-  toImport <- S.toList_ do
-    for_ ks $ \k -> runMaybeT do
-      v <- get sto k & MaybeT
-      what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus
-
-      case what of
-        Added _ fx  -> do
-          let ha = hashObject @HbSync (serialise fx) & HashRef
-          unless (HS.member ha fset) do
-            warn $ red "import" <+> viaShow (pretty ha)
-            lift $ S.yield (Right fx)
-        w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w))
-
-  withState $ transactional do
-    for_ (rights  toImport) insertFixme
-
-  let w = lefts toImport
-  eval (mconcat w)
-
-  unless (List.null toImport) do
-    updateIndexes
-
-  -- compactStorageClose sto
-
-printEnv :: FixmePerks m => FixmeM m ()
-printEnv = do
-  g <- asks fixmeEnvGitDir >>= readTVarIO
-  masks <- asks fixmeEnvFileMask >>= readTVarIO
-  tags  <- asks fixmeEnvTags >>= readTVarIO
-  days  <- asks fixmeEnvGitScanDays >>= readTVarIO
-  comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList
-
-  comments2 <- asks fixmeEnvFileComments >>= readTVarIO
-                 <&> HM.toList
-                 <&> fmap  (over _2 HS.toList)
-
-  attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
-  vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
-
-  for_ tags $ \m -> do
-    liftIO $ print $ "fixme-prefix" <+> pretty m
-
-  for_ masks $ \m -> do
-    liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
-
-  for_ days $ \d -> do
-    liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
-
-  for_ comments1 $ \d -> do
-    liftIO $ print $ "fixme-comments" <+> dquotes (pretty d)
-
-  for_ comments2 $ \(ft, comm') -> do
-    for_ comm' $ \comm -> do
-      liftIO $ print $ "fixme-file-comments"
-                  <+> dquotes (pretty ft) <+> dquotes (pretty  comm)
-
-  for_ attr $ \a -> do
-      liftIO $ print $ "fixme-attribs"
-                  <+> pretty a
-
-  for_ vals$ \(v, vs) -> do
-      liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs))
-
-  for_ g $ \git -> do
-    liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
-
-  dbPath <- asks fixmeEnvDbPath >>= readTVarIO
-  liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
-
-  (before,after) <- asks fixmeEnvCatContext >>= readTVarIO
-
-  liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
-
-  ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList
-
-  for_ ma $ \(n, syn) -> do
-    liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
-
-
-help :: FixmePerks m => m ()
-help = do
-  notice "this is help  message"
-
-
--- splitForms :: [String] -> [[String]]
--- splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
---   where
---     go acc ( "then" : rest ) = emit acc >> go mempty rest
---     go acc ( "and" : rest ) = emit acc >> go mempty rest
---     go acc ( x : rest ) = go ( x : acc ) rest
---     go acc [] = emit acc
-
---     emit = S.yield . reverse
-
-sanitizeLog :: [Syntax c] -> [Syntax c]
-sanitizeLog lls = flip filter lls $ \case
-  ListVal (SymbolVal "deleted" : _) -> True
-  ListVal (SymbolVal "modified" : _) -> True
-  _ -> False
-
-pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c]
-pattern Template w syn <- (mbTemplate  -> (w, syn))
-
-mbTemplate :: [Syntax c] -> (Maybe Id, [Syntax c])
-mbTemplate = \case
-  ( SymbolVal "template" : StringLike w : rest ) -> (Just (fromString w), rest)
-  other -> (Nothing, other)
-
-pattern IsSimpleTemplate ::  forall {c} . [Syntax c] -> [Syntax c]
-pattern IsSimpleTemplate xs <- [ListVal (SymbolVal "simple" : xs)]
-
-run :: FixmePerks m => [String] -> FixmeM m ()
-run what = do
-
-  sc <- readConfig
-
-  let s0 = fmap (parseTop . unwords) (splitForms what)
-             & rights
-             & mconcat
-
-  runForms (sc <> s0)
-
-
-runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
-         => [Syntax c]
-         -> FixmeM m ()
-runForms ss = for_  ss $ \s -> do
-
-  macros  <- asks fixmeEnvMacro >>= readTVarIO
-
-  debug $ pretty s
-
-  case s of
-
-    (ListVal (SymbolVal name : rest)) | HM.member name macros -> do
-      let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ]
-      maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do
-        debug $ yellow "run macro" <+> pretty macro
-        runForms [macro]
-
-    FixmeFiles xs -> do
-      t <- asks fixmeEnvFileMask
-      atomically (modifyTVar t (<> xs))
-
-    FixmePrefix tag -> do
-      t <- asks fixmeEnvTags
-      atomically (modifyTVar t (HS.insert tag))
-
-    FixmeGitScanFilterDays d -> do
-      t <- asks fixmeEnvGitScanDays
-      atomically (writeTVar t (Just d))
-
-    ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do
-      let co = Text.pack b & HS.singleton
-      t <- asks fixmeEnvFileComments
-      atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
-
-    ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do
-      t <- asks fixmeEnvDefComments
-      let co = fmap Text.pack xs & HS.fromList
-      atomically $ modifyTVar t (<> co)
-
-    ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do
-      ta <- asks fixmeEnvAttribs
-      atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
-
-    ListVal [SymbolVal "fixme-git-dir", StringLike g] -> do
-      ta <- asks fixmeEnvGitDir
-      atomically $ writeTVar ta (Just g)
-
-    ListVal [SymbolVal "fixme-state-path", StringLike g] -> do
-      p <- asks fixmeEnvDbPath
-      db <- asks fixmeEnvDb
-      atomically do
-        writeTVar p g
-        writeTVar db Nothing
-
-      evolve
-
-    ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do
-      t <- asks fixmeEnvCatContext
-      atomically $ writeTVar t (fromIntegral a, fromIntegral b)
-
-    ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do
-      t <- asks fixmeEnvCatAction
-      let action =  CatAction $ \dict lbs -> do
-
-            let ccmd = case inject dict cmd0 of
-                         (StringLike p : StringLikeList xs) -> Just (p, xs)
-                         _  -> Nothing
-
-
-            debug $ pretty ccmd
-
-            maybe1 ccmd none $ \(p, args) -> do
-
-              let input = byteStringInput lbs
-              let cmd = setStdin input $ setStderr closed
-                                       $ proc p args
-              void $ runProcess cmd
-
-      atomically $ writeTVar t action
-
-    ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do
-      t <- asks fixmeEnvAttribValues
-      let name = fromString n
-      let vals = fmap fromString xs & HS.fromList
-      atomically $ modifyTVar t (HM.insertWith (<>) name vals)
-
-    Init         -> init
-
-    ScanGitLocal args -> scanGitLocal args Nothing
-
-    Update args -> scanGitLocal args Nothing
-
-    ListVal (SymbolVal "list" : (Template n [])) -> do
-      debug $ "list" <+> pretty n
-      list_ n ()
-
-    ListVal (SymbolVal "list" : (Template n whatever)) -> do
-      debug $ "list" <+> pretty n
-      list_ n whatever
-
-    ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do
-      catFixmeMetadata hash
-
-    ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
-      catFixme hash
-
-    ListVal [SymbolVal "delete", FixmeHashLike hash] -> do
-      delete hash
-
-    ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do
-      modify_ hash a b
-
-    ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do
-      debug $ green $ pretty s
-      updateFixme (Just t) hash (fromString a) (fromString b)
-
-    ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do
-      debug $ green $ pretty s
-      updateFixme Nothing hash (fromString a) (fromString b)
-
-    ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do
-      deleteFixme hash
-
-    ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
-      deleteFixme hash
-
-    ListVal [SymbolVal "added", FixmeHashLike _] -> do
-      -- we don't add fixmies at this stage
-      -- but in fixme-import
-      none
-
-    ReadFixmeStdin -> readFixmeStdin
-
-    ListVal [SymbolVal "print-env"] -> printEnv
-
-    ListVal (SymbolVal "hello" : xs) -> do
-      notice $ "hello" <+> pretty xs
-
-    ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do
-      debug $ yellow "define-macro" <+> pretty name <+> pretty macro
-      macros <- asks fixmeEnvMacro
-      atomically $ modifyTVar macros (HM.insert name (fixContext macro))
-
-    ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do
-      trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs)
-      t <- asks fixmeEnvTemplates
-      atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs)))
-
-    ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do
-      templates <- asks fixmeEnvTemplates
-      t <- readTVarIO templates
-      for_ (HM.lookup w t) $ \tpl -> do
-        atomically $ modifyTVar templates (HM.insert who tpl)
-
-    -- FIXME: maybe-rename-fixme-update-action
-    ListVal (SymbolVal "fixme-update-action" : xs) -> do
-      debug $ "fixme-update-action" <+> pretty xs
-      env <- ask
-      t <- asks fixmeEnvUpdateActions
-      let repl syn = [ ( "$1", syn ) ]
-      let action = UpdateAction @c $ \syn -> do
-                       liftIO (withFixmeEnv env (runForms (inject (repl syn) xs)))
-
-      atomically $ modifyTVar t (<> [action])
-
-    ListVal (SymbolVal "update-action" : xs) -> do
-      debug $ "update-action" <+> pretty xs
-      env <- ask
-      t <- asks fixmeEnvReadLogActions
-      let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms  xs))
-      atomically $ modifyTVar t (<> [action])
-
-    ListVal [SymbolVal "import-git-logs", StringLike fn] -> do
-      warn $ red "import-git-logs" <+> pretty fn
-      scanGitLogLocal fn importFromLog
-
-    ListVal [SymbolVal "import", StringLike fn] -> do
-      warn $ red "IMPORT" <+> pretty fn
-      sto <- compactStorageOpen  readonly fn
-      importFromLog sto
-      compactStorageClose sto
-
-    ListVal [SymbolVal "export", StringLike fn] -> do
-      warn $ red "EXPORT" <+> pretty fn
-      exportToLog fn
-
-    ListVal [SymbolVal "git:list-refs"] -> do
-      refs <- listRefs False
-      for_ refs $ \(h,r) -> do
-        liftIO $ print $ pretty h <+> pretty r
-
-    ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do
-      debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b
-
-      temp <- liftIO $ emptyTempFile "." "merge-result"
-      sa  <- compactStorageOpen @HbSync readonly o
-      sb  <- compactStorageOpen @HbSync readonly b
-      r   <- compactStorageOpen @HbSync mempty temp
-
-      for_ [sa,sb] $ \sto -> do
-        ks   <- keys sto
-        for_ ks $ \k -> runMaybeT do
-          v <- get sto k & MaybeT
-          put r k v
-
-      compactStorageClose r
-      compactStorageClose sa
-      compactStorageClose sb
-
-      mv temp target
-
-    ListVal [SymbolVal "no-debug"] -> do
-      setLoggingOff @DEBUG
-
-    ListVal [SymbolVal "silence"] -> do
-      silence
-
-    ListVal [SymbolVal "builtin:run-stdin"] -> do
-      let ini = mempty :: [Text]
-      flip fix ini $ \next acc -> do
-        eof <- liftIO IO.isEOF
-        s <-   if eof then pure "" else liftIO Text.getLine <&> Text.strip
-        if Text.null s then do
-          let code = parseTop (Text.unlines acc) & fromRight mempty
-          runForms code
-          unless eof do
-            next mempty
-        else do
-          next (acc <> [s])
-
-    ListVal [SymbolVal "builtin:evolve"] -> do
-      evolve
-
-    ListVal [SymbolVal "builtin:list-commits"] -> do
-      co <- listCommits
-      liftIO $ print $ vcat (fmap (pretty . view _1) co)
-
-    ListVal [SymbolVal "builtin:cleanup-state"] -> do
-      cleanupDatabase
-
-    ListVal [SymbolVal "builtin:clean-stage"] -> do
-      cleanStage
-
-    ListVal [SymbolVal "builtin:drop-stage"] -> do
-      cleanStage
-
-    ListVal [SymbolVal "builtin:show-stage"] -> do
-      stage <- selectStage
-      liftIO $ print $ vcat (fmap pretty stage)
-
-    ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
-      sto <- compactStorageOpen @HbSync readonly fn
-
-      ks <- keys sto
-
-      entries <- mapM (get sto) ks
-                  <&> catMaybes
-                  <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
-                  <&> rights
-
-      liftIO $ print $ vcat (fmap pretty entries)
-
-      compactStorageClose sto
-
-    ListVal [SymbolVal "builtin:update-indexes"] -> do
-      updateIndexes
-
-    ListVal [SymbolVal "builtin:scan-magic"] -> do
-      magic <- scanMagic
-      liftIO $ print $ pretty magic
-
-    ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do
-      w <- selectFixmeHash x
-      liftIO $ print $ pretty w
-
-    ListVal [SymbolVal "builtin:git:list-stage"] -> do
-      stage <- gitListStage
-      for_ stage $ \case
-        Left (fn,h)  -> liftIO $ print $ "N" <+> pretty h <+> pretty fn
-        Right (fn,h) -> liftIO $ print $ "E" <+> pretty h <+> pretty fn
-
-    ListVal (SymbolVal "builtin:git:extract-file-meta-data" : StringLikeList fs) -> do
-      fxm <-  gitExtractFileMetaData fs <&> HM.toList
-      liftIO $ print $ vcat (fmap (pretty.snd) fxm)
-
-    ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do
-      env <- ask
-      gitStage <- gitListStage
-
-      let dry = or [ True | StringLike "dry" <- opts ]
-      let verbose = or [ True | StringLike "verbose" <- opts ]
-
-      blobs  <- for gitStage $ \case
-          Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn)
-          Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash))
-
-      let fns = fmap (view _1) blobs
-
-      -- TODO: extract-metadata-from-git-blame
-      --   subj
-
-      stageFile <- localConfigDir <&> (</> "current-stage.log")
-
-      fmeStage <- compactStorageOpen mempty stageFile
-
-      for_ blobs $ \(fn, bhash, readBlob) -> do
-        nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer)
-        lbs <- readBlob
-        fxs <- scanBlob (Just fn) lbs
-                 >>= \e -> do
-                  for e $ \fx0 -> do
-                    n <- atomically $ stateTVar nno (\m -> do
-                            let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0
-                            (what, HM.insert (fixmeTitle fx0) (succ what) m)
-                         )
-                    let ls = fixmePlain fx0
-                    meta <- getMetaDataFromGitBlame fn fx0
-                    let tit = fixmeTitle fx0 & coerce @_ @Text
-
-                    -- FIXME: fix-this-copypaste
-                    let ks  = [qc|{fn}#{tit}:{n}|] :: Text
-                    let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
-                    let kh = HM.singleton "fixme-key" ksh
-                    let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
-
-                    pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta)
-                             & set  (field @"fixmePlain") ls
-
-                             & over (field @"fixmeAttr")
-                                    (HM.insert "blob" (fromString $ show $ pretty bhash))
-                             & over (field @"fixmeAttr")
-                                    (mappend (kh<>kv))
-
-        unless dry do
-          for_ fxs $ \fx -> void $ runMaybeT do
-            e <- getEpoch
-            let what = Added e fx
-            let k = mkKey (FromFixmeKey fx)
-            get fmeStage k >>= guard . isNothing
-            put fmeStage k (LBS.toStrict $ serialise what)
-
-            when verbose do
-              liftIO $ print (pretty fx)
-
-      when dry do
-        warn $ red "FUCKING DRY!"
-
-      compactStorageClose fmeStage
-
-    ListVal [SymbolVal "trace"] -> do
-      setLogging @TRACE (logPrefix "[trace] " . toStderr)
-      trace "trace on"
-
-    ListVal [SymbolVal "no-trace"] -> do
-      trace "trace off"
-      setLoggingOff @TRACE
-
-    ListVal [SymbolVal "debug"] -> do
-      setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
-
-    w         -> err (pretty w)
-
-

fixme-new/lib/Fixme/Scan/Git/Local.hs

@@ -365,3 +365,5 @@ startGitCatFile = do
   -- ssin <- getStdin config
   startProcess config
 
+
+

fixme-new/lib/Fixme/State.hs

@@ -404,7 +404,7 @@ insertFixme fme = do
               when excluded.w > object.w and (excluded.v <> object.v) then excluded.w
               else object.w
             end,
-        nonce = case when excluded.w > object.w and (excluded.v <> object.v) then null
+        nonce = case when excluded.w > object.w and (excluded.v <> object.v) then excluded.nonce
                      else object.nonce
                 end
       |]

fixme-new/lib/Fixme/Types.hs

@@ -332,6 +332,14 @@ data PeerNotConnected = PeerNotConnected
 
 instance Exception PeerNotConnected
 
+data FixmeFlags =
+  FixmeIgnoreCached
+  deriving stock (Eq,Ord,Enum,Show,Generic)
+
+instance Hashable FixmeFlags
+  -- hashWithSalt s e = undefined
+
+
 data FixmeEnv =
   FixmeEnv
   { fixmeLock              :: MVar ()
@@ -358,6 +366,7 @@ data FixmeEnv =
   , fixmeEnvRefChan        :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
   , fixmeEnvAuthor         :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
   , fixmeEnvReader         :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic))
+  , fixmeEnvFlags          :: TVar (HashSet FixmeFlags)
   }
 
 
@@ -428,6 +437,7 @@ fixmeEnvBare =
     <*>  newTVarIO mzero
     <*>  newTVarIO mzero
     <*>  newTVarIO mzero
+    <*>  newTVarIO mempty
 
 withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
 withFixmeEnv env what = runReaderT ( fromFixmeM what) env

hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs

@@ -8,6 +8,7 @@ import HBS2.CLI.Run.Internal.GroupKey as G
 import HBS2.Hash
 import HBS2.Net.Auth.GroupKeySymm as Symm
 import HBS2.Data.Types.Refs
+import HBS2.Data.Detect
 import HBS2.Merkle
 import HBS2.Storage
 import HBS2.Storage.Operations.ByteString
@@ -19,6 +20,7 @@ import HBS2.KeyMan.Keys.Direct
 import HBS2.Net.Auth.Schema()
 
 import Codec.Serialise
+import Data.Coerce
 import Data.ByteString.Lazy qualified as LBS
 import Data.HashMap.Strict qualified as HM
 import Data.Text qualified as Text
@@ -26,22 +28,22 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Cont
 import Control.Monad.Except
 
+
 --FIXME: move-somewhere-else
-getGroupKeyHash :: ( IsContext c
+getGroupKeyHash :: ( MonadUnliftIO m
-                   , MonadUnliftIO m
                    , HasStorage m
                    , HasClientAPI StorageAPI UNIX m
                    )
                 => HashRef
-                -> RunM c m (Maybe HashRef, MTreeAnn [HashRef])
+                -> m (Maybe HashRef, MTreeAnn [HashRef])
 getGroupKeyHash h = do
   flip runContT pure do
-    sto <- getStorage
+    sto <- lift getStorage
 
     headBlock <- getBlock sto (fromHashRef h)
-                   >>= orThrowUser  "no-block"
+                   >>= orThrow MissedBlockError
                    <&> deserialiseOrFail @(MTreeAnn [HashRef])
-                   >>= orThrowUser  "invalid block format"
+                   >>= orThrow UnsupportedFormat
 
     case _mtaCrypt headBlock of
       (EncryptGroupNaClSymm hash _) ->
@@ -115,3 +117,39 @@ createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do
       runExceptT $ writeAsMerkle sto source <&> HashRef
 
 
+getTreeContents :: forall m . ( MonadUnliftIO m
+                              , MonadIO m
+                              , MonadError OperationError m
+                   )
+                => AnyStorage
+                -> HashRef
+                -> m LBS.ByteString
+
+getTreeContents sto href = do
+
+  blk <- getBlock sto (coerce href)
+           >>= orThrowError MissedBlockError
+
+  let q = tryDetect (coerce href) blk
+
+  case q of
+
+    Merkle _ -> do
+      readFromMerkle sto (SimpleKey (coerce href))
+
+    MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
+      readFromMerkle sto (SimpleKey (coerce href))
+
+    MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
+
+      rcpts  <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh)
+                  >>= orThrowError (GroupKeyNotFound 11)
+                  <&> HM.keys . Symm.recipients
+
+      let findStuff g = do
+            runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
+
+      readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
+
+    _ -> throwError UnsupportedFormat
+

hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs

@@ -3,6 +3,8 @@
 module HBS2.CLI.Run.MetaData
   ( metaDataEntries
   , createTreeWithMetadata
+  , getTreeContents
+  , getGroupKeyHash
   ) where
 
 import HBS2.CLI.Prelude

hbs2-core/lib/HBS2/Net/Messaging/Unix.hs

@@ -63,6 +63,18 @@ data MessagingUnixOpts =
   | MUKeepAlive Int
   deriving (Eq,Ord,Show,Generic,Data)
 
+-- TODO: counters-to-detect-zombies
+--   $class: leak
+--   добавить счётчики для обнаружения
+--   мёртвых соединений, а так же их отстрел.
+--   есть основания полагать, что Messaging
+--   может течь.
+--
+--   Шаг 1. добавить счётчики
+--   Шаг 2. убедиться, что ресурсы текут
+--   Шаг 3. устранить течь
+--   Шаг 4. убедиться, что течь устранена
+
 -- FIXME: use-bounded-queues
 data MessagingUnix =
   MessagingUnix

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs

@@ -157,6 +157,13 @@ extractGroupKeySecret gk = do
 
     pure $ headMay r
 
+trackGK :: forall s m . (MonadIO m, s ~ HBS2Basic)
+         => AnyStorage
+        -> HashRef
+        -> m ()
+trackGK sto href = do
+  -- gk <- loadGroupKeyMaybe @s sto href
+  pure ()
 
 type TrackGroupKeyView = ( SomeHash GroupKeyId
                          , SomeHash HashRef

hbs2-keyman/hbs2-keyman/Main.hs

@@ -136,8 +136,11 @@ updateKeys = do
       conf <- getConf
       let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
 
+      -- FIXME: assume-huge-list
       seen <- withState selectAllSeenGKTx
 
+      trace $ "SEEN" <+> pretty (List.length seen)
+
       flip runContT pure $ callCC \exit -> do
         when (List.null rchans) $ exit ()
         so' <- detectRPC
@@ -152,6 +155,8 @@ updateKeys = do
 
             for_ rchans $ \r -> do
 
+              notice $ "scan refchan" <+> pretty (AsBase58  r)
+
               walkRefChanTx @proto (pure . not . flip HS.member seen) r $ \tx0 -> \case
                 P _  (ProposeTran _ box) -> do
 
@@ -174,15 +179,19 @@ updateKeys = do
                     --   будет болтаться, если она не AnnotatedHashRef
                     lift $ lift $ S.yield (Left tx0)
 
-                    gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs & toMPlus
+                    let gkz1 = deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs
+                                  & either mempty List.singleton
 
-                    gkId <- getGroupKeyId gk & toMPlus
+                    for_ gkz1 $ \gk -> do
 
-                    --TODO: verify-group-key-id-if-possible
+                      gkId <- getGroupKeyId gk & toMPlus
 
-                    notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh
+                      --TODO: verify-group-key-id-if-possible
 
-                    lift $ lift $ S.yield (Right (gkId, gkh, gk) )
+                      notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh
+
+                      lift $ lift $ S.yield (Right (gkId, gkh, gk) )
+                      lift $ lift $ S.yield ( Left tx0 )
 
                 _ -> do
                   lift $ S.yield (Left tx0)

hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs

@@ -267,6 +267,9 @@ refChanUpdateProto self pc adapter msg = do
     guard =<< lift (refChanSubscribed adapter (getRefChanId msg))
 
     let h0 = hashObject @HbSync (serialise msg)
+
+    debug $ "RefchanUpdate: ALREADY" <+> pretty h0
+
     guard =<< liftIO (hasBlock sto h0 <&> isNothing)
 
     case msg of

hbs2-sync/src/HBS2/Sync/Internal.hs

@@ -11,6 +11,8 @@ import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.Unix (UNIX)
 import HBS2.Peer.RPC.Client
 
+import HBS2.CLI.Run.MetaData (getTreeContents)
+
 import HBS2.CLI.Run.Internal hiding (PeerNotConnectedException)
 
 import Control.Monad.Trans.Maybe

hbs2-sync/src/HBS2/Sync/State.hs

@@ -24,7 +24,7 @@ import HBS2.Peer.RPC.Client.RefChan as Client
 
 import HBS2.KeyMan.Keys.Direct
 
-import HBS2.CLI.Run.MetaData (createTreeWithMetadata)
+import HBS2.CLI.Run.MetaData (createTreeWithMetadata, getTreeContents)
 
 import DBPipe.SQLite
 import Data.Config.Suckless.Script.File
@@ -599,39 +599,6 @@ mergeState seed orig = do
         else
           new
 
-getTreeContents :: forall m . ( MonadUnliftIO m
-                              , MonadIO m
-                              , MonadError OperationError m
-                   )
-                => AnyStorage
-                -> HashRef
-                -> m LBS.ByteString
-
-getTreeContents sto href = do
-
-  blk <- getBlock sto (coerce href)
-           >>= orThrowError MissedBlockError
-
-  let q = tryDetect (coerce href) blk
-
-  case q of
-
-    MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
-      readFromMerkle sto (SimpleKey (coerce href))
-
-    MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
-
-      rcpts  <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh)
-                  >>= orThrowError (GroupKeyNotFound 11)
-                  <&> HM.keys . Symm.recipients
-
-      let findStuff g = do
-            runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
-
-      readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
-
-    _ -> throwError UnsupportedFormat
-
 
 runDirectory :: ( IsContext c
                 , SyncAppPerks m

hbs2-tests/test/TestRefChanNotify.hs

@@ -117,7 +117,7 @@ work = do
     --
     --   так лучше
     --
-    let o = [MUWatchdog 10,MUDontRetry]
+    let o = [MUWatchdog 10]
 
     soname <- detectRPC
                 >>= orThrowUser "hbs2-peer not found"

nix/peer/flake.lock

@@ -9,15 +9,16 @@
         ]
       },
       "locked": {
-        "lastModified": 1708680396,
+        "lastModified": 1713359411,
-        "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=",
+        "narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=",
-        "ref": "refs/heads/master",
+        "ref": "generic-sql",
-        "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827",
+        "rev": "03635c54b2e2bd809ec1196bc9082447279f6f24",
-        "revCount": 7,
+        "revCount": 9,
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       },
       "original": {
+        "ref": "generic-sql",
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       }
@@ -82,6 +83,21 @@
         "type": "github"
       }
     },
+    "flake-utils_10": {
+      "locked": {
+        "lastModified": 1644229661,
+        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
     "flake-utils_2": {
       "locked": {
         "lastModified": 1644229661,
@@ -187,6 +203,62 @@
         "type": "github"
       }
     },
+    "flake-utils_9": {
+      "locked": {
+        "lastModified": 1644229661,
+        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "fuzzy": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_4",
+        "nixpkgs": [
+          "hbs2",
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1715919110,
+        "narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
+        "ref": "refs/heads/master",
+        "rev": "5a55c22750589b357e50b759d2a754df058446d6",
+        "revCount": 40,
+        "type": "git",
+        "url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+      }
+    },
+    "fuzzy_2": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_8",
+        "nixpkgs": "nixpkgs_2"
+      },
+      "locked": {
+        "lastModified": 1715918584,
+        "narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
+        "rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
+        "revCount": 63,
+        "type": "git",
+        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
+      },
+      "original": {
+        "rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
+        "type": "git",
+        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
+      }
+    },
     "haskell-flake-utils": {
       "inputs": {
         "flake-utils": "flake-utils_2"
@@ -245,6 +317,24 @@
       "inputs": {
         "flake-utils": "flake-utils_5"
       },
+      "locked": {
+        "lastModified": 1707809372,
+        "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils_5": {
+      "inputs": {
+        "flake-utils": "flake-utils_6"
+      },
       "locked": {
         "lastModified": 1698938553,
         "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
@@ -260,9 +350,9 @@
         "type": "github"
       }
     },
-    "haskell-flake-utils_5": {
+    "haskell-flake-utils_6": {
       "inputs": {
-        "flake-utils": "flake-utils_6"
+        "flake-utils": "flake-utils_7"
       },
       "locked": {
         "lastModified": 1672412555,
@@ -279,9 +369,9 @@
         "type": "github"
       }
     },
-    "haskell-flake-utils_6": {
+    "haskell-flake-utils_7": {
       "inputs": {
-        "flake-utils": "flake-utils_7"
+        "flake-utils": "flake-utils_8"
       },
       "locked": {
         "lastModified": 1698938553,
@@ -297,9 +387,27 @@
         "type": "github"
       }
     },
-    "haskell-flake-utils_7": {
+    "haskell-flake-utils_8": {
       "inputs": {
-        "flake-utils": "flake-utils_8"
+        "flake-utils": "flake-utils_9"
+      },
+      "locked": {
+        "lastModified": 1707809372,
+        "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils_9": {
+      "inputs": {
+        "flake-utils": "flake-utils_10"
       },
       "locked": {
         "lastModified": 1672412555,
@@ -319,7 +427,8 @@
       "inputs": {
         "db-pipe": "db-pipe",
         "fixme": "fixme",
-        "haskell-flake-utils": "haskell-flake-utils_4",
+        "fuzzy": "fuzzy",
+        "haskell-flake-utils": "haskell-flake-utils_5",
         "hspup": "hspup",
         "lsm": "lsm",
         "nixpkgs": [
@@ -329,17 +438,15 @@
         "suckless-conf": "suckless-conf_2"
       },
       "locked": {
-        "lastModified": 1713159635,
+        "lastModified": 1726739166,
-        "narHash": "sha256-iXf8qcJxePLM65E0fsAK2kj69/YIyQdNMrZ5yULzVGc=",
+        "narHash": "sha256-8IXnyZnKZY2kaKNgdYHDzDcMOxxmtSvkQ9HRctSM4xk=",
-        "ref": "hbs2-git-index",
+        "rev": "627a3e0911d470b0f06d986d8bc663f934269d0e",
-        "rev": "2289845078ba839bade83a1daf5234435e6e631e",
+        "revCount": 1022,
-        "revCount": 997,
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       },
       "original": {
-        "ref": "hbs2-git-index",
+        "rev": "627a3e0911d470b0f06d986d8bc663f934269d0e",
-        "rev": "2289845078ba839bade83a1daf5234435e6e631e",
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       }
@@ -366,7 +473,7 @@
     },
     "hspup": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_5",
+        "haskell-flake-utils": "haskell-flake-utils_6",
         "nixpkgs": [
           "hbs2",
           "nixpkgs"
@@ -388,7 +495,7 @@
     },
     "lsm": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_6",
+        "haskell-flake-utils": "haskell-flake-utils_7",
         "nixpkgs": [
           "hbs2",
           "nixpkgs"
@@ -425,6 +532,22 @@
       }
     },
     "nixpkgs_2": {
+      "locked": {
+        "lastModified": 1707451808,
+        "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "442d407992384ed9c0e6d352de75b69079904e4e",
+        "type": "github"
+      }
+    },
+    "nixpkgs_3": {
       "locked": {
         "lastModified": 1709200309,
         "narHash": "sha256-lKdtMbhnBNU1lr978T+wEYet3sfIXXgyiDZNEgx8CV8=",
@@ -445,7 +568,7 @@
         "extra-container": "extra-container",
         "hbs2": "hbs2",
         "home-manager": "home-manager",
-        "nixpkgs": "nixpkgs_2"
+        "nixpkgs": "nixpkgs_3"
       }
     },
     "saltine": {
@@ -490,22 +613,23 @@
     },
     "suckless-conf_2": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_7",
+        "fuzzy": "fuzzy_2",
+        "haskell-flake-utils": "haskell-flake-utils_9",
         "nixpkgs": [
           "hbs2",
           "nixpkgs"
         ]
       },
       "locked": {
-        "lastModified": 1704001322,
+        "lastModified": 1724740155,
-        "narHash": "sha256-D7T/8wAg5J4KkRw0uB90w3+adY11aQaX7rjmQPXkkQc=",
+        "narHash": "sha256-dHAWLoQ0uZ2FckV/93qbXo6aYCTY+jARXiiTgUt6fcA=",
-        "ref": "refs/heads/master",
+        "rev": "b6c5087312e6c09e5c27082da47846f377f73756",
-        "rev": "8cfc1272bb79ef6ad62ae6a625f21e239916d196",
+        "revCount": 38,
-        "revCount": 28,
         "type": "git",
         "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
       },
       "original": {
+        "rev": "b6c5087312e6c09e5c27082da47846f377f73756",
         "type": "git",
         "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
       }

nix/peer/flake.nix

@@ -7,7 +7,7 @@
     extra-container.url = "github:erikarvstedt/extra-container";
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
     hbs2.url =
-      "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?rev=3b8f3d48f486043c7fa2df5990e5ab96b71996e1";
+      "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?rev=627a3e0911d470b0f06d986d8bc663f934269d0e";
     hbs2.inputs.nixpkgs.follows = "nixpkgs";
 
     home-manager.url = "github:nix-community/home-manager";