merged hbs2-cli ans hbs2-sync

.envrc

@@ -1,3 +1,4 @@
+## wtf
 if [ -f .envrc.local ]; then
   source_env .envrc.local
 fi

.fixme-new/.gitignore

@@ -0,0 +1 @@
+state.db

.fixme-new/config

@@ -0,0 +1,106 @@
+
+; fixme-files **/*.hs docs/devlog.md
+
+; no-debug
+; debug
+
+fixme-prefix     FIXME:
+fixme-prefix     TODO:
+fixme-prefix     PR:
+fixme-prefix     REVIEW:
+
+fixme-git-scan-filter-days 30
+
+fixme-attribs assigned workflow type
+
+fixme-attribs resolution cat scope
+
+fixme-value-set workflow new backlog wip test fixed done
+
+fixme-value-set cat bug feat refactor
+
+fixme-value-set scope mvp-0 mvp-1 backlog
+
+fixme-value-set type bug feature code
+
+fixme-files **/*.txt docs/devlog.md
+fixme-files **/*.hs
+
+fixme-file-comments "*.scm" ";"
+
+fixme-comments ";" "--"
+
+(update-action
+  (import-git-logs ".fixme-new/log")
+)
+
+(update-action
+  (import ".fixme-new/fixme.log")
+)
+
+(update-action
+  (export ".fixme-new/fixme.log")
+)
+
+
+(update-action
+  (hello kitty)
+)
+
+(define-macro done
+  (modify $1 workflow done)
+)
+
+(define-macro wip
+  (modify $1 workflow wip)
+)
+
+(define-macro test
+  (modify $1 workflow test)
+)
+
+(define-macro backlog
+  (modify $1 workflow backlog)
+)
+
+(define-macro fixed
+  (modify $1 workflow fixed)
+)
+
+(define-macro new
+  (modify $1 workflow new)
+)
+
+(define-macro stage
+  (builtin:show-stage))
+
+(define-macro log
+  (builtin:show-log .fixme-new/fixme.log))
+
+
+(define-template short
+  (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  $type)  " "
+     (align 12 $assigned)  " "
+     (align 20 (trim 20 $committer-name)) " "
+     (trim 50  ($fixme-title)) " "
+     (nl)
+  )
+)
+
+(set-template default short)
+
+; update
+
+

.fixme/config

@@ -20,8 +20,7 @@ fixme-files docs/notes/**/*.txt
 
 fixme-files-ignore .direnv/** dist-newstyle/**
 
-fixme-id-show-len 10
+fixme-id-show-len 12
-
 
 fixme-attribs assigned workflow resolution cat scope
 

.fixme/log

@@ -1,2 +1,3 @@
 
-(fixme-set "workflow" "done" "RsTry2C5Gk")
+(fixme-set "workflow" "done" "RsTry2C5Gk")
+(fixme-set "workflow" "done" "DYfcfsNCrU")

.gitattributes

@@ -0,0 +1,2 @@
+.fixme-new/log merge=fixme-log-merge
+.fixme-new/fixme.log merge=fixme-log-merge

.gitignore

@@ -11,3 +11,5 @@ cabal.project.local
 
 .backup/
 .hbs2-git/
+bin/
+.fixme-new/current-stage.log

CHANGELOG.md

@@ -1,3 +1,4 @@
 
-# 0.24.1.1  2024-04-02
+# 0.24.1.2  2024-04-27
-  - Don't do HTTP redirect on /ref/XXXXXXXXXX requests; show content directly
+  - Bump scotty version
+

Makefile

@@ -13,8 +13,13 @@ BINS := \
   hbs2-keyman        \
 	hbs2-fixer         \
 	hbs2-git-subscribe \
+	hbs2-git-dashboard \
   git-remote-hbs2    \
   git-hbs2           \
+  hbs2-cli           \
+  hbs2-sync          \
+  fixme-new          \
+	hbs2-storage-simple-benchmarks \
 
 ifeq ($(origin .RECIPEPREFIX), undefined)
   $(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)

cabal.project

@@ -3,6 +3,9 @@ packages: **/*.cabal
 
 allow-newer: all
 
+constraints: pandoc >=3.1.11, suckless-conf >= 0.1.2.6
+
+
 -- executable-static: True
 -- profiling: True
 -- library-profiling: False

examples/refchan-qblf/app/RefChanQBLFMain.hs

@@ -70,36 +70,36 @@ data DefStateOpt
 data StateRefOpt
 
 data QBLFRefKey
-type MyRefKey = AnyRefKey QBLFRefKey HBS2Basic
+type MyRefKey = AnyRefKey QBLFRefKey 'HBS2Basic
 
-instance Monad m => HasCfgKey HttpPortOpt (Maybe Int) m where
+instance HasCfgKey HttpPortOpt (Maybe Int) where
   key = "http"
 
 
-instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int) m) => HasCfgValue HttpPortOpt (Maybe Int) m where
+instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int)) => HasCfgValue HttpPortOpt (Maybe Int) m where
   cfgValue  = val <$> getConf
     where
       val syn = lastMay [ fromIntegral e
-                | ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int) @m
+                | ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int)
                 ]
 
-instance Monad m => HasCfgKey RefChanOpt (Maybe String) m where
+instance HasCfgKey RefChanOpt (Maybe String)  where
   key = "refchan"
 
-instance Monad m => HasCfgKey SocketOpt (Maybe String) m where
+instance HasCfgKey SocketOpt (Maybe String)  where
   key = "socket"
 
-instance Monad m => HasCfgKey ActorOpt (Maybe String) m where
+instance HasCfgKey ActorOpt (Maybe String)  where
   key = "actor"
 
-instance Monad m => HasCfgKey DefStateOpt (Maybe String) m where
+instance HasCfgKey DefStateOpt (Maybe String) where
   key = "default-state"
 
-instance Monad m => HasCfgKey StateRefOpt (Maybe String) m where
+instance HasCfgKey StateRefOpt (Maybe String) where
   key = "state-ref"
 
-class ToBalance e tx where
+class ToBalance s tx where
-  toBalance :: tx -> [(Account e, Amount)]
+  toBalance :: tx -> [(Account s, Amount)]
 
 tracePrefix :: SetLoggerEntry
 tracePrefix  = toStderr . logPrefix "[trace] "
@@ -153,7 +153,7 @@ data MyEnv =
   , myChan  :: RefChanId UNIX
   , myRef   :: MyRefKey
   , mySto   :: AnyStorage
-  , myCred  :: PeerCredentials HBS2Basic
+  , myCred  :: PeerCredentials 'HBS2Basic
   , myHttpPort :: Int
   , myFetch :: Cache HashRef ()
   }
@@ -211,8 +211,8 @@ instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (App m) where
   tryLockForPeriod _ _ = pure True
 
 instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (App m) where
-  type QBLFActor ConsensusQBLF = Actor L4Proto
+  type QBLFActor ConsensusQBLF = Actor 'HBS2Basic
-  type QBLFTransaction ConsensusQBLF = QBLFDemoToken L4Proto
+  type QBLFTransaction ConsensusQBLF = QBLFDemoToken 'HBS2Basic
   type QBLFState ConsensusQBLF = DAppState
 
   qblfMoveForward _ s1 = do
@@ -247,7 +247,7 @@ instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (App m) wher
               -- пробуем разослать бандлы с транзакциями
               runMaybeT do
                 ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
-                let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref)
+                let refval = makeBundleRefValue @'HBS2Basic pk sk (BundleRefSimple ref)
                 r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
                 lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
 
@@ -280,7 +280,7 @@ instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (App m) wher
       let sk = view peerSignSk creds
       let pk = view peerSignPk creds
       nonce <- randomIO @Word64 <&> serialise <&> LBS.toStrict
-      let box = makeSignedBox @UNIX pk sk (LBS.toStrict (serialise msg) <> nonce)
+      let box = makeSignedBox pk sk (LBS.toStrict (serialise msg) <> nonce)
       let notify = Notify @UNIX chan box
       request self notify
 
@@ -327,17 +327,17 @@ instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (App m) wher
 
               bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t)
 
-              tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) bs & either (const Nothing) Just
+              tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bs & either (const Nothing) Just
 
               case tx of
                 Emit box -> do
-                  (pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box
+                  (pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box
                   guard ( chan == pk )
                   debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
                   pure ([(t,e)], mempty)
 
                 (Move box) -> do
-                  (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box
+                  (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx 'HBS2Basic) box
 
                   guard (qty > 0)
                   debug $ "MOVE TRANSACTION" <+> pretty t
@@ -352,7 +352,7 @@ instance (ForConsensus m, MonadUnliftIO m)  => IsQBLF ConsensusQBLF (App m) wher
       bal0 <- balances (fromDAppState s0)
 
       -- баланс с учётом новых emit
-      let balE = foldMap (toBalance @L4Proto . snd) emits
+      let balE = foldMap (toBalance @'HBS2Basic. snd) emits
                         & HashMap.fromListWith (+)
                         & HashMap.unionWith (+) bal0
 
@@ -391,12 +391,12 @@ balances :: forall e s m . ( e ~ L4Proto
                            , HasStorage m
                            -- , FromStringMaybe (PubKey 'Sign s)
                            , s ~ Encryption e
-                           , ToBalance L4Proto (EmitTx L4Proto)
+                           , ToBalance s (EmitTx s)
-                           , ToBalance L4Proto (MoveTx L4Proto)
+                           , ToBalance s (MoveTx s)
                            , Pretty (AsBase58 (PubKey 'Sign s))
                            )
          => HashRef
-         -> m (HashMap (Account e) Amount)
+         -> m (HashMap (Account s) Amount)
 
 balances root = do
   sto <- getStorage
@@ -406,7 +406,7 @@ balances root = do
   cached <- runMaybeT do
     rval <- MaybeT $ liftIO $ getRef sto pk
     val  <- MaybeT $ liftIO $ getBlock sto rval
-    MaybeT $ deserialiseOrFail @(HashMap (Account e) Amount) val
+    MaybeT $ deserialiseOrFail @(HashMap (Account s) Amount) val
           & either (const $ pure Nothing) (pure . Just)
 
   case cached of
@@ -417,16 +417,16 @@ balances root = do
 
       r <- forM txs $ \h -> runMaybeT do
         blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h)
-        tx  <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) blk & either (const Nothing) Just
+        tx  <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken s) blk & either (const Nothing) Just
 
         case tx of
           Emit box -> do
-            (_, emit) <- MaybeT $ pure $  unboxSignedBox0 @(EmitTx L4Proto) box
+            (_, emit) <- MaybeT $ pure $  unboxSignedBox0 @(EmitTx s) box
-            pure $ toBalance @e emit
+            pure $ toBalance @s emit
 
           Move box -> do
-            (_, move) <- MaybeT $ pure $  unboxSignedBox0 @(MoveTx L4Proto) box
+            (_, move) <- MaybeT $ pure $  unboxSignedBox0 @(MoveTx s) box
-            pure $ toBalance @e move
+            pure $ toBalance @s move
 
       let val = catMaybes r & mconcat & HashMap.fromListWith (+)
 
@@ -450,8 +450,8 @@ balances root = do
 --              -> [(tx, b)]
 --              -> [(tx, b)]
 
-updBalances :: forall e a tx . (ForRefChans e, ToBalance e tx)
+updBalances :: forall e s a tx . (ForRefChans e, ToBalance s tx, s ~ Encryption e)
-            => HashMap (Account e) Amount
+            => HashMap (Account s) Amount
             -> [(a, tx)]
             -> [(a, tx)]
 
@@ -467,7 +467,7 @@ updBalances = go
         go bal rest
 
       where
-        nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @e (snd t)))
+        nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @s (snd t)))
         good = HashMap.filter (<0) nb & HashMap.null
 
 
@@ -515,7 +515,7 @@ runMe conf = withLogging $ flip runReaderT conf do
            ) `orDie` "state-ref not set"
 
   sc <- liftIO $ BS.readFile kr
-  creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
+  creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
 
   chan  <- pure (fromStringMay @(RefChanId L4Proto) chan') `orDie` "invalid REFCHAN"
 
@@ -560,11 +560,11 @@ runMe conf = withLogging $ flip runReaderT conf do
 
   headBlk <- getRefChanHead @L4Proto sto (RefChanHeadKey chan) `orDie` "can't read head block"
 
-  let self = view peerSignPk creds & Actor @L4Proto
+  let self = view peerSignPk creds & Actor
 
   let actors = view refChanHeadAuthors headBlk
                   & HashSet.toList
-                  & fmap (Actor @L4Proto)
+                  & fmap Actor
 
   runApp myEnv do
 
@@ -590,7 +590,7 @@ runMe conf = withLogging $ flip runReaderT conf do
 
                 debug $ "GOT TX" <+> pretty hBin
 
-                tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken L4Proto) bin)
+                tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bin)
 
                 tx <- case tok of
                         (Emit box) -> do
@@ -649,7 +649,7 @@ runMe conf = withLogging $ flip runReaderT conf do
 
       let coco = hashObject @HbSync $ serialise msg
       void $ runMaybeT do
-        (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 @ByteString @UNIX msg
+        (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0  msg
         qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
                                               & either (const Nothing) Just
 
@@ -687,7 +687,7 @@ runMe conf = withLogging $ flip runReaderT conf do
                   Just val -> do
                     pure val
 
-type Config = [Syntax MegaParsec]
+type Config = [Syntax C]
 
 main :: IO ()
 main = join . customExecParser (prefs showHelpOnError) $
@@ -729,11 +729,11 @@ main = join . customExecParser (prefs showHelpOnError) $
       dest <- strArgument ( metavar "ADDRESS" )
       pure $ const $ silently do
         sc <- BS.readFile kr
-        creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
+        creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
         let pk = view peerSignPk creds
         let sk = view peerSignSk creds
         acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
-        tx <- makeEmitTx @L4Proto pk sk acc amnt
+        tx <- makeEmitTx @_ @L4Proto pk sk acc amnt
         LBS.putStr $ serialise tx
 
     pGenMove = do
@@ -742,29 +742,29 @@ main = join . customExecParser (prefs showHelpOnError) $
       dest <- strArgument ( metavar "ADDRESS" )
       pure $ const $ silently do
         sc <- BS.readFile kr
-        creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
+        creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
         let pk = view peerSignPk creds
         let sk = view peerSignSk creds
         acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
-        tx <- makeMoveTx @L4Proto pk sk acc amnt
+        tx <- makeMoveTx @_ @L4Proto pk sk acc amnt
         LBS.putStr $ serialise tx
 
     pCheckTx = do
       kr    <- strOption   ( long "keyring"  <> short 'k' <> help "keyring file" )
       pure $ const do
         sc <- BS.readFile kr
-        creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
+        creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
         let pk = view peerSignPk creds
         let sk = view peerSignSk creds
 
-        tx <- LBS.getContents <&> deserialise @(QBLFDemoToken L4Proto)
+        tx <- LBS.getContents <&> deserialise @(QBLFDemoToken 'HBS2Basic)
 
         case tx of
           Emit box -> do
-            void $ pure (unboxSignedBox0 @(EmitTx L4Proto) @L4Proto box) `orDie` "bad emit tx"
+            void $ pure (unboxSignedBox0 box) `orDie` "bad emit tx"
 
           Move box -> do
-            void $ pure (unboxSignedBox0 @(MoveTx L4Proto) @L4Proto box) `orDie` "bad move tx"
+            void $ pure (unboxSignedBox0 box) `orDie` "bad move tx"
 
         pure ()
 

examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs

@@ -1,4 +1,6 @@
 {-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language TypeOperators #-}
 module Demo.QBLF.Transactions where
 
 import HBS2.Prelude.Plated
@@ -16,17 +18,17 @@ import Data.ByteString.Lazy (ByteString)
 import Data.Word (Word64)
 import System.Random
 
-newtype Actor e =
+newtype Actor s =
-  Actor { fromActor :: PubKey 'Sign (Encryption e) }
+  Actor { fromActor :: PubKey 'Sign s }
   deriving stock (Generic)
 
-deriving stock instance Eq (PubKey 'Sign (Encryption e)) => Eq (Actor e)
+deriving stock instance Eq (PubKey 'Sign s) => Eq (Actor s)
-deriving newtype instance Hashable (PubKey 'Sign (Encryption e)) => Hashable (Actor e)
+deriving newtype instance Hashable (PubKey 'Sign s) => Hashable (Actor s)
 
-instance Pretty (AsBase58 (PubKey 'Sign (Encryption e))) => Pretty (Actor e) where
+instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (Actor s) where
   pretty (Actor a) = pretty (AsBase58 a)
 
-type Account e = PubKey 'Sign (Encryption e)
+type Account s = PubKey 'Sign s
 
 newtype Amount = Amount Integer
                 deriving stock (Eq,Show,Ord,Data,Generic)
@@ -39,48 +41,48 @@ newtype DAppState = DAppState { fromDAppState :: HashRef }
 instance Hashed HbSync DAppState where
   hashObject (DAppState (HashRef h)) = h
 
-data EmitTx e = EmitTx (Account e) Amount Word64
+data EmitTx s = EmitTx (Account s) Amount Word64
                 deriving stock (Generic)
 
-data MoveTx e = MoveTx (Account e) (Account e) Amount Word64
+data MoveTx s = MoveTx (Account s) (Account s) Amount Word64
                 deriving stock (Generic)
 
-data QBLFDemoToken e =
+data QBLFDemoToken s =
-    Emit (SignedBox (EmitTx e) e)  --  proof: owner's  key
+    Emit (SignedBox (EmitTx s) s)  --  proof: owner's  key
-  | Move (SignedBox (MoveTx e) e)  --  proof: wallet's key
+  | Move (SignedBox (MoveTx s) s)  --  proof: wallet's key
   deriving stock (Generic)
 
-instance ForRefChans e => Serialise (Actor e)
+instance ForQBLFDemoToken s => Serialise (Actor s)
 
 instance Serialise DAppState
 
 instance Serialise Amount
 
-instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (EmitTx e)
+instance ForQBLFDemoToken s => Serialise (EmitTx s)
 
-instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (MoveTx e)
+instance ForQBLFDemoToken s => Serialise (MoveTx s)
 
-instance (Serialise (Account e), ForRefChans e) => Serialise (QBLFDemoToken e)
+instance ForQBLFDemoToken s => Serialise (QBLFDemoToken s)
 
-type ForQBLFDemoToken e = ( Eq (PubKey 'Sign (Encryption e))
+type ForQBLFDemoToken s = ( Eq (PubKey 'Sign s)
-                          , Eq (Signature (Encryption e))
+                          , Eq (Signature s)
-                          , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
+                          , Pretty (AsBase58 (PubKey 'Sign s))
-                          , ForSignedBox e
+                          , ForSignedBox s
-                          , FromStringMaybe (PubKey 'Sign (Encryption e))
+                          , FromStringMaybe (PubKey 'Sign s)
-                          , Serialise (PubKey 'Sign (Encryption e))
+                          , Serialise (PubKey 'Sign s)
-                          , Serialise (Signature (Encryption e))
+                          , Serialise (Signature s)
-                          , Hashable (PubKey 'Sign (Encryption e))
+                          , Hashable (PubKey 'Sign s)
                           )
 
-deriving stock instance (ForQBLFDemoToken e) => Eq (QBLFDemoToken e)
+deriving stock instance (ForQBLFDemoToken s) => Eq (QBLFDemoToken s)
 
-instance ForQBLFDemoToken e => Hashable (QBLFDemoToken e) where
+instance ForQBLFDemoToken s => Hashable (QBLFDemoToken s) where
   hashWithSalt salt = \case
     Emit box  -> hashWithSalt salt box
     Move box  -> hashWithSalt salt box
 
 newtype QBLFDemoTran e =
-  QBLFDemoTran (SignedBox (QBLFDemoToken e) e)
+  QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e))
   deriving stock Generic
 
 instance ForRefChans e => Serialise (QBLFDemoTran e)
@@ -93,39 +95,43 @@ deriving newtype instance
   (Eq (Signature (Encryption e)), ForRefChans e)
     => Hashable (QBLFDemoTran e)
 
-instance Serialise (QBLFDemoTran UNIX) => HasProtocol UNIX (QBLFDemoTran UNIX) where
+instance HasProtocol UNIX (QBLFDemoTran UNIX) where
   type instance ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
   type instance Encoded UNIX = ByteString
   decode = either (const Nothing) Just . deserialiseOrFail
   encode = serialise
 
-makeEmitTx :: forall e m . ( MonadIO m
+makeEmitTx :: forall s e m . ( MonadIO m
-                           , ForRefChans e
+                             , ForRefChans e
-                           , Signatures (Encryption e)
+                             , ForQBLFDemoToken s
-                           )
+                             , Signatures (Encryption e)
-           => PubKey 'Sign (Encryption e)
+                             , s ~ Encryption e
-           -> PrivKey 'Sign (Encryption e)
+                             )
-           -> Account e
+           => PubKey 'Sign s
+           -> PrivKey 'Sign s
+           -> Account s
            -> Amount
-           -> m (QBLFDemoToken e)
+           -> m (QBLFDemoToken s)
 
 makeEmitTx pk sk acc amount = do
   nonce <- randomIO
-  let box = makeSignedBox @e pk sk (EmitTx @e acc amount nonce)
+  let box = makeSignedBox @s pk sk (EmitTx acc amount nonce)
-  pure (Emit @e box)
+  pure (Emit @s box)
 
-makeMoveTx :: forall e m . ( MonadIO m
+makeMoveTx :: forall s e m . ( MonadIO m
-                           , ForRefChans e
+                             , ForQBLFDemoToken s
-                           , Signatures (Encryption e)
+                             , ForRefChans e
-                           )
+                             , Signatures s
-           => PubKey 'Sign (Encryption e)  -- from pk
+                             , s ~ Encryption e
-           -> PrivKey 'Sign (Encryption e) -- from sk
+                             )
-           -> Account e
+           => PubKey 'Sign s  -- from pk
+           -> PrivKey 'Sign s -- from sk
+           -> Account s
            -> Amount                       -- amount
-           -> m (QBLFDemoToken e)
+           -> m (QBLFDemoToken s)
 
 makeMoveTx pk sk acc amount = do
   nonce <- randomIO
-  let box = makeSignedBox @e pk sk (MoveTx @e pk acc amount nonce)
+  let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce)
-  pure (Move @e box)
+  pure (Move @s box)
 

fixme-new/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2023, 
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of  nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

fixme-new/README.md

@@ -0,0 +1,22 @@
+
+
+## The new glorious fixme
+
+This is a new fixme implementation! It's a re-implementation
+of fixme aiming for using multiple sources for issues, not
+only git repo, and able to share the state via hbs2
+privimites.
+
+It will replace the old good fixme and will reuse all the
+code from there that could be re-used.
+
+It's indendent to be mostly compatible with the old
+fixme, but we will see.
+
+The binary is called fixme-new in order not to be confused
+with old fixme, but it's only for a while.
+
+It will be replaced as soon, as this fixme will be fully
+operational.
+
+

fixme-new/app/FixmeMain.hs

@@ -0,0 +1,72 @@
+module Main where
+
+import Fixme
+import Fixme.Run
+import System.Environment
+
+-- TODO: fixme-new
+--   $author: Dmitry Zuikov <dzuikov@gmail.com>
+--   $milestone: undefined
+--   $priority: ASAP
+--  после майских:
+--  1.  fixme переезжает в дерево hbs2, конкретно в hbs2-git
+
+--  2.  fixme преобразуется в утилиту для генерации отчётов по репозиторию git
+--
+--  3.  fixme генерирует поток фактов про репозиторий git, включая записи todo/fixme
+--
+--  4.  fixme начинает генерировать PR-ы в формате git (у гита есть простенькие пулл-реквесты!)
+--      и умеет постить их куда там их следует постить
+--
+--  5.  fixme получает ограничитель глубины сканирования и фильтр бранчей,
+--      что бы не окочуриваться на больших проектах
+--
+--  6.  fixme генерирует настройки по умолчанию, включая .gitignore
+--
+--  7.  fixme позволяет явно задавать лог изменений статуса, беря его как из
+--      .fixme/log так и откуда скажут
+--
+--  8.  fixme интегрируется в hbs2-git-dashboard
+--
+--  9.  fixme временно получает название fixme2 или nfixme или hfixme (не решил пока),
+--      потом возвращается к старому названию
+--
+--  10. fixme умеет постить записи в своём формате в hbs2 или же умеет любые источники дампить в своём формате так,
+--        что бы hbs2-git мог запостить их в соответствующий рефчан
+--
+--  11. fixme оформляет либу для экстракции фактов из git, которую будет использовать и hbs2-git-dashboard
+--
+--  12. hbs2-git-dashboard понимает и уважает каталог настроек .fixme , а стейт берёт прямо оттуда
+
+--  открытые вопросы:
+
+--  hbs2-git использует fixme или fixme использует hbs2
+
+--  переводить fixme на fuzzy-parse или нет (скорее, да)
+
+--  переводить ли suckless-conf на fuzzy-parse сейчас (или хрен пока с ним)
+
+--  встроить ли jq внутрь или лучше дать доступ к sql запросам по json
+
+main :: IO ()
+main = do
+
+  -- TODO: discover-config
+  --
+  -- TODO: local-config-has-same-name-with-binary
+  --
+  -- TODO: per-user-config-has-same-name-with-binary
+  --
+  -- TODO: per-user-config-added-after-per-project-config
+
+  -- TODO: scan-all-sources
+  --   for-source-from-con
+
+  runFixmeCLI (run =<< liftIO getArgs)
+
+-- FIXME: test-fixme
+--   $workflow: wip
+--   $assigned: voidlizard
+--
+--   Тестовый тикет с параметрами
+

fixme-new/fixme.cabal

@@ -0,0 +1,140 @@
+cabal-version:      3.0
+name:               fixme-new
+version:            0.24.1.2
+synopsis: reimplemented fixme
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+-- copyright:
+category:           System
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common shared-properties
+  ghc-options:
+        -Wall
+        -fno-warn-type-defaults
+        -threaded
+        -rtsopts
+        -O2
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+  default-language: GHC2021
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , RecordWildCards
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+
+
+  build-depends:
+        hbs2-core
+      , hbs2-peer
+      , hbs2-storage-simple
+      , hbs2-keyman
+      , hbs2-git
+      , db-pipe
+      , suckless-conf >= 0.1.2.6
+      , fuzzy-parse
+
+      , aeson
+      , aeson-pretty
+      , attoparsec
+      , atomic-write
+      , bytestring
+      , binary
+      , containers
+      , directory
+      , exceptions
+      , filepath
+      , filepattern
+      , generic-lens
+      , generic-deriving
+      , interpolatedstring-perl6
+      , memory
+      , microlens-platform
+      , mtl
+      , safe
+      , serialise
+      , scientific
+      , streaming
+      , stm
+      , split
+      , text
+      , temporary
+      , time
+      , timeit
+      , transformers
+      , typed-process
+      , unordered-containers
+      , unliftio
+      , unliftio-core
+      , zlib
+      , prettyprinter
+      , prettyprinter-ansi-terminal
+      , random
+      , vector
+      , unix
+
+
+library
+    import:           shared-properties
+
+    exposed-modules:
+      Fixme
+      Fixme.Config
+      Fixme.Run
+      Fixme.Log
+      Fixme.Types
+      Fixme.Prelude
+      Fixme.State
+      Fixme.Scan
+      Fixme.Scan.Git.Local
+
+    build-depends:    base
+                    , base16-bytestring
+                    , binary
+                    , unix
+
+    hs-source-dirs:  lib
+
+
+executable fixme-new
+    import:           shared-properties
+    main-is:          FixmeMain.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base, fixme-new, hbs2-core, hbs2-peer, hbs2-git
+        , binary
+        , vector
+        , optparse-applicative
+
+    hs-source-dirs:   app
+    default-language: GHC2021
+
+

fixme-new/lib/Fixme.hs

@@ -0,0 +1,8 @@
+module Fixme
+  ( module Fixme.Types
+  , module Fixme.Prelude
+  ) where
+
+import Fixme.Prelude
+import Fixme.Types
+

fixme-new/lib/Fixme/Config.hs

@@ -0,0 +1,38 @@
+module Fixme.Config where
+
+import Fixme.Prelude
+import Fixme.Types
+
+import HBS2.System.Dir
+import System.Environment
+import System.Directory
+
+binName :: FixmePerks m => m FilePath
+binName = liftIO getProgName
+
+localConfigDir :: FixmePerks m => m FilePath
+localConfigDir = do
+  p <- pwd
+  b <- binName
+  pure (p </> ("." <> b))
+
+localConfig:: FixmePerks m => m FilePath
+localConfig = localConfigDir <&> (</> "config")
+
+userConfigs :: FixmePerks m => m [FilePath]
+userConfigs= do
+  bin <- binName
+  h <- home
+  xdg <- liftIO (getXdgDirectory XdgConfig bin)
+
+  let conf1 = h </> ("." <> bin)
+  let conf2 = xdg </> "config"
+
+  pure [conf2, conf1]
+
+localDBName :: FilePath
+localDBName = "state.db"
+
+localDBPath :: FixmePerks m => m FilePath
+localDBPath = localConfigDir <&> (</> localDBName)
+

fixme-new/lib/Fixme/Log.hs

@@ -0,0 +1,31 @@
+module Fixme.Log where
+
+import Fixme.Prelude
+import Fixme.Types
+
+import HBS2.Storage.Compact
+
+import Data.Config.Suckless
+
+import Data.ByteString.Lazy qualified as LBS
+import Data.Maybe
+import Data.Either
+
+{- HLINT ignore "Functor law"-}
+
+loadAllEntriesFromLog :: FixmePerks m
+                      => CompactStorage HbSync
+                      -> FixmeM m [Syntax C]
+loadAllEntriesFromLog sto = do
+    ks <- keys sto
+
+    entries <- mapM (get sto) ks
+                <&> catMaybes
+                <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
+                <&> rights
+
+    let top = show $ vcat (fmap pretty entries)
+    let theLog = parseTop top & fromRight mempty
+
+    pure theLog
+

fixme-new/lib/Fixme/Prelude.hs

@@ -0,0 +1,20 @@
+module Fixme.Prelude
+  ( module All
+  , GitHash(..)
+  , GitRef(..)
+  , Serialise(..)
+  , serialise, deserialiseOrFail, deserialise
+  ) where
+
+import HBS2.Prelude.Plated as All
+import HBS2.Hash as All
+import HBS2.Data.Types.Refs as All
+import HBS2.Misc.PrettyStuff as All
+import HBS2.System.Logger.Simple.ANSI as All
+import HBS2.Git.Local (GitHash(..),GitRef(..))
+import Codec.Serialise (Serialise(..),serialise,deserialise,deserialiseOrFail)
+import Data.Functor as All
+import Data.Function as All
+import UnliftIO as All
+import System.FilePattern as All
+import Control.Monad.Reader as All

fixme-new/lib/Fixme/Run.hs

@@ -0,0 +1,827 @@
+{-# Language MultiWayIf #-}
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
+module Fixme.Run 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 Fixme.Log
+
+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)
+
+exportToLog :: FixmePerks m => FilePath -> FixmeM m ()
+exportToLog fn = do
+  e <- getEpoch
+  warn $ red "EXPORT-FIXMIES" <+> pretty fn
+  sto <- compactStorageOpen @HbSync mempty fn
+  fx <- selectFixmeThin ()
+  for_ fx $ \(FixmeThin m) -> void $ runMaybeT do
+    h <- HM.lookup "fixme-hash" m & toMPlus
+    loaded <- lift (selectFixme (coerce h)) >>= toMPlus
+    let what = Added e loaded
+    let k = mkKey what
+    get sto k >>= guard . isNothing
+    put sto (mkKey what) (LBS.toStrict $ serialise what)
+    warn $ red "export" <+> pretty h
+
+  what <- selectStage
+
+  for_ what $ \w -> do
+    let k = mkKey w
+    v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction .  LBS.fromStrict)
+    case v0 of
+      Nothing -> do
+        put sto k (LBS.toStrict $ serialise w)
+
+      Just (Left{}) -> do
+        put sto k (LBS.toStrict $ serialise w)
+
+      Just (Right prev) | getSequence w > getSequence prev -> do
+        put sto k (LBS.toStrict $ serialise w)
+
+      _ -> pure ()
+
+  compactStorageClose sto
+
+  cleanStage
+
+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
+  runForms (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.hs

@@ -0,0 +1,215 @@
+{-# Language MultiWayIf #-}
+module Fixme.Scan (scanBlob,scanMagic) where
+
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Text qualified as Text
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (ignore)
+import Data.Char (isSpace)
+
+import Data.Maybe
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Data.Coerce
+
+import Data.Generics.Product.Fields (field)
+import Lens.Micro.Platform
+import Text.InterpolatedString.Perl6 (qc)
+
+import Streaming.Prelude qualified as S
+
+{- HLINT ignore "Functor law" -}
+
+
+data SfEnv =
+  SfEnv { lno :: Int  -- ^ line number
+        , l0  :: Int  -- ^ fixme indent
+        , eln :: Int  -- ^ empty lines counter
+        }
+        deriving stock Generic
+
+
+succEln :: SfEnv -> ByteString -> SfEnv
+succEln f s | LBS8.null s = over (field @"eln") succ f
+            | otherwise = set (field @"eln") 0 f
+
+data Sx = S0 | Sf SfEnv
+
+data S = S Sx [(Int,ByteString)]
+
+
+data FixmePart = FixmePart Int FixmeWhat
+                 deriving stock (Show,Data,Generic)
+
+data FixmeWhat = FixmeHead Int Int Text Text
+               | FixmeLine Text
+               | FixmeAttr FixmeAttrName FixmeAttrVal
+                 deriving stock (Show,Data,Generic)
+
+data P = P0 [FixmePart] | P1 Int Fixme [FixmePart]
+
+
+scanMagic :: FixmePerks m => FixmeM m HashRef
+scanMagic = do
+  env <- ask
+  w <- atomically do
+         tagz <- fixmeEnvTags env         & readTVar
+         co   <- fixmeEnvDefComments  env & readTVar
+         fco  <- fixmeEnvFileComments env  & readTVar
+         m    <- fixmeEnvFileMask env      & readTVar
+         a    <- fixmeEnvAttribs env       & readTVar
+         v    <- fixmeEnvAttribValues env  & readTVar
+
+         pure $ serialise (tagz, co, fco, m, a, v)
+  pure $ HashRef $ hashObject w
+
+scanBlob :: forall m . FixmePerks m
+         => Maybe FilePath   -- ^ filename to detect type
+         -> ByteString       -- ^ content
+         -> FixmeM m [Fixme]
+
+scanBlob fpath lbs = do
+
+  tagz <- asks fixmeEnvTags
+              >>= readTVarIO
+              <&> HS.toList
+              <&> fmap (Text.unpack . coerce)
+              <&> filter (not . null)
+              <&> fmap LBS8.pack
+
+  comments <- fixmeGetCommentsFor fpath
+                <&> filter (not . LBS8.null) . fmap (LBS8.pack . Text.unpack)
+
+  anames  <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
+
+  let setters = [ ( LBS8.pack [qc|${show $ pretty n}:|], n ) | n <- anames ]
+
+  let ls = LBS8.lines lbs & zip [0..]
+
+  parts <- S.toList_ do
+
+      flip fix (S S0 ls) $ \next -> \case
+        S S0 ((lno,x):xs) -> do
+
+          (l,bs)  <- eatPrefix0 Nothing comments x
+
+          let mtag = headMay [ t | t <- tagz, LBS8.isPrefixOf t bs ]
+
+          case mtag of
+            Nothing ->
+              next (S S0 xs)
+
+            Just tag -> do
+              emitFixmeStart lno l tag (LBS8.drop (LBS8.length tag) bs)
+              next (S (Sf (SfEnv lno l 0)) xs)
+
+        S sf@(Sf env@(SfEnv{..})) (x : xs) -> do
+
+          (li,bs)  <- eatPrefix0 (Just l0) comments (snd x)
+
+          if | eln > 1 -> next (S S0 (x:xs))
+
+             | li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs))
+
+             | otherwise -> do
+
+                let stripped = LBS8.dropWhile isSpace bs
+                let attr = headMay [ (s, LBS8.drop (LBS8.length a) stripped)
+                                   | (a,s) <- setters, LBS8.isPrefixOf a stripped
+                                   ]
+
+                case attr of
+                  Just (a,v) -> do
+                    let vv = LBS8.toStrict v & decodeUtf8With ignore & Text.strip
+                    emitFixmeAttr (fst x) l0 a (FixmeAttrVal vv)
+                  Nothing -> do
+                    emitFixmeLine (fst x) l0 bs
+
+                next (S (Sf (succEln env bs)) xs)
+
+        S _ [] -> pure ()
+  -- debug $ vcat (fmap viaShow parts)
+
+  S.toList_ do
+    flip fix (P0 parts) $ \next -> \case
+
+        (P0 (FixmePart l h@FixmeHead{} : rs)) -> do
+          next (P1 l (fromHead h) rs)
+
+        (P1 _ fx (FixmePart l h@FixmeHead{} : rs)) -> do
+          emitFixme fx
+          next (P1 l (fromHead h) rs)
+
+        (P1 _ fx (FixmePart lno (FixmeLine what) : rs)) -> do
+          next (P1 lno (setLno lno $ over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs)
+
+        (P1 _ fx (FixmePart lno (FixmeAttr a v) : rs)) -> do
+          next (P1 lno (setLno lno $ over (field @"fixmeAttr") (<> HM.singleton a v) fx) rs)
+
+        (P1 _ fx []) -> emitFixme fx
+        (P0 ( _ : rs ) ) -> next (P0 rs)
+        (P0 []) -> pure ()
+
+  where
+
+    setLno lno fx@Fixme{} = do
+      let lno1 = Just (FixmeOffset (fromIntegral lno))
+      set (field @"fixmeEnd") lno1 fx
+
+    emitFixme e = do
+      S.yield $ over (field @"fixmePlain") dropEmpty e
+      where
+        dropEmpty = dropWhile $ \case
+          FixmePlainLine "" -> True
+          _                 -> False
+
+    -- FIXME: jopakita
+    fromHead = \case
+      FixmeHead lno  _ tag title ->
+          Fixme (FixmeTag tag)
+                (FixmeTitle title)
+                Nothing
+                Nothing
+                (Just (FixmeOffset (fromIntegral lno)))
+                Nothing
+                mempty
+                mempty
+
+      _ -> mempty
+
+    emitFixmeStart lno lvl tagbs restbs = do
+      let tag  = decodeUtf8With ignore  (LBS8.toStrict tagbs) & Text.strip
+      let rest = decodeUtf8With ignore  (LBS8.toStrict restbs) & Text.strip
+      S.yield (FixmePart lno (FixmeHead lno lvl tag rest))
+
+    emitFixmeAttr lno _ name val = do
+      S.yield (FixmePart lno (FixmeAttr name val))
+
+    emitFixmeLine lno _ restbs = do
+      let rest = decodeUtf8With ignore  (LBS8.toStrict restbs) & Text.stripEnd
+      S.yield (FixmePart lno (FixmeLine rest))
+
+    eatPrefix0 lim' comments x = do
+      over _2 LBS8.pack <$> do
+
+        flip fix (0, LBS8.unpack x) $ \next w@(k, left) -> do
+
+          let lim = fromMaybe (succ k) lim'
+
+          if k > lim then
+            pure (k, left)
+          else
+            case w of
+              (n, ' '  : rest) -> next (n+1, if k == lim then ' ' : rest else rest)
+              (n, '\t' : rest) -> next (n+8, if k == lim then '\t' : rest else rest)
+
+              (n, rest) -> do
+                let comm = headMay [ co | co <- comments, LBS8.isPrefixOf co (LBS8.pack rest) ]
+                case comm of
+                  Nothing -> pure (n, rest)
+                  Just co -> next (n+1, drop (fromIntegral $ LBS8.length co) rest)
+

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

@@ -0,0 +1,619 @@
+{-# Language MultiWayIf #-}
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
+module Fixme.Scan.Git.Local where
+
+
+import Prelude hiding (init)
+import Fixme.Prelude hiding (indent)
+import Fixme.Types
+import Fixme.State
+import Fixme.Scan as Scan
+import Fixme.Log
+
+import HBS2.Storage
+import HBS2.Storage.Compact
+import HBS2.System.Dir
+import HBS2.Git.Local.CLI
+
+import DBPipe.SQLite hiding (field)
+import Data.Config.Suckless
+import Data.Text.Fuzzy.Tokenize
+
+import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy (ByteString)
+import Data.Either
+import Data.Fixed
+import Data.List qualified as List
+import Data.List.Split (chunksOf)
+import Data.Maybe
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.HashSet (HashSet)
+import Data.Text qualified as Text
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (ignore)
+import Data.Word
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Coerce
+import Data.Generics.Product.Fields (field)
+import Lens.Micro.Platform
+import System.Process.Typed
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import System.IO qualified as IO
+import System.IO.Temp (emptySystemTempFile)
+import System.TimeIt
+
+import Data.Map qualified as Map
+
+import Streaming.Prelude qualified as S
+
+data ScanGitArgs =
+    PrintBlobs
+  | PrintFixme
+  | ScanRunDry
+  | ScanAllCommits
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+pattern ScanGitArgs :: forall {c} . ScanGitArgs -> Syntax c
+pattern ScanGitArgs w <- ( scanGitArg -> Just w )
+
+scanGitArg :: Syntax c -> Maybe ScanGitArgs
+scanGitArg = \case
+  SymbolVal "print-blobs" -> Just PrintBlobs
+  SymbolVal "print-fixme" -> Just PrintFixme
+  SymbolVal "dry"         -> Just ScanRunDry
+  SymbolVal "all-commits" -> Just ScanAllCommits
+  _ -> Nothing
+
+
+{- HLINT ignore "Functor law" -}
+
+
+listCommits :: FixmePerks m => FixmeM m [(GitHash, HashMap FixmeAttrName FixmeAttrVal)]
+listCommits = do
+  gd <- fixmeGetGitDirCLIOpt
+
+  days <- asks fixmeEnvGitScanDays
+            >>= readTVarIO
+            <&> fmap ( \x -> "--since" <+> squotes (pretty x <+> "days ago"))
+            <&> fromMaybe mempty
+            <&> show
+
+  let cmd = [qc|git {gd} log --all --format="%H '%cn' '%ce' %ct" {days}|]
+
+  debug $ yellow "listCommits" <+> pretty cmd
+
+  gitRunCommand cmd
+    <&> fromRight mempty
+    <&> LBS8.lines
+    <&> mapMaybe extract
+
+  where
+    extract :: ByteString -> Maybe (GitHash, HashMap FixmeAttrName FixmeAttrVal)
+    extract lbs = do
+      let txt = decodeUtf8With ignore (LBS8.toStrict lbs)
+      let r = tokenize @Text spec txt
+      case r of
+        [co, n, e, t] -> do
+          let gh = fromStringMay @GitHash (Text.unpack co)
+
+          let bag = [ ("commit", co)
+                    , ("commit-time", t)
+                    , ("committer-name", n)
+                    , ("committer-email", e)
+                    , ("committer", [qc|{n} <{e}>|])
+                    ] & fmap ( over _1 FixmeAttrName . over _2 FixmeAttrVal)
+                      & HM.fromList
+
+          (,) <$> gh <*> pure bag
+
+        _ -> Nothing
+
+    spec = sq <> delims " \t"
+
+
+listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)]
+listRefs every = do
+  gd <- fixmeGetGitDirCLIOpt
+  gitRunCommand [qc|git {gd} show-ref --dereference|]
+    <&> fromRight mempty
+    <&> fmap LBS8.words . LBS8.lines
+    <&> mapMaybe
+          (\case
+             [h,b] -> (,) <$> fromStringMay @GitHash (LBS8.unpack h) <*> pure (GitRef (LBS8.toStrict b))
+             _     -> Nothing
+          )
+    >>= filterM filt
+
+  where
+    filt _ | every = pure True
+
+    filt (h,_) = do
+      done <- withState $ isProcessed $ ViaSerialise h
+      pure (not done)
+
+listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m [(FilePath,GitHash)]
+listBlobs co = do
+  gd <- fixmeGetGitDirCLIOpt
+  gitRunCommand [qc|git {gd} ls-tree -r -l -t {pretty co}|]
+    <&> fromRight mempty
+    <&> fmap LBS8.words . LBS8.lines
+    <&> mapMaybe
+          (\case
+             [a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h)
+             _                 -> Nothing)
+
+filterBlobs0 :: FixmePerks m
+            => [(Bool,FilePattern)]
+            -> [(FilePath,GitHash)]
+            -> FixmeM m [(FilePath,GitHash)]
+
+filterBlobs0 pat xs = do
+  -- pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
+  let src = [ ((f,h),f) | (f,h) <- xs ]
+  let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList
+  pure $ [ (b,a) | (a,b) <- r ]
+
+filterBlobs :: FixmePerks m
+            => [(FilePath,GitHash)]
+            -> FixmeM m [(FilePath,GitHash)]
+
+filterBlobs xs = do
+  pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
+  filterBlobs0 pat xs
+
+
+scanGitLogLocal :: FixmePerks m
+                => FilePath
+                -> ( CompactStorage HbSync -> FixmeM m () )
+                -> FixmeM m ()
+scanGitLogLocal refMask play = do
+  warn $ red "scanGitLogLocal" <+> pretty refMask
+
+  (t,refs) <- timeItT $ listRefs False
+
+  let hashes = fmap fst refs
+
+  warn $ yellow "listRefs in" <+> pretty (realToFrac t :: Fixed E6)
+
+  let pat = [(True, refMask)]
+
+  -- FIXME: use-cache-to-skip-already-processed-tips
+  logz <- withState do
+      S.toList_ $ for_ hashes $ \h -> do
+          done <- lift $ isProcessed (ViaSerialise h)
+          unless done do
+            blobs <- lift $ lift $ (listBlobs h >>= filterBlobs0 pat)
+            when (List.null blobs) do
+              lift $ insertProcessed (ViaSerialise h)
+            for_ blobs $ \(_,b) -> do
+              S.yield (h,b)
+
+  warn $ yellow "STEP 3" <+> "for each tree   --- find log"
+
+  warn $ vcat (fmap pretty logz)
+
+  warn $ yellow "STEP 4" <+> "for each log    --- scan log"
+
+  withState $ transactional do
+
+    flip runContT pure do
+      for_ logz $ \(commitHash, h) -> callCC \shit -> do
+          warn $ blue "SCAN BLOB" <+> pretty h
+          tmp <- ContT $ bracket (liftIO (emptySystemTempFile "fixme-log")) rm
+          blob <- lift $ lift $ gitCatBlob h
+          liftIO (LBS8.writeFile tmp blob)
+
+          esto <- lift $ try @_ @CompactStorageOpenError $ compactStorageOpen @HbSync readonly tmp
+
+          -- skip even problematic commit
+          lift $ insertProcessed (ViaSerialise commitHash)
+
+          either (const $ warn $ "skip malformed/unknown log" <+> pretty h) (const none) esto
+          sto <- either (const $ shit ()) pure esto
+
+          lift $ lift $ play sto
+
+          compactStorageClose sto
+
+scanGitLocal :: FixmePerks m
+             => [ScanGitArgs]
+             -> Maybe FilePath
+             -> FixmeM m ()
+scanGitLocal args p =  do
+
+  env <- ask
+
+  flip runContT pure do
+
+    (dbFn, _) <- ContT $ withSystemTempFile "fixme-db" . curry
+
+    tempDb <- newDBPipeEnv dbPipeOptsDef dbFn
+
+    withDB tempDb do
+      ddl [qc| create table co
+               ( cohash text not null
+               , ts   int null
+               , primary key (cohash)
+               )
+             |]
+
+      ddl [qc| create table coattr
+               ( cohash text not null
+               , name   text not null
+               , value  text not null
+               , primary key (cohash,name)
+               )
+             |]
+
+      ddl [qc| create table blob
+               ( hash   text not null
+               , cohash text not null
+               , path   text not null
+               , primary key (hash,cohash,path)
+               )
+             |]
+
+      -- update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|]
+
+    let onlyNewCommits xs
+            | ScanAllCommits `elem` args = pure xs
+            | otherwise = lift $ filterM (newCommit . view _1) xs
+
+    co <- lift listCommits >>= onlyNewCommits
+
+    lift do
+      withDB tempDb $ transactional do
+        for_ co $ \(commit, attr) -> do
+
+          debug $ "commit" <+> pretty commit
+
+          blobs <- lift $ listBlobs commit >>= withFixmeEnv env . filterBlobs
+
+          let ts = HM.lookup "commit-time" attr
+                     >>= readMay @Word64 . Text.unpack . coerce
+
+          insert [qc|
+              insert into co (cohash,ts) values (?,?) on conflict (cohash) do nothing
+              |] (commit,ts)
+
+          for_ (HM.toList attr) $ \(a,b) -> do
+            insert [qc|
+                insert into coattr(cohash,name,value) values(?,?,?)
+                on conflict (cohash,name) do nothing
+                |] (commit,a,b)
+
+          for_ blobs $ \(fp,h) -> do
+            insert [qc| insert into blob (hash,cohash,path)
+                        values (?,?,?)
+                        on conflict (hash,cohash,path) do nothing
+                      |] (h,commit,fp)
+
+
+    blobs <- withDB tempDb  do
+                select_ @_ @(GitHash, FilePath) [qc|select distinct hash, path from blob order by path|]
+
+    when ( PrintBlobs `elem` args ) do
+        for_ blobs $ \(h,fp) -> do
+          notice $ pretty h <+> pretty fp
+
+    callCC \fucked -> do
+
+      gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
+
+      let ssin   = getStdin gitCat
+      let ssout  = getStdout gitCat
+
+      liftIO $ IO.hSetBuffering ssin LineBuffering
+
+      for_ blobs $ \(h,fp) ->  callCC \next -> do
+
+        seen <-  lift (withState $ selectObjectHash h) <&> isJust
+
+        when seen do
+          trace $ red "ALREADY SEEN BLOB" <+> pretty h
+          next ()
+
+        liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
+        prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
+
+        case prefix of
+          [bh, "blob", ssize] -> do
+            let mslen = readMay @Int (BS.unpack ssize)
+            len <- ContT $ maybe1 mslen (pure ())
+            blob <- liftIO $ LBS8.hGet ssout len
+            void $ liftIO $ BS.hGetLine ssout
+
+
+            poor <- lift (Scan.scanBlob (Just fp) blob)
+
+            rich <- withDB tempDb do
+                      let q = [qc|
+
+            WITH CommitAttributes AS (
+              SELECT co.cohash, co.ts, coattr.name, coattr.value
+              FROM co
+              JOIN coattr ON co.cohash = coattr.cohash
+            ),
+            MinCommitTimes AS (
+              SELECT blob.hash, MIN(co.ts) as mintime
+              FROM blob
+              JOIN co ON blob.cohash = co.cohash
+              WHERE co.ts IS NOT NULL
+              GROUP BY blob.hash
+            ),
+            RelevantCommits AS (
+              SELECT blob.hash, blob.cohash, blob.path
+              FROM blob
+              JOIN MinCommitTimes ON blob.hash = MinCommitTimes.hash
+              JOIN co ON blob.cohash = co.cohash AND co.ts = MinCommitTimes.mintime
+            )
+            SELECT CommitAttributes.name, CommitAttributes.value
+            FROM RelevantCommits
+            JOIN CommitAttributes ON RelevantCommits.cohash = CommitAttributes.cohash
+            WHERE RelevantCommits.hash = ?
+                      |]
+
+                      what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h)
+                                <&> HM.fromList
+                                <&> (<> HM.fromList [ ("blob",fromString $ show (pretty h))
+                                                    , ("file",fromString fp)
+                                                    ])
+
+                      for poor $ \f -> do
+                        let lno = maybe mempty ( HM.singleton "line"
+                                               . FixmeAttrVal
+                                               . Text.pack
+                                               . show
+                                               )
+                                       (fixmeStart f)
+
+                        let ts = HM.lookup "commit-time" what
+                                  <&> Text.unpack . coerce
+                                  >>= readMay
+                                  <&> FixmeTimestamp
+
+                        pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> (what <> lno)) f
+
+
+            let fxpos1 = [ (fixmeTitle fx, [i :: Int])
+                         | (i,fx) <- zip [0..] rich
+                         -- , fixmeTitle fx /= mempty
+                         ] & Map.fromListWith (flip (<>))
+
+            let mt e = do
+                  let seed = [ (fst e, i) | i <- snd e ]
+                  flip fix (0,[],seed) $ \next (num,acc,rest) ->
+                    case rest of
+                      [] -> acc
+                      (x:xs) -> next (succ num, (x,num) : acc, xs)
+
+            let fxpos2 = [ mt e
+                         | e <- Map.toList fxpos1
+                         ] & mconcat
+                           & Map.fromList
+
+            fixmies <- for (zip [0..] rich) $ \(i,fx) -> do
+                         let title = fixmeTitle fx
+                         let kb = Map.lookup (title,i) fxpos2
+                         let ka = HM.lookup "file" (fixmeAttr fx)
+                         let kk = (,,) <$> ka <*> pure title <*> kb
+
+                         case kk of
+                          Nothing -> pure fx
+                          Just (a,b,c) -> do
+                            let ks = [qc|{show (pretty a)}#{show (pretty b)}:{show c}|] :: 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 $ over (field @"fixmeAttr") (<> kv) fx
+
+            when ( PrintFixme `elem` args ) do
+              for_ fixmies $ \fixme -> do
+                notice $ pretty fixme
+
+            when ( ScanRunDry `elem` args ) $ fucked ()
+
+            debug $ "actually-import-fixmies" <+> pretty h
+
+            liftIO $ withFixmeEnv env $ withState $ transactional do
+              insertBlob h
+              for_ fixmies insertFixme
+
+          _ -> fucked ()
+
+      unless ( ScanRunDry `elem` args ) do
+        lift runLogActions
+
+      liftIO $ withFixmeEnv env $ withState $ transactional do
+        for_ co $ \w -> do
+          insertCommit (view _1 w)
+
+
+gitListStage :: (FixmePerks m)
+             => FixmeM m [Either (FilePath, GitHash) (FilePath, GitHash)]
+gitListStage = do
+  gd <- fixmeGetGitDirCLIOpt
+  modified <- gitRunCommand [qc|git {gd} status --porcelain|]
+                <&> fromRight mempty
+                <&> fmap LBS8.words . LBS8.lines
+                <&> mapMaybe ( \case
+                       ["M", fn] -> Just (LBS8.unpack fn)
+                       _         -> Nothing
+                    )
+
+  new <- S.toList_ $ do
+            for_ modified $ \fn -> void $ runMaybeT do
+
+              e <- gitRunCommand [qc|git {gd} hash-object {fn}|]
+                     >>= toMPlus
+                     <&> maybe mempty LBS8.unpack . headMay . LBS8.words
+                     <&> fromStringMay @GitHash
+                     >>= toMPlus
+
+              lift (S.yield $ (fn,e))
+
+  old <- gitRunCommand [qc|git {gd} ls-files -s|]
+          <&> fromRight mempty
+          <&> fmap LBS8.words . LBS8.lines
+          <&> mapMaybe ( \case
+                [_, h, _, fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h)
+                _             -> Nothing
+                )
+
+  new1 <- filterBlobs new <&> fmap Left
+  old1 <- filterBlobs old <&> fmap Right
+
+  pure (old1 <> new1)
+
+
+getMetaDataFromGitBlame :: FixmePerks m => FilePath -> Fixme -> FixmeM m Fixme
+getMetaDataFromGitBlame f fx0 = do
+  gd <- fixmeGetGitDirCLIOpt
+  fromMaybe mempty <$> runMaybeT do
+    l0 <- fixmeStart fx0 & toMPlus <&> fromIntegral <&> succ
+    let cmd = [qc|git {gd} blame {f} -L{l0},{l0} -t -l -p|]
+
+    s0 <- gitRunCommand cmd
+             <&> LBS8.unpack . fromRight mempty
+
+    s <- parseTop s0 & toMPlus
+
+    let ko = headMay (words <$> lines s0)
+                   >>= headMay
+                   >>= (\z -> do
+                         if z == "0000000000000000000000000000000000000000"
+                           then Nothing
+                           else Just z )
+                   >>= fromStringMay @GitHash
+
+    pieces <- for s $ \case
+      ListVal (SymbolVal "committer" : StringLikeList  w) | isJust ko -> do
+        let co = FixmeAttrVal $ fromString $ unwords w
+        pure $ mempty { fixmeAttr = HM.singleton "committer-name" co }
+
+      ListVal (SymbolVal "committer-mail" : StringLikeList  w) | isJust ko -> do
+        let co = FixmeAttrVal $ fromString $ unwords w
+        pure $ mempty { fixmeAttr = HM.singleton "committer-email" co }
+
+      ListVal [SymbolVal "committer-time", TimeStampLike t] | isJust ko  -> do
+        let ct = FixmeAttrVal $ fromString $ show t
+        pure $ mempty { fixmeAttr = HM.singleton "commit-time" ct, fixmeTs = Just t }
+
+      _ -> pure mempty
+
+    let coco = mempty { fixmeAttr = maybe mempty (HM.singleton "commit" . fromString . show . pretty) ko }
+
+    pure $ mconcat pieces <> coco
+
+gitExtractFileMetaData :: FixmePerks m => [FilePath] -> FixmeM m (HashMap FilePath Fixme)
+gitExtractFileMetaData fns = do
+  -- FIXME: magic-number
+  let chunks = chunksOf 64 fns
+
+  gd <- fixmeGetGitDirCLIOpt
+
+  commitz <- S.toList_ $ for_ chunks $ \chu -> do
+      let filez = unwords chu
+      let cmd = [qc|git {gd} log --diff-filter=AMR --pretty=format:'entry %H %at "%an" "%ae"' -- {filez}|]
+      ss <- gitRunCommand cmd
+             <&> fromRight mempty
+             <&> fmap LBS8.unpack . LBS8.lines
+
+      for_ ss $ \s -> do
+        let syn = parseTop s & fromRight mempty
+        case syn of
+          [ListVal [SymbolVal "entry", SymbolVal (Id e), LitIntVal t, StringLike n, StringLike m]] -> do
+            -- liftIO $ print $ pretty e <+> pretty syn
+            S.yield (fromString @GitHash (Text.unpack e), (t,n,m) )
+
+          _ -> pure ()
+
+  let co = HM.fromList commitz
+             & HM.toList
+
+  rich0 <- S.toList_ $ do
+    for_ co $ \(c, (t,n,m)) -> do
+      let pat = [ (True, f) | f <- fns ]
+      blobz <- lift $ listBlobs c >>= filterBlobs0 pat
+
+      for_ blobz $ \(f,h) -> do
+        let attr = HM.fromList [ ("commit",          FixmeAttrVal (fromString $ show $ pretty c))
+                               , ("commit-time",     FixmeAttrVal (fromString $ show $ pretty t))
+                               , ("committer-name",  FixmeAttrVal (fromString n))
+                               , ("committer-email", FixmeAttrVal (fromString m))
+                               , ("committer",       FixmeAttrVal (fromString $ [qc|{n} <{m}>|]))
+                               , ("file",            FixmeAttrVal (fromString f))
+                               , ("blob",            FixmeAttrVal (fromString $ show $ pretty $ h))
+                               ]
+        let what = mempty { fixmeAttr = attr }
+        S.yield (f,t,what)
+
+  let rich = List.sortBy (\a b -> compare (view _2 a) (view _2 b)) rich0
+
+  pure $ HM.fromList [ (view _1 w, view _3 w) | w <- rich ]
+
+-- TODO: move-outta-here
+runLogActions :: FixmePerks m => FixmeM m ()
+runLogActions = do
+  debug $ yellow "runLogActions"
+  actions <- asks fixmeEnvReadLogActions >>= readTVarIO
+
+  for_ actions $ \(ReadLogAction a) -> do
+    liftIO (a (List noContext []))
+
+  updateIndexes
+
+data GitBlobInfo = GitBlobInfo FilePath GitHash
+                   deriving stock (Eq,Ord,Data,Generic,Show)
+
+instance Hashable GitBlobInfo
+
+data GitIndexEntry =
+       GitCommit Word64 (HashSet GitBlobInfo)
+       deriving stock (Eq,Ord,Data,Generic,Show)
+
+instance Serialise GitBlobInfo
+instance Serialise GitIndexEntry
+
+listCommitForIndex :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => ( (GitHash, GitIndexEntry) -> m ()) -> m ()
+listCommitForIndex fn = do
+
+  gd <- fixmeGetGitDirCLIOpt
+  let cmd = [qc|git {gd} log --all --format="%H %ct"|]
+
+  debug $ yellow "listCommits" <+> pretty cmd
+
+  s0 <- gitRunCommand cmd
+    <&> fromRight mempty
+    <&> fmap (words . LBS8.unpack) . LBS8.lines
+    <&> mapMaybe ( \case
+         [a,b] -> (,) <$> fromStringMay @GitHash a <*> makeIndexEntry0 a b
+         _     -> Nothing
+         )
+
+  for_ s0 $ \(h, GitCommit w _) -> do
+    blobz <- listBlobs h <&> HS.fromList . fmap ( uncurry GitBlobInfo  )
+    fn (h, GitCommit w blobz)
+
+  where
+    makeIndexEntry0 _ t = GitCommit <$> readMay t <*> pure mempty
+
+gitCatBlob :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m ByteString
+gitCatBlob h = do
+  gd <- fixmeGetGitDirCLIOpt
+  (_,s,_)  <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|]
+  pure s
+
+startGitCatFile ::  (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())
+startGitCatFile = do
+  gd <- fixmeGetGitDirCLIOpt
+  let cmd = [qc|git {gd} cat-file --batch|]
+  debug $ pretty cmd
+  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd
+  startProcess config
+

fixme-new/lib/Fixme/State.hs

@@ -0,0 +1,707 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Fixme.State
+  ( evolve
+  , withState
+  , insertFixme
+  , selectFixmeThin
+  , selectFixmeHash
+  , selectFixmeHashes
+  , selectFixme
+  , deleteFixme
+  , updateFixme
+  , insertCommit
+  , insertBlob
+  , selectObjectHash
+  , newCommit
+  , cleanupDatabase
+  , updateIndexes
+  , insertFixmeDelStaged
+  , insertFixmeModStaged
+  , selectStageModified
+  , selectStageDeleted
+  , selectStage
+  , cleanStage
+  , insertProcessed
+  , isProcessed
+  , selectProcessed
+  , checkFixmeExists
+  , listAllFixmeHashes
+  , HasPredicate(..)
+  , SelectPredicate(..)
+  ) where
+
+import Fixme.Prelude
+import Fixme.Types
+import Fixme.Config
+
+import HBS2.System.Dir
+import Data.Config.Suckless
+import Data.Config.Suckless.Syntax
+import DBPipe.SQLite hiding (field)
+
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Aeson as Aeson
+import Data.HashMap.Strict qualified as HM
+import Text.InterpolatedString.Perl6 (q,qc)
+import Data.Text qualified as Text
+import Data.Maybe
+import Data.List qualified as List
+import Data.Either
+import Data.List (sortBy,sortOn)
+import Data.Ord
+import Lens.Micro.Platform
+import Data.Generics.Product.Fields (field)
+import Control.Monad.Trans.Maybe
+import Data.Coerce
+import Data.Fixed
+import Data.Word (Word64)
+import System.TimeIt
+
+-- TODO: runPipe-omitted
+--   runPipe нигде не запускается, значит, все изменения
+--   будут закоммичены в БД только по явному вызову
+--   commitAll или transactional
+--   это может объясняеть некоторые артефакты.
+--   Но это и удобно: кажется, что можно менять БД
+--   на лету бесплатно
+
+
+pattern Operand :: forall {c} . Text -> Syntax c
+pattern Operand what <- (operand -> Just what)
+
+pattern BinOp :: forall {c} . Id -> Syntax c
+pattern BinOp what <- (binOp -> Just what)
+
+binOp :: Syntax c -> Maybe Id
+binOp = \case
+  SymbolVal "~"  -> Just "like"
+  SymbolVal "&&" -> Just "and"
+  SymbolVal "||" -> Just "or"
+  _              -> Nothing
+
+operand :: Syntax c -> Maybe Text
+operand = \case
+  SymbolVal c -> Just (coerce c)
+  LitStrVal s -> Just s
+  LitIntVal i -> Just (Text.pack (show i))
+  LitScientificVal v -> Just (Text.pack (show v))
+  _ -> Nothing
+
+
+instance ToField HashRef where
+  toField x = toField $ show $ pretty x
+
+instance FromField HashRef where
+  fromField = fmap (fromString @HashRef) . fromField @String
+
+evolve :: FixmePerks m => FixmeM  m ()
+evolve = 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
+              newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path)
+              case newDb of
+                Left e   -> pure (Left e)
+                Right db -> do
+                  debug "set-new-db"
+                  atomically $ writeTVar t (Just db)
+                  pure $ Right db
+
+  either throwIO (`withDB` what) db
+
+createTables :: FixmePerks m => DBPipeM m ()
+createTables = do
+
+  -- тут все таблицы будут называться с префиксом
+  -- fixme, что бы может быть можно было встроить
+  -- в другую бд, если вдруг понадобится
+
+  ddl [qc|
+        create table if not exists fixmegitobject
+          ( hash text not null
+          , type text null
+          , primary key (hash)
+          )
+      |]
+
+  ddl [qc|
+        create table if not exists fixme
+          ( id    text not null
+          , ts    integer
+          , fixme blob not null
+          , primary key (id)
+          )
+      |]
+
+  ddl [qc|
+        create table if not exists fixmedeleted
+          ( id      text not null
+          , ts      integer not null
+          , deleted bool not null
+          , primary key (id,ts)
+          )
+      |]
+
+  ddl [qc|
+        create table if not exists fixmerel
+          ( origin  text not null
+          , related text not null
+          , ts      integer not null
+          , reason  text not null
+          , primary key (origin,related,ts)
+          )
+      |]
+
+  ddl [qc|
+        create table if not exists fixmeattr
+          ( fixme   text not null
+          , ts      integer null
+          , name    text not null
+          , value   text
+          , primary key (fixme,ts,name)
+          )
+      |]
+
+  ddl [qc| drop view if exists fixmeattrview |]
+
+  let commits = [qc|name in ('commit','committer','committer-name','committer-email','commit-time')|] :: Text
+
+  ddl [qc|
+    create view fixmeattrview as
+      with ranked1 as (
+        select
+          fixme,
+          name,
+          value,
+          row_number() over (partition by fixme, name order by ts desc nulls first) as rn
+        from fixmeattr
+        where not ({commits})
+      )
+      , ranked2 as (
+        select
+          fixme,
+          name,
+          value,
+          row_number() over (partition by fixme, name order by ts asc nulls last) as rn
+        from fixmeattr
+        where ({commits})
+      )
+
+      select distinct fixme,name,value
+      from
+      (
+        select
+          fixme,
+          name,
+          value
+        from ranked1
+        where rn = 1
+
+        union
+
+        select
+          fixme,
+          name,
+          value
+        from ranked2
+        where rn = 1
+      )
+    |]
+
+  ddl [qc|drop view if exists fixmeactualview|]
+
+  ddl [qc|
+    create view fixmeactualview as
+    with a1 as (
+      select
+        a.fixme,
+        f.ts,
+        a.name,
+        a.value
+      from
+        fixmeattrview a
+        join fixme f on a.fixme = f.id
+      where
+        a.name = 'fixme-key'
+        and not exists (select null from fixmedeleted d where d.id = f.id)
+    ),
+    rn AS (
+      select
+        f.id,
+        f.ts,
+        a.value AS fixmekey,
+        row_number() over (partition by a.value order by f.ts desc) as rn
+      from
+        fixme f
+        join a1 a on f.id = a.fixme and a.name = 'fixme-key'
+    )
+    select id as fixme, fixmekey, ts from rn
+      where rn = 1
+      and not exists (
+      select null
+        from fixmeattr a
+             join fixmedeleted d on d.id = a.fixme
+        where a.name = 'fixme-key'
+              and a.value = rn.fixmekey
+      )
+
+    |]
+
+
+  ddl [qc|
+        create table if not exists fixmeactual
+          ( fixme   text not null
+          , primary key (fixme)
+          )
+      |]
+
+  ddl [qc|
+        create table if not exists fixmejson
+          ( fixme     text not null
+          , fixmekey  text
+          , json      blob
+          , primary key (fixme)
+          )
+      |]
+
+  ddl [qc|
+        create index if not exists idx_fixmekey ON fixmejson(fixmekey)
+      |]
+
+  ddl [qc| create table if not exists fixmestagedel
+           ( hash text    not null primary key
+           , ts   integer not null
+           )
+         |]
+
+  ddl [qc| create table if not exists fixmestagemod
+           ( hash   text    not null
+           , ts     integer not null
+           , attr   text    not null
+           , value  text
+           , primary key (hash,attr)
+           )
+         |]
+
+  ddl [qc| create table if not exists fixmeprocessed
+           ( hash   text  not null
+           , primary key (hash)
+           )
+         |]
+
+-- .fixme-new/state.db
+-- and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
+
+insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
+insertCommit gh = do
+  insert [qc|
+    insert into fixmegitobject (hash,type) values(?,'commit')
+    on conflict (hash) do nothing
+            |] (Only gh)
+
+insertBlob :: FixmePerks m => GitHash -> DBPipeM m ()
+insertBlob gh = do
+  insert [qc|
+    insert into fixmegitobject (hash,type) values(?,'blob')
+    on conflict (hash) do nothing
+            |] (Only gh)
+
+selectObjectHash :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash)
+selectObjectHash gh = do
+  select [qc|select hash from fixmegitobject where hash = ?|] (Only gh)
+    <&> fmap fromOnly . listToMaybe
+
+newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool
+newCommit gh = isNothing <$> withState (selectObjectHash gh)
+
+insertFixme :: FixmePerks m => Fixme -> DBPipeM m ()
+insertFixme fx@Fixme{..} = do
+  let fixme = serialise fx
+  let fxId = hashObject @HbSync fixme & HashRef
+  insert [qc|insert into fixme (id, ts, fixme) values (?,?,?)
+             on conflict(id) do nothing
+            |] (fxId, fixmeTs, fixme)
+
+  for_ (HM.toList fixmeAttr) $ \(n,v) -> do
+    insert [qc|
+      insert into fixmeattr(fixme,ts,name,value)
+      values (?,?,?,?)
+      on conflict (fixme,ts,name) do update set value = excluded.value
+              |] (fxId, fixmeTs, n, v)
+
+    insert [qc|
+      insert into fixmeattr(fixme,ts,name,value)
+      values (?,?,?,?)
+      on conflict (fixme,ts,name) do update set value = excluded.value
+              |] (fxId, fixmeTs, "fixme-tag", fixmeTag)
+
+    insert [qc|
+      insert into fixmeattr(fixme,ts,name,value)
+      values (?,?,?,?)
+      on conflict (fixme,ts,name) do update set value = excluded.value
+              |] (fxId, fixmeTs, "fixme-title", fixmeTitle)
+
+
+data SelectPredicate =
+    All
+  | FixmeHashExactly Text
+  | AttrLike Text Text
+  | And SelectPredicate SelectPredicate
+  | Or SelectPredicate SelectPredicate
+  | Not SelectPredicate
+  | Ignored
+  deriving stock (Data,Generic,Show)
+
+class HasPredicate a where
+  predicate :: a -> SelectPredicate
+
+instance HasPredicate () where
+  predicate = const All
+
+instance HasPredicate SelectPredicate where
+  predicate = id
+
+
+instance IsContext c => HasPredicate [Syntax c] where
+  predicate s = goPred $ unlist $ go s
+    where
+
+      goPred :: Syntax c -> SelectPredicate
+      goPred = \case
+        ListVal [SymbolVal "not", a]     ->  Not (goPred a)
+        ListVal [SymbolVal "or", a, b]   ->  Or (goPred a) (goPred b)
+        ListVal [SymbolVal "and", a, b]  ->  And (goPred a) (goPred b)
+        ListVal [SymbolVal "like", StringLike a, StringLike b] ->  AttrLike (Text.pack a) (Text.pack b)
+        _ -> Ignored
+
+      go :: [Syntax c] -> Syntax c
+      go = \case
+
+        ( SymbolVal "!" : rest ) -> do
+            mklist [mksym "not", unlist (go rest)]
+
+        ( Operand a : SymbolVal "~" : Operand b  : rest ) -> do
+          go (mklist [mksym "like", mkstr a, mkstr b] : rest)
+
+        ( w : SymbolVal "&&" : rest ) -> do
+          mklist [mksym "and", unlist w, unlist (go rest)]
+
+        ( w : SymbolVal "||" : rest ) -> do
+          mklist [mksym "or", unlist w, unlist (go rest)]
+
+        w -> mklist w
+
+      unlist = \case
+        ListVal [x] -> x
+        x -> x
+
+
+{- HLINT ignore "Functor law" -}
+{- HLINT ignore "Eta reduce" -}
+
+selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text)
+selectFixmeHash what = listToMaybe <$> selectFixmeHashes what
+
+selectFixmeHashes :: (FixmePerks m) => Text -> FixmeM m [Text]
+selectFixmeHashes what = withState do
+  let w = what <> "%"
+  select @(Only Text)
+            [qc| select fixme
+                 from fixmejson
+                 where json_extract(json,'$."fixme-key"') like ?
+                 union
+                 select id
+                 from fixme
+                 where id like ?
+            |] (w,w)
+         <&> fmap fromOnly
+
+selectFixme :: FixmePerks m => Text -> FixmeM m (Maybe Fixme)
+selectFixme txt = do
+
+  attrs <- selectFixmeThin (FixmeHashExactly txt)
+             <&> fmap coerce . headMay
+             <&> fromMaybe mempty
+
+  runMaybeT do
+
+    lift (withState $ select [qc|select fixme from fixme where id = ? limit 1|] (Only txt))
+      <&> listToMaybe . fmap fromOnly
+      >>= toMPlus
+      <&> (deserialiseOrFail @Fixme)
+      >>= toMPlus
+      <&> over (field @"fixmeAttr") (<> attrs)
+
+
+listAllFixmeHashes :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef)
+listAllFixmeHashes = withState do
+  select_ @_ @(Only HashRef) [qc|select id from fixme|]
+    <&> HS.fromList . fmap fromOnly
+
+checkFixmeExists :: FixmePerks m => HashRef -> FixmeM m Bool
+checkFixmeExists what = withState do
+  select @(Only (Maybe Int)) [qc|select 1 from fixme where id = ? limit 1|] (Only what)
+    <&> not . List.null
+
+data Bound = forall a . (ToField a, Show a) => Bound a
+
+instance ToField Bound where
+  toField (Bound x) = toField x
+
+instance Show Bound where
+  show (Bound x) = show x
+
+genPredQ  :: Text -> SelectPredicate -> (Text, [Bound])
+genPredQ tbl what = go what
+  where
+    go = \case
+      All -> ("true", mempty)
+
+      FixmeHashExactly x ->
+        ([qc|({tbl}.fixme = ?)|], [Bound x])
+
+      AttrLike "fixme-hash" val -> do
+        let binds = [Bound (val <> "%")]
+        ([qc|({tbl}.fixme like ?)|], binds)
+
+      AttrLike name val -> do
+        let x = val <> "%"
+        let binds = [Bound x]
+        ([qc|(json_extract({tbl}.json, '$."{name}"') like ?)|], binds)
+
+      Not a -> do
+        let (sql, bound) = go a
+        ([qc|(coalesce(not {sql},true))|], bound)
+
+      And a b -> do
+        let (asql, abound) = go a
+        let (bsql, bbound) = go b
+        ([qc|{asql} and {bsql}|], abound <> bbound)
+
+      Or a b -> do
+        let asql = go a
+        let bsql = go b
+        ([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql)
+
+      Ignored -> ("false", mempty)
+
+
+updateFixmeJson :: FixmePerks m =>  DBPipeM m ()
+updateFixmeJson = do
+
+  update_ [qc|
+
+    insert into fixmejson (fixme,fixmekey,json)
+      with json as  (
+        select
+            a.fixme as fixme,
+            cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', f.fixme) as blob) as json
+
+        from
+          fixmeattrview a join fixmeactual f on f.fixme = a.fixme
+
+        group by a.fixme
+      )
+
+      select
+          fixme
+        , json_extract(json, '$."fixme-key"') as fixmekey
+        , json
+         from json where true
+      on conflict (fixme) do update set json = excluded.json, fixmekey = excluded.fixmekey
+  |]
+
+
+-- TODO: predicate-for-stage-toggle
+selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
+selectFixmeThin a = withState do
+
+  let predic = genPredQ "j" (predicate a)
+
+  let emptyObect = [q|'{}'|] :: String
+
+  let sql = [qc|
+
+with s1 as (
+  select  m.hash as hash
+        , cast(json_group_object(m.attr,m.value) as blob) as json
+  from fixmestagemod m
+)
+
+select  cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob
+
+from
+  fixmejson j join fixmeactual f on f.fixme = j.fixme
+              join fixme f0 on f0.id = f.fixme
+              left join s1 s on s.hash = j.fixme
+
+where
+
+  (
+  {fst predic}
+  )
+
+order by json_extract(blob, '$.commit-time'), json_extract(blob, '$.title')
+
+  |]
+
+  trace $ red "selectFixmeThin" <> line <> pretty sql
+
+  (t,r) <- timeItT $ select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly)
+
+  trace $ yellow "selectFixmeThin" <> line
+            <> pretty sql <> line
+            <> pretty (length r) <+> "rows" <> line
+            <> pretty "elapsed" <+> pretty (realToFrac t :: Fixed E6)
+
+  pure r
+
+cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
+cleanupDatabase = do
+  warn $ red "cleanupDatabase"
+  withState $ transactional do
+    update_ [qc|delete from fixme|]
+    update_ [qc|delete from fixmeattr|]
+    update_ [qc|delete from fixmegitobject|]
+    update_ [qc|delete from fixmedeleted|]
+    update_ [qc|delete from fixmerel|]
+    update_ [qc|delete from fixmeactual|]
+    update_ [qc|delete from fixmejson|]
+    update_ [qc|delete from fixmestagedel|]
+    update_ [qc|delete from fixmestagemod|]
+
+
+insertFixmeModStaged :: (FixmePerks m,MonadReader FixmeEnv m)
+                     => Text
+                     -> FixmeAttrName
+                     -> FixmeAttrVal
+                     -> m ()
+insertFixmeModStaged hash k v = withState do
+  ts <- getEpoch
+  insert [qc| insert into fixmestagemod (hash,ts,attr,value) values(?,?,?,?)
+              on conflict (hash,attr)
+                 do update set hash  = excluded.hash
+                             , ts    = excluded.ts
+                             , attr  = excluded.attr
+                             , value = excluded.value
+            |] (hash,ts,k,v)
+
+
+insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
+insertFixmeDelStaged hash = withState do
+  ts <- getEpoch
+  insert [qc| insert into fixmestagedel (hash,ts) values(?,?)
+              on conflict (hash)
+                 do update set hash = excluded.hash
+                  , ts = excluded.ts
+            |] (hash,ts)
+
+
+type StageModRow = (HashRef,Word64,Text,Text)
+
+selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
+selectStageModified = withState do
+  what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|]
+  for what $ \(h,t,k,v) -> do
+    pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v)
+
+selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
+selectStageDeleted = withState do
+  what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|]
+  for what $ \(h,t) -> do
+    pure $ Deleted t h
+
+selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
+selectStage = do
+  a <- selectStageModified
+  b <- selectStageDeleted
+  pure (a<>b)
+
+cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m ()
+cleanStage = withState do
+  transactional do
+    update_ [qc|delete from fixmestagedel|]
+    update_ [qc|delete from fixmestagemod|]
+
+deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
+deleteFixme hash = withState do
+  trace $ red "deleteFixme" <+> pretty hash
+
+  here <- select [qc| select true
+                      from fixmedeleted
+                      where deleted and id = ?
+                      order by ts desc
+                      limit 1
+                     |] (Only hash) <&> isJust . listToMaybe . fmap (fromOnly @Bool)
+
+  unless here do
+    insert [qc| insert into fixmedeleted (id,ts,deleted)
+                values (?,(strftime('%s', 'now')),true)
+                on conflict(id,ts) do nothing
+              |] (Only hash)
+
+updateFixme :: (FixmePerks m,MonadReader FixmeEnv m)
+            => Maybe FixmeTimestamp
+            -> Text
+            -> FixmeAttrName
+            ->  FixmeAttrVal
+            -> m ()
+
+updateFixme ts hash a b = withState do
+  warn $ red "updateFixme" <+> pretty hash
+  insert [qc| insert into fixmeattr (fixme,ts,name,value)
+              values (?,coalesce(?,strftime('%s', 'now')),?,?)
+              on conflict(fixme,ts,name) do update set value = excluded.value
+            |] (hash,ts,a,b)
+
+updateIndexes :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
+updateIndexes = withState $ transactional do
+  update_ [qc|delete from fixmeactual|]
+  update_ [qc|
+    insert into fixmeactual
+      select distinct fixme from fixmeactualview
+    |]
+  updateFixmeJson
+  -- FIXME: delete-table-grows
+  --   надо добавлять статус в fixmedeleted
+  --   только если он отличается от последнего
+  --   известного статуса
+  update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|]
+
+
+
+insertProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
+                => w
+                -> DBPipeM m ()
+insertProcessed what = do
+  insert [qc| insert into fixmeprocessed (hash) values(?)
+              on conflict (hash) do nothing
+            |] (Only (show $ pretty $ hashObject @HbSync what))
+
+
+isProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
+             => w
+             -> DBPipeM m Bool
+isProcessed what = do
+  let k = show $ pretty $ hashObject @HbSync what
+  select @(Only (Maybe Int)) [qc| select null from fixmeprocessed where hash = ? limit 1 |] (Only k)
+   <&> isJust . listToMaybe
+
+selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m)
+                 => m [HashRef]
+selectProcessed = withState do
+  select_ [qc|select hash from fixmeprocessed|]
+    <&> fmap fromOnly
+
+

fixme-new/lib/Fixme/Types.hs

@@ -0,0 +1,648 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Fixme.Types
+  ( module Fixme.Types
+  ) where
+
+import Fixme.Prelude hiding (align)
+import HBS2.Base58
+
+import DBPipe.SQLite hiding (field)
+import HBS2.Git.Local
+
+import Data.Config.Suckless
+
+import Prettyprinter.Render.Terminal
+import Control.Applicative
+import Data.Aeson
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Word (Word64,Word32)
+import Data.Maybe
+import Data.Coerce
+import Data.Text qualified as Text
+import Data.List qualified as List
+import Data.Map qualified as Map
+import System.FilePath
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Generics.Product.Fields (field)
+import Lens.Micro.Platform
+
+-- FIXME: move-to-suckless-conf
+deriving stock instance Ord (Syntax C)
+
+pattern StringLike :: forall {c} . String -> Syntax c
+pattern StringLike e <- (stringLike -> Just e)
+
+pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
+pattern StringLikeList e <- (stringLikeList -> e)
+
+pattern FixmeHashLike :: forall {c} . Text -> Syntax c
+pattern FixmeHashLike  e <- (fixmeHashFromSyn -> Just e)
+
+
+pattern TimeStampLike :: forall {c} . FixmeTimestamp -> Syntax c
+pattern TimeStampLike  e <- (tsFromFromSyn -> Just e)
+
+fixContext :: IsContext c => Syntax c -> Syntax C
+fixContext = go
+  where
+    go = \case
+      List    _ xs -> List noContext (fmap go xs)
+      Symbol  _ w  -> Symbol noContext w
+      Literal _ l  -> Literal noContext l
+
+mklist :: IsContext c => [Syntax c] -> Syntax c
+mklist = List noContext
+
+mkint :: (IsContext c, Integral a) => a -> Syntax c
+mkint  = Literal noContext . LitInt . fromIntegral
+
+mksym :: IsContext c => Id -> Syntax c
+mksym  = Symbol noContext
+
+class MkId a where
+  mkId :: a -> Id
+
+instance MkId FixmeAttrName where
+  mkId (k :: FixmeAttrName) = Id ("$" <> coerce k)
+
+instance MkId (Text,Int) where
+  mkId (p, i) = Id (p <> fromString (show i))
+
+instance MkId (String,Integer) where
+  mkId (p, i) = Id (fromString p <> fromString (show i))
+
+class IsContext c => MkStr c a where
+  mkstr :: a -> Syntax c
+
+
+instance IsContext c => MkStr c String where
+  mkstr s = Literal (noContext @c) (LitStr $ Text.pack s)
+
+instance IsContext c => MkStr c ByteString where
+  mkstr s = Literal (noContext @c) (LitStr $ Text.pack $ BS8.unpack s)
+
+instance IsContext c => MkStr c (Maybe FixmeKey) where
+  mkstr Nothing  = Literal (noContext @c) (LitStr "")
+  mkstr (Just k) = Literal (noContext @c) (LitStr (coerce k))
+
+instance IsContext c => MkStr c FixmeAttrVal where
+  mkstr (s :: FixmeAttrVal)  = Literal (noContext @c) (LitStr (coerce s))
+
+
+instance IsContext c => MkStr c (Maybe FixmeAttrVal) where
+  mkstr (Just v) = mkstr v
+  mkstr Nothing  = mkstr ( "" :: Text )
+
+instance IsContext c => MkStr c FixmeAttrName where
+  mkstr (s :: FixmeAttrName)  = Literal (noContext @c) (LitStr (coerce s))
+
+instance IsContext c => MkStr c HashRef where
+  mkstr s  = Literal (noContext @c) (LitStr (fromString $ show $ pretty s))
+
+instance IsContext c => MkStr c Text where
+  mkstr = Literal noContext . LitStr
+
+stringLike :: Syntax c -> Maybe String
+stringLike = \case
+  LitStrVal s -> Just $ Text.unpack s
+  SymbolVal (Id s) -> Just $ Text.unpack s
+  _ -> Nothing
+
+stringLikeList :: [Syntax c] -> [String]
+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
+
+fixmeHashFromSyn :: Syntax c -> Maybe Text
+fixmeHashFromSyn = \case
+  StringLike s -> do
+    let (_,value) = span (`elem` "#%~:") s
+    Just $ Text.pack value
+
+  _            -> Nothing
+
+tsFromFromSyn :: Syntax c -> Maybe FixmeTimestamp
+tsFromFromSyn = \case
+  LitIntVal n -> Just (fromIntegral n)
+  _ -> Nothing
+
+newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
+                   deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField)
+                   deriving stock (Data,Generic)
+
+newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
+                     deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable)
+                     deriving stock (Data,Generic)
+
+newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
+                         deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField)
+                         deriving stock (Data,Generic)
+
+
+newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text }
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable)
+                        deriving newtype (ToField,FromField)
+                        deriving newtype (ToJSON,FromJSON,ToJSONKey,FromJSONKey)
+                        deriving stock (Data,Generic)
+
+
+newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField,ToJSON,FromJSON,Semigroup,Monoid)
+                        deriving stock (Data,Generic)
+
+newtype FixmeTimestamp = FixmeTimestamp Word64
+                        deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
+                        deriving stock (Data,Generic)
+
+
+newtype FixmeKey  = FixmeKey Text
+                    deriving newtype (Eq,Ord,Show,ToField,FromField)
+                    deriving stock (Data,Generic)
+
+newtype FixmeOffset = FixmeOffset Word32
+                     deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
+                     deriving newtype (Integral,Real,Enum)
+                     deriving stock (Data,Generic)
+
+
+data Fixme =
+  Fixme
+  { fixmeTag       :: FixmeTag
+  , fixmeTitle     :: FixmeTitle
+  , fixmeKey       :: Maybe FixmeKey
+  , fixmeTs        :: Maybe FixmeTimestamp
+  , fixmeStart     :: Maybe FixmeOffset
+  , fixmeEnd       :: Maybe FixmeOffset
+  , fixmePlain     :: [FixmePlainLine]
+  , fixmeAttr      :: HashMap FixmeAttrName FixmeAttrVal
+  }
+  deriving stock (Ord,Eq,Show,Data,Generic)
+
+instance Monoid Fixme where
+  mempty = Fixme mempty mempty Nothing Nothing Nothing Nothing mempty mempty
+
+instance Semigroup Fixme where
+  (<>) a b = b { fixmeTs  = fixmeTs b <|> fixmeTs a
+               , fixmeTitle = fixmeAttrNonEmpty (fixmeTitle a) (fixmeTitle b)
+               , fixmeTag   = fixmeAttrNonEmpty (fixmeTag a) (fixmeTag b)
+               , fixmeStart = fixmeStart b <|> fixmeStart a
+               , fixmeEnd = fixmeEnd b <|> fixmeEnd a
+               , fixmePlain = fixmePlain b
+               , fixmeAttr = fixmeAttr a <> fixmeAttr b
+               }
+
+newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
+                    deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
+                    deriving stock (Data,Generic)
+
+
+
+
+type FixmePerks m = ( MonadUnliftIO m
+                    , MonadIO m
+                    )
+
+
+data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction :: Syntax c -> IO () }
+
+data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () }
+
+-- FIXME: fucking-context-hardcode-wtf-1
+data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> LBS.ByteString -> IO () }
+
+data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c]
+
+class HasSequence w where
+  getSequence :: w -> Word64
+
+newtype FromFixmeKey a = FromFixmeKey a
+
+data CompactAction =
+    Deleted  Word64 HashRef
+  | Modified Word64 HashRef FixmeAttrName FixmeAttrVal
+  | Added    Word64 Fixme
+  deriving stock (Eq,Ord,Show,Generic)
+
+class MkKey a where
+  mkKey :: a -> ByteString
+
+instance MkKey CompactAction where
+  mkKey (Deleted _ h) = "D" <> LBS.toStrict (serialise h)
+  mkKey (Modified _ h _ _) = "M" <> LBS.toStrict (serialise h)
+  mkKey (Added _ fixme) = "A" <> coerce (hashObject @HbSync $ serialise fixme)
+
+instance MkKey (FromFixmeKey Fixme) where
+  mkKey (FromFixmeKey fx@Fixme{..}) =
+    maybe k2  (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr)
+    where k2 = mappend "A" $ serialise fx & LBS.toStrict
+
+instance Pretty CompactAction where
+  pretty = \case
+    Deleted s r      -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r  ]
+    Modified s r k v -> pretty $ mklist @C [ mksym "modified", mkint s, mkstr r, mkstr k, mkstr v ]
+    -- FIXME: normal-pretty-instance
+    e@(Added  w fx) -> do
+      pretty $ mklist @C [ mksym "added", mkstr (toBase58 $ mkKey e) ]
+
+instance Serialise CompactAction
+
+pattern CompactActionSeq :: Word64 -> CompactAction
+pattern CompactActionSeq s <- (seqOf -> Just s)
+
+{-# COMPLETE CompactActionSeq #-}
+
+seqOf :: CompactAction -> Maybe Word64
+seqOf = \case
+  Deleted   w  _ -> Just w
+  Modified  w _ _ _ -> Just w
+  Added w _ -> Just w
+
+instance HasSequence CompactAction where
+  getSequence x = fromMaybe 0 (seqOf x)
+
+data FixmeTemplate =
+  Simple SimpleTemplate
+
+data RenderError = RenderError String
+                   deriving stock (Eq,Show,Typeable)
+
+class FixmeRenderTemplate a b where
+  render :: a -> Either RenderError b
+
+data FixmeOpts =
+  FixmeOpts
+  { fixmeOptNoEvolve :: Bool
+  }
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+instance Monoid FixmeOpts where
+  mempty = FixmeOpts False
+
+instance Semigroup FixmeOpts where
+  (<>) _ b = FixmeOpts (fixmeOptNoEvolve b)
+
+data FixmeEnv =
+  FixmeEnv
+  { fixmeLock              :: MVar ()
+  , fixmeEnvOpts           :: TVar FixmeOpts
+  , fixmeEnvDbPath         :: TVar FilePath
+  , fixmeEnvDb             :: TVar (Maybe DBPipeEnv)
+  , fixmeEnvGitDir         :: TVar (Maybe FilePath)
+  , fixmeEnvFileMask       :: TVar [FilePattern]
+  , fixmeEnvTags           :: TVar (HashSet FixmeTag)
+  , fixmeEnvAttribs        :: TVar (HashSet FixmeAttrName)
+  , fixmeEnvAttribValues   :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
+  , fixmeEnvDefComments    :: TVar (HashSet Text)
+  , fixmeEnvFileComments   :: TVar (HashMap FilePath (HashSet Text))
+  , fixmeEnvGitScanDays    :: TVar (Maybe Integer)
+  , fixmeEnvUpdateActions  :: TVar [UpdateAction]
+  , fixmeEnvReadLogActions :: TVar [ReadLogAction]
+  , fixmeEnvCatAction      :: TVar CatAction
+  , fixmeEnvTemplates      :: TVar (HashMap Id FixmeTemplate)
+  , fixmeEnvMacro          :: TVar (HashMap Id (Syntax C))
+  , fixmeEnvCatContext     :: TVar (Int,Int)
+  }
+
+
+fixmeGetCommentsFor :: FixmePerks m => Maybe FilePath -> FixmeM m [Text]
+
+fixmeGetCommentsFor Nothing = do
+  asks fixmeEnvDefComments >>= readTVarIO
+    <&> HS.toList
+
+fixmeGetCommentsFor (Just fp) = do
+  cof <- asks fixmeEnvFileComments >>= readTVarIO
+  def <- asks fixmeEnvDefComments >>= readTVarIO
+
+  let r = maybe mempty HS.toList (HM.lookup (commentKey fp) cof)
+           <> HS.toList def
+
+  pure r
+
+{- HLINT ignore "Functor law" -}
+
+fixmeGetGitDirCLIOpt :: (FixmePerks m, MonadReader FixmeEnv m) => m String
+fixmeGetGitDirCLIOpt = do
+  asks fixmeEnvGitDir
+          >>= readTVarIO
+          <&> fmap (\d -> [qc|--git-dir {d}|])
+          <&> fromMaybe ""
+
+newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadReader FixmeEnv
+                                      )
+
+
+fixmeEnvBare :: FixmePerks m => m FixmeEnv
+fixmeEnvBare =
+  FixmeEnv
+    <$>  newMVar ()
+    <*>  newTVarIO mempty
+    <*>  newTVarIO ":memory:"
+    <*>  newTVarIO Nothing
+    <*>  newTVarIO Nothing
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO defCommentMap
+    <*>  newTVarIO Nothing
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO (CatAction $ \_ _ -> pure ())
+    <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
+    <*>  newTVarIO (1,3)
+
+withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
+withFixmeEnv env what = runReaderT ( fromFixmeM what) env
+
+-- FIXME: move-to-suckless-conf-library
+deriving newtype instance Hashable Id
+
+instance Serialise FixmeTag
+instance Serialise FixmeTitle
+instance Serialise FixmePlainLine
+instance Serialise FixmeAttrName
+instance Serialise FixmeAttrVal
+instance Serialise FixmeTimestamp
+instance Serialise FixmeOffset
+instance Serialise FixmeKey
+instance Serialise Fixme
+
+
+instance ToField GitHash where
+  toField h = toField (show $ pretty h)
+
+instance ToField GitRef where
+  toField h = toField (show $ pretty h)
+
+instance FromField GitRef where
+  fromField = fmap fromString . fromField @String
+
+instance FromField GitHash where
+  fromField = fmap fromString . fromField @String
+
+instance Pretty FixmeTimestamp where
+  pretty = pretty . coerce @_ @Word64
+
+instance Pretty FixmeOffset where
+  pretty = pretty . coerce @_ @Word32
+
+instance Pretty FixmeAttrName where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeAttrVal where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeTitle where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeTag where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmePlainLine where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty Fixme where
+  pretty Fixme{..} =
+    pretty fixmeTag <+> pretty fixmeTitle
+    <> fstart
+    <> fend
+    <> la
+    <> lls
+    <> line
+    where
+
+      fstart = case fixmeStart of
+        Just s  -> line <> pretty ([qc| $fixme-start: {show $ pretty s}|] :: String)
+        Nothing -> mempty
+
+      fend = case fixmeEnd of
+        Just s  -> line <> pretty ([qc| $fixme-end: {show $ pretty s}|] :: String)
+        Nothing -> mempty
+
+      la | not (HM.null fixmeAttr) = do
+            let a = HM.toList fixmeAttr
+            let ss = [ [qc| ${show $ pretty n}: {show $ pretty v}|]  | (n,v) <- a ]  :: [String]
+            line <> vcat ( fmap pretty ss ) <> line
+
+         | otherwise = mempty
+
+      lls | not (null fixmePlain) =  line <> vcat (fmap pretty fixmePlain)
+          | otherwise = mempty
+
+
+defCommentMap :: HashMap FilePath (HashSet Text)
+defCommentMap = HM.fromList
+  [ comment ".cabal"   ["--"]
+  , comment ".hs"      ["--"]
+  , comment ".c"       ["//"]
+  , comment ".h"       ["//"]
+  , comment ".cc"      ["//"]
+  , comment ".cpp"     ["//"]
+  , comment ".cxx"     ["//"]
+  , comment "Makefile" ["#"]
+  ]
+  where
+    comment a b = (a, HS.fromList b)
+
+commentKey :: FilePath -> FilePath
+commentKey fp =
+  case takeExtension fp of
+    "" -> takeFileName fp
+    xs -> xs
+
+type ContextShit c = (Data c, Data (Context c), IsContext c, Data (Syntax c))
+
+
+cc0 :: forall c . ContextShit c => Context c
+cc0 = noContext :: Context c
+
+inject :: forall c  a . (ContextShit c, Data a) => [(Id,Syntax c)] -> a -> a
+inject repl target =
+  flip transformBi target $ \case
+   (SymbolVal x) | issubst x -> fromMaybe mt (Map.lookup x rmap)
+   other -> other
+   where
+    mt = Literal (noContext @c) (LitStr "")
+    rmap = Map.fromList repl
+    issubst (Id x) = Text.isPrefixOf "$" x
+
+pattern NL :: forall {c}. Syntax c
+pattern NL <- ListVal [SymbolVal "nl"]
+
+
+instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where
+
+  render (SimpleTemplate syn) = Right $ mconcat $
+      flip fix (mempty,syn) $ \next -> \case
+        (acc, NL : rest)    -> next (acc <> nl, rest)
+        (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest)
+        (acc, StringLike w : rest) -> next (acc <> txt w, rest)
+        (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep' [e]), rest)
+        (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep' [e]), rest)
+        (acc, ListVal [SymbolVal "fg", SymbolVal co, e] : rest) -> next (acc <> fmap (fg_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "bg", SymbolVal co, e] : rest) -> next (acc <> fmap (bg_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "fgd", SymbolVal co, e] : rest) -> next (acc <> fmap (fgd_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "bgd", SymbolVal co, e] : rest) -> next (acc <> fmap (bgd_ (color_ co)) (deep [e]), rest)
+
+        (acc, ListVal [ SymbolVal "if", cond
+                      , ListVal (SymbolVal "then" : then_)
+                      , ListVal (SymbolVal "else" : else_)
+                      ] : rest) -> do
+
+          let r = case cond of
+                    ListVal [SymbolVal "~", StringLike p, evaluated -> Just x] ->
+                      Text.isPrefixOf (Text.pack p) x
+                    _ -> False
+
+          next (acc <> if r then deep then_ else deep else_, rest)
+
+
+        (acc, ListVal es : rest) ->  next (acc <> deep es, rest)
+        (acc, e : rest) -> next (acc <> p e, rest)
+        (acc, []) -> acc
+
+    where
+
+      evaluated :: (ContextShit c) => Syntax c -> Maybe  Text
+      evaluated what = Just (deep' [what] & Text.concat)
+
+      color_ = \case
+        "black"   -> Just Black
+        "red"     -> Just Red
+        "green"   -> Just Green
+        "yellow"  -> Just Yellow
+        "blue"    -> Just Blue
+        "magenta" -> Just Magenta
+        "cyan"    -> Just Cyan
+        "white"   -> Just White
+        _         -> Nothing
+
+
+      fg_ = maybe id (annotate . color)
+      bg_ = maybe id (annotate . bgColor)
+
+      fgd_ = maybe id (annotate . colorDull)
+      bgd_ = maybe id (annotate . bgColorDull)
+
+      untxt = fmap pretty
+
+      align n0 s0 | n > 0     = untxt [Text.justifyLeft n ' ' s]
+                  | otherwise = untxt [Text.justifyRight (abs n) ' ' s]
+
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      trim n0 s0 | n >= 0     = untxt [ Text.take n s ]
+                 | otherwise  = untxt [ Text.takeEnd (abs n) s ]
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      deep :: forall c . (ContextShit c) => [Syntax c] -> [Doc AnsiStyle]
+      deep sy = either mempty List.singleton (render (SimpleTemplate sy))
+
+      deep' :: forall c . (ContextShit c) => [Syntax c] -> [Text]
+      deep' sy = do
+        let what = deep sy
+        [ Text.pack (show x) | x <- what]
+
+      nl = [ line ]
+      txt s = [fromString s]
+      p e = untxt [Text.pack (show $ pretty e)]
+
+
+instance FixmeRenderTemplate SimpleTemplate Text where
+  render (SimpleTemplate syn) = Right $ Text.concat $
+      flip fix (mempty,syn) $ \next -> \case
+        (acc, NL : rest)    -> next (acc <> nl, rest)
+        (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest)
+        (acc, StringLike w : rest) -> next (acc <> txt w, rest)
+        (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep [e]), rest)
+        (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep [e]), rest)
+        (acc, ListVal es : rest) ->  next (acc <> deep es, rest)
+        (acc, e : rest) -> next (acc <> p e, rest)
+        (acc, []) -> acc
+
+    where
+
+      align n0 s0 | n > 0     = [Text.justifyLeft n ' ' s]
+                  | otherwise = [Text.justifyRight (abs n) ' ' s]
+
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      trim n0 s0 | n >= 0     = [ Text.take n s ]
+                 | otherwise  = [ Text.takeEnd (abs n) s ]
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      deep :: forall c . (ContextShit c) => [Syntax c] -> [Text]
+      deep sy = either mempty List.singleton (render (SimpleTemplate sy))
+
+      nl = [ "\n" ]
+      txt s = [fromString s]
+      p e = [Text.pack (show $ pretty e)]
+
+
+newtype ViaSerialise a = ViaSerialise a
+
+instance Serialise a => Hashed HbSync (ViaSerialise a) where
+  hashObject (ViaSerialise x) = hashObject (serialise x)
+
+
+fixmeTitleNonEmpty :: FixmeTitle -> FixmeTitle -> FixmeTitle
+fixmeTitleNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
+  (x,y) | Text.null x && not (Text.null y) -> FixmeTitle y
+  (x,y) | not (Text.null x) &&  Text.null y -> FixmeTitle x
+  (_,y) -> FixmeTitle y
+
+fixmeAttrNonEmpty :: Coercible a Text => a -> a -> a
+fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
+  (x,y) | Text.null x && not (Text.null y) -> b
+  (x,y) | not (Text.null x) &&  Text.null y -> a
+  (_,_) -> b
+
+fixmeDerivedFields :: Fixme -> Fixme
+fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
+  where
+    email = HM.lookup "commiter-email" (fixmeAttr fx)
+              & maybe mempty (\x -> " <" <> x <> ">")
+
+    comitter = HM.lookup "commiter-name" (fixmeAttr fx)
+                 <&> (<> email)
+
+    tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx))  }
+
+    lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show
+
+    fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
+
+    fxCo =
+      maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter
+
+    fxMisc =
+      fx & over (field @"fixmeAttr")
+                (HM.insert "fixme-title" (FixmeAttrVal (coerce (fixmeTitle fx))))
+
+mkFixmeFileName :: FilePath -> Fixme
+mkFixmeFileName fp =
+  mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) }
+
+

flake.lock

@@ -8,15 +8,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"
       }
@@ -133,6 +134,92 @@
         "type": "github"
       }
     },
+    "flake-utils_7": {
+      "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_8": {
+      "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_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": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1711855026,
+        "narHash": "sha256-uO2dNqFiio46cuZURBC00k17uKGAtUgP7bZAYZ9HlOU=",
+        "ref": "refs/heads/master",
+        "rev": "a579201f0672f90eec7c42e65d6828978dddb816",
+        "revCount": 39,
+        "type": "git",
+        "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+      },
+      "original": {
+        "type": "git",
+        "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+      }
+    },
+    "fuzzy_2": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_8",
+        "nixpkgs": "nixpkgs_2"
+      },
+      "locked": {
+        "lastModified": 1715918584,
+        "narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
+        "ref": "refs/heads/master",
+        "rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
+        "revCount": 63,
+        "type": "git",
+        "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
+      },
+      "original": {
+        "rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
+        "type": "git",
+        "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
+      }
+    },
     "haskell-flake-utils": {
       "inputs": {
         "flake-utils": "flake-utils"
@@ -191,6 +278,24 @@
       "inputs": {
         "flake-utils": "flake-utils_4"
       },
+      "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_5"
+      },
       "locked": {
         "lastModified": 1698938553,
         "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
@@ -206,25 +311,6 @@
         "type": "github"
       }
     },
-    "haskell-flake-utils_5": {
-      "inputs": {
-        "flake-utils": "flake-utils_5"
-      },
-      "locked": {
-        "lastModified": 1672412555,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ivanovs-4",
-        "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
-        "type": "github"
-      }
-    },
     "haskell-flake-utils_6": {
       "inputs": {
         "flake-utils": "flake-utils_6"
@@ -237,6 +323,61 @@
         "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
         "type": "github"
       },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils_7": {
+      "inputs": {
+        "flake-utils": "flake-utils_7"
+      },
+      "locked": {
+        "lastModified": 1698938553,
+        "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils_8": {
+      "inputs": {
+        "flake-utils": "flake-utils_8"
+      },
+      "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_9"
+      },
+      "locked": {
+        "lastModified": 1672412555,
+        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "type": "github"
+      },
       "original": {
         "owner": "ivanovs-4",
         "repo": "haskell-flake-utils",
@@ -245,7 +386,7 @@
     },
     "hspup": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_5",
+        "haskell-flake-utils": "haskell-flake-utils_6",
         "nixpkgs": [
           "nixpkgs"
         ]
@@ -264,6 +405,27 @@
         "type": "github"
       }
     },
+    "lsm": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_7",
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1711033804,
+        "narHash": "sha256-z9cb5yuWfuZmGukxsZebXhc6KUZoPVT60oXxQ6j6ML8=",
+        "ref": "refs/heads/master",
+        "rev": "0e8286a43da5b9e54c4f3ecdb994173fe77351db",
+        "revCount": 26,
+        "type": "git",
+        "url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls"
+      }
+    },
     "nixpkgs": {
       "locked": {
         "lastModified": 1707451808,
@@ -280,12 +442,30 @@
         "type": "github"
       }
     },
+    "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"
+      }
+    },
     "root": {
       "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": "nixpkgs",
         "saltine": "saltine",
         "suckless-conf": "suckless-conf_2"
@@ -332,23 +512,25 @@
     },
     "suckless-conf_2": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_6",
+        "fuzzy": "fuzzy_2",
+        "haskell-flake-utils": "haskell-flake-utils_9",
         "nixpkgs": [
           "nixpkgs"
         ]
       },
       "locked": {
-        "lastModified": 1704001322,
+        "lastModified": 1715919707,
-        "narHash": "sha256-D7T/8wAg5J4KkRw0uB90w3+adY11aQaX7rjmQPXkkQc=",
+        "narHash": "sha256-lbvrCqJHC//NJgfvsy15+Evup5CS+CE50NolDwPIh94=",
         "ref": "refs/heads/master",
-        "rev": "8cfc1272bb79ef6ad62ae6a625f21e239916d196",
+        "rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01",
-        "revCount": 28,
+        "revCount": 35,
         "type": "git",
-        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
+        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6"
       },
       "original": {
+        "rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01",
         "type": "git",
-        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
+        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6"
       }
     }
   },

flake.nix

@@ -10,14 +10,23 @@ inputs = {
     hspup.inputs.nixpkgs.follows = "nixpkgs";
 
     fixme.url = "git+https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr";
+    #fixme.url = "git+file:///home/dmz/w/fixme?ref=dev-0.2";
     fixme.inputs.nixpkgs.follows = "nixpkgs";
 
-    suckless-conf.url = "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ";
+    suckless-conf.url =
+      "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=41830ea2f2e9bb589976f0433207a8f1b73b0b01&tag=0.1.2.6";
+
     suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
 
-    db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft";
+    db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft?ref=generic-sql";
     db-pipe.inputs.nixpkgs.follows = "nixpkgs";
 
+    lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls";
+    lsm.inputs.nixpkgs.follows = "nixpkgs";
+
+    fuzzy.url = "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
+    fuzzy.inputs.nixpkgs.follows = "nixpkgs";
+
     saltine = {
       url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d";
       flake = false;
@@ -35,8 +44,10 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-git"
      "hbs2-qblf"
      "hbs2-keyman"
-     "hbs2-share"
      "hbs2-fixer"
+     "hbs2-cli"
+     "hbs2-sync"
+     "fixme-new"
     ];
   in
  haskell-flake-utils.lib.simpleCabalProject2flake {
@@ -58,13 +69,16 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-storage-simple" = "./hbs2-storage-simple";
      "hbs2-peer"   = "./hbs2-peer";
      "hbs2-keyman" = "./hbs2-keyman";
-     "hbs2-share"  = "./hbs2-share";
      "hbs2-git"    = "./hbs2-git";
      "hbs2-fixer"  = "./hbs2-fixer";
+     "hbs2-cli"    = "./hbs2-cli";
+     "hbs2-sync"   = "./hbs2-sync";
+     "fixme-new"   = "./fixme-new";
    };
 
    hpPreOverrides = {pkgs, ...}: final: prev: with pkgs; {
      saltine = prev.callCabal2nix "saltine" inputs.saltine { inherit (pkgs) libsodium; };
+     scotty = final.callHackage "scotty" "0.21" { };
    };
 
    packagePostOverrides = { pkgs }: with pkgs; with haskell.lib; [

hbs2-cli/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2024, Dmitry Zuikov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Dmitry Zuikov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-cli/app/Main.hs

@@ -0,0 +1,97 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module Main where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run
+import HBS2.CLI.Run.Help
+import HBS2.CLI.Run.KeyMan
+import HBS2.CLI.Run.Keyring
+import HBS2.CLI.Run.GroupKey
+import HBS2.CLI.Run.Sigil
+import HBS2.CLI.Run.MetaData
+import HBS2.CLI.Run.Peer
+import HBS2.CLI.Run.RefLog
+import HBS2.CLI.Run.RefChan
+import HBS2.CLI.Run.LWWRef
+
+import Data.Config.Suckless.Script.File as SF
+
+import HBS2.Peer.RPC.Client.Unix
+
+import HBS2.Net.Auth.Schema()
+
+import System.Environment
+
+type RefLogId = PubKey 'Sign 'HBS2Basic
+
+{- HLINT ignore "Functor law" -}
+
+
+setupLogger :: MonadIO m => m ()
+setupLogger = do
+  -- setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+  setLogging @ERROR  $ toStderr . logPrefix "[error] "
+  setLogging @WARN   $ toStderr . logPrefix "[warn] "
+  setLogging @NOTICE $ toStdout . logPrefix ""
+  pure ()
+
+flushLoggers :: MonadIO m => m ()
+flushLoggers = do
+  silence
+
+silence :: MonadIO m => m ()
+silence = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+
+main :: IO ()
+main = do
+
+  setupLogger
+
+  cli <- getArgs <&> unlines . fmap unwords . splitForms
+           >>= either (error.show) pure . parseTop
+
+  let dict = makeDict do
+
+        internalEntries
+        keymanEntries
+        keyringEntries
+        groupKeyEntries
+        sigilEntries
+        metaDataEntries
+        peerEntries
+        reflogEntries
+        refchanEntries
+        lwwRefEntries
+        helpEntries
+
+        SF.entries
+
+        entry $ bindMatch "--help" $ nil_ \case
+          HelpEntryBound what -> helpEntry what
+          [StringLike s]      -> helpList False (Just s)
+          _                   -> helpList False Nothing
+
+        entry $ bindMatch "debug:cli:show" $ nil_ \case
+          _ -> display cli
+
+  runHBS2Cli do
+
+    case cli of
+      [ListVal [SymbolVal "stdin"]] -> do
+        what <- liftIO getContents
+                  >>= either (error.show) pure . parseTop
+
+        recover $ run dict what >>= eatNil display
+
+      [] -> do
+        void $ run dict [mkForm  "help" []]
+
+      _ -> do
+        recover $ run dict cli >>= eatNil display
+

hbs2-cli/hbs2-cli.cabal

@@ -0,0 +1,143 @@
+cabal-version:      3.0
+name:               hbs2-cli
+version:            0.24.1.2
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+-- copyright:
+category:           System
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common shared-properties
+  ghc-options:
+        -Wall
+        -fno-warn-type-defaults
+        -threaded
+        -rtsopts
+        -O2
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+  default-language: GHC2021
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , RecordWildCards
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+                     , PatternSynonyms
+                     , ViewPatterns
+
+
+  build-depends:
+        hbs2-core
+      , hbs2-peer
+      , hbs2-storage-simple
+      , hbs2-keyman
+      , db-pipe
+      , suckless-conf
+
+      , attoparsec
+      , atomic-write
+      , bytestring
+      , binary
+      , containers
+      , directory
+      , exceptions
+      , filepath
+      , filepattern
+      , hashable
+      , interpolatedstring-perl6
+      , memory
+      , microlens-platform
+      , mtl
+      , safe
+      , serialise
+      , streaming
+      , stm
+      , text
+      , time
+      , timeit
+      , transformers
+      , typed-process
+      , unordered-containers
+      , unliftio
+      , unliftio-core
+      , zlib
+      , prettyprinter
+      , prettyprinter-ansi-terminal
+      , random
+      , vector
+      , unix
+      , split
+
+
+library
+    import:           shared-properties
+
+    exposed-modules:
+      HBS2.CLI
+      HBS2.CLI.Prelude
+      HBS2.CLI.Bind
+      HBS2.CLI.Run
+      HBS2.CLI.Run.Internal
+      HBS2.CLI.Run.Internal.GroupKey
+      HBS2.CLI.Run.Internal.Merkle
+      HBS2.CLI.Run.Internal.KeyMan
+      HBS2.CLI.Run.GroupKey
+      HBS2.CLI.Run.KeyMan
+      HBS2.CLI.Run.Keyring
+      HBS2.CLI.Run.MetaData
+      HBS2.CLI.Run.Peer
+      HBS2.CLI.Run.RefLog
+      HBS2.CLI.Run.RefChan
+      HBS2.CLI.Run.LWWRef
+      HBS2.CLI.Run.Sigil
+
+      HBS2.CLI.Run.Help
+
+      Data.Config.Suckless.Script
+      Data.Config.Suckless.Script.Internal
+      Data.Config.Suckless.Script.File
+
+    build-depends:    base
+                    , magic
+
+    hs-source-dirs:   lib
+
+
+executable hbs2-cli
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+          base, hbs2-cli
+
+    hs-source-dirs:   app
+    default-language: GHC2021
+

hbs2-cli/lib/Data/Config/Suckless/Script.hs

@@ -0,0 +1,48 @@
+{-# Language UndecidableInstances #-}
+module Data.Config.Suckless.Script
+  ( module Exported
+  , module Data.Config.Suckless.Script
+  ) where
+
+import Data.Config.Suckless as Exported
+import Data.Config.Suckless.Script.Internal as Exported
+
+import Control.Monad.Reader
+import Data.HashMap.Strict qualified as HM
+import Prettyprinter
+import Prettyprinter.Render.Terminal
+import Data.List qualified as List
+import Data.Text qualified as Text
+import UnliftIO
+
+
+{- HLINT ignore "Functor law" -}
+
+helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m ()
+helpList hasDoc p = do
+
+  let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
+
+  d <- ask >>= readTVarIO
+  let ks = [k | Id k <- List.sort (HM.keys d)
+           , match k
+           , not hasDoc || docDefined (HM.lookup (Id k) d)
+           ]
+
+  display_ $ vcat (fmap pretty ks)
+
+  where
+    docDefined (Just (Bind (Just w) _)) = True
+    docDefined _ = False
+
+helpEntry :: MonadUnliftIO m => Id -> RunM c m ()
+helpEntry what = do
+  man <- ask >>= readTVarIO
+           <&> HM.lookup what
+           <&> maybe mzero bindMan
+
+  liftIO $ hPutDoc stdout (pretty man)
+
+pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
+pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]
+

hbs2-cli/lib/Data/Config/Suckless/Script/File.hs

@@ -0,0 +1,84 @@
+{-# Language MultiWayIf #-}
+module Data.Config.Suckless.Script.File where
+
+import Data.Config.Suckless
+import Data.Config.Suckless.Script.Internal
+
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Cont
+import Data.Maybe
+import Data.Either
+import Data.Foldable
+import System.Directory
+import System.FilePath
+import System.FilePattern
+import Data.HashSet qualified as HS
+
+import Lens.Micro.Platform
+import UnliftIO
+import Control.Concurrent.STM qualified as STM
+import Streaming.Prelude qualified as S
+
+glob :: forall m . MonadIO m
+     => [FilePattern]           -- ^ search patterns
+     -> [FilePattern]           -- ^ ignore patterns
+     -> FilePath                -- ^ directory
+     -> (FilePath -> m Bool)    -- ^ file action
+     -> m ()
+
+glob pat ignore dir action = do
+  q <- newTQueueIO
+  void $ liftIO (async $ go q dir >> atomically (writeTQueue q Nothing))
+  fix $ \next -> do
+    atomically (readTQueue q) >>= \case
+      Nothing -> pure ()
+      Just x -> do
+        r <- action x
+        when r next
+
+  where
+
+    matches p f = or [ i ?== f | i <- p ]
+    skip p = or [ i ?== p | i <- ignore ]
+
+    go q f = do
+
+      isD <- doesDirectoryExist f
+
+      if not isD then do
+        isF <- doesFileExist f
+        when (isF && matches pat f && not (skip f)) do
+          atomically $ writeTQueue q (Just f)
+      else do
+        co' <- (try @_ @IOError $ listDirectory f)
+                 <&> fromRight mempty
+
+        forConcurrently_ co' $ \x -> do
+          let p = normalise (f </> x)
+          unless (skip p) (go q p)
+
+entries :: forall c m . ( IsContext c
+                        , Exception (BadFormException c)
+                        , MonadUnliftIO m)
+         => MakeDictM c m ()
+entries = do
+  entry $ bindMatch "glob" $ \syn -> do
+
+    (p,i,d) <- case syn of
+                 [] -> pure (["*"], [], ".")
+
+                 [StringLike d, StringLike i, StringLike e] -> do
+                    pure ([i], [e], d)
+
+                 [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
+                    pure (i, e, d)
+
+                 _ -> throwIO (BadFormException @c nil)
+
+    r <- S.toList_ $ glob p i d $ \fn -> do
+          S.yield (mkStr @c fn) -- do
+          pure True
+
+    pure (mkList r)
+

hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs

@@ -0,0 +1,975 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module Data.Config.Suckless.Script.Internal
+  ( module Data.Config.Suckless.Script.Internal
+  , module Export
+  ) where
+
+import Data.Config.Suckless
+
+import Control.Applicative
+import Control.Monad.Identity
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.Data
+import Data.Function as Export
+import Data.Functor as Export
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.Kind
+import Data.List (isPrefixOf)
+import Data.List qualified as List
+import Data.Maybe
+import Data.String
+import Data.Text.IO qualified as TIO
+import Data.Text qualified as Text
+import Data.Text (Text)
+import Data.Time.Clock.POSIX
+import GHC.Generics hiding (C)
+import Prettyprinter
+import Prettyprinter.Render.Terminal
+import Safe
+import Streaming.Prelude qualified as S
+import System.Environment
+import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO
+
+-- TODO: move-to-suckless-conf
+
+data ManApplyArg = ManApplyArg Text Text
+                   deriving stock (Eq,Show,Data,Generic)
+
+newtype ManApply = ManApply [ ManApplyArg ]
+                   deriving stock (Eq,Show,Data,Generic)
+                   deriving newtype (Semigroup,Monoid)
+
+data ManSynopsis =
+  ManSynopsis ManApply
+  deriving stock (Eq,Show,Data,Generic)
+
+data ManDesc     = ManDescRaw Text
+  deriving stock (Eq,Show,Data,Generic)
+
+data ManRetVal   = ManRetVal
+  deriving stock (Eq,Show,Data,Generic)
+
+newtype ManName a = ManName Id
+  deriving stock (Eq,Show,Data,Generic)
+  deriving newtype (IsString,Pretty)
+
+newtype ManBrief = ManBrief Text
+  deriving stock (Eq,Show,Data,Generic)
+  deriving newtype (Pretty,IsString)
+
+data ManReturns = ManReturns Text Text
+  deriving stock (Eq,Show,Data,Generic)
+
+newtype ManExamples =
+  ManExamples Text
+  deriving stock (Eq,Show,Data,Generic)
+  deriving newtype (Pretty,IsString,Monoid,Semigroup)
+
+class ManNameOf a ann where
+  manNameOf :: a -> ManName ann
+
+data Man a =
+  Man
+  { manName     :: Maybe (ManName a)
+  , manHidden   :: Bool
+  , manBrief    :: Maybe ManBrief
+  , manSynopsis :: [ManSynopsis]
+  , manDesc     :: Maybe ManDesc
+  , manReturns  :: Maybe ManReturns
+  , manExamples :: [ManExamples]
+  }
+  deriving stock (Eq,Show,Generic)
+
+instance Monoid (Man a) where
+  mempty = Man Nothing False Nothing mempty Nothing Nothing mempty
+
+instance Semigroup (Man a) where
+  (<>) a b = Man (manName b <|> manName a)
+                 (manHidden b || manHidden a)
+                 (manBrief b <|> manBrief a)
+                 (manSynopsis a <> manSynopsis b)
+                 (manDesc b <|> manDesc a)
+                 (manReturns b <|> manReturns a)
+                 (manExamples a <> manExamples b)
+
+instance ManNameOf Id a where
+  manNameOf = ManName
+
+
+instance Pretty ManDesc where
+  pretty = \case
+    ManDescRaw t -> pretty t
+
+instance IsString ManDesc where
+  fromString s = ManDescRaw (Text.pack s)
+
+instance Pretty (Man a) where
+  pretty e =   "NAME"
+             <> line
+             <> indent 8 (pretty (manName e) <> fmtBrief e)
+             <> line
+             <> fmtSynopsis
+             <> fmtDescription
+             <> retval
+             <> fmtExamples
+   where
+    fmtBrief a = case manBrief a of
+      Nothing -> mempty
+      Just x  -> " - " <> pretty x
+
+    retval = case manReturns e of
+      Nothing -> mempty
+      Just (ManReturns t s) ->
+        line <> "RETURN VALUE" <> line
+        <> indent 8 (
+            if not (Text.null s) then
+              (pretty t <> hsep ["","-",""] <> pretty s) <> line
+            else pretty t )
+
+    fmtDescription = line
+      <> "DESCRIPTION" <> line
+      <> indent 8 ( case manDesc e of
+           Nothing -> pretty (manBrief e)
+           Just x  -> pretty x)
+      <> line
+
+    fmtSynopsis = case manSynopsis e of
+      [] -> mempty
+      _  ->
+           line
+        <> "SYNOPSIS"
+        <> line
+        <> vcat (fmap synEntry (manSynopsis e))
+        <> line
+
+    fmtExamples = case manExamples e of
+      [] -> mempty
+      es -> line
+        <> "EXAMPLES"
+        <> line
+        <> indent 8 ( vcat (fmap pretty es) )
+
+    synEntry (ManSynopsis (ManApply [])) =
+      indent 8 ( parens (pretty (manName e)) ) <> line
+
+    synEntry (ManSynopsis (ManApply xs)) = do
+      indent 8 do
+        parens (pretty (manName e) <+>
+         hsep [ pretty n | ManApplyArg t n <- xs ]  )
+         <> line
+         <> line
+         <> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ]
+
+pattern StringLike :: forall {c} . String -> Syntax c
+pattern StringLike e <- (stringLike -> Just e)
+
+pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
+pattern StringLikeList e <- (stringLikeList -> e)
+
+pattern BlobLike :: forall {c} . ByteString -> Syntax c
+pattern BlobLike s <- (blobLike -> Just s)
+
+pattern Nil :: forall {c} . Syntax c
+pattern Nil <- ListVal []
+
+
+
+class Display a where
+  display :: MonadIO m => a -> m ()
+
+instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
+  display = liftIO . print . pretty
+
+instance IsContext c => Display (Syntax c) where
+  display = \case
+    LitStrVal s -> liftIO $ TIO.putStr s
+    -- ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do
+    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
+    --   liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s)
+    -- ListVal [SymbolVal "blob", LitStrVal txt] -> do
+    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
+    --   liftIO $ print $ parens $ "blob:base58" <+> dquotes s
+    x           -> liftIO $ putStr (show $ pretty x)
+
+instance Display Text where
+  display = liftIO . TIO.putStr
+
+instance Display String where
+  display = liftIO . putStr
+
+display_ :: (MonadIO m, Show a) => a -> m ()
+display_ = liftIO . print
+
+{- HLINT ignore "Functor law" -}
+
+class IsContext c => MkSym c a where
+  mkSym :: a -> Syntax c
+
+instance IsContext c => MkSym c String where
+  mkSym s = Symbol noContext (Id $ Text.pack s)
+
+instance IsContext c => MkSym c Text where
+  mkSym s = Symbol noContext (Id s)
+
+instance IsContext c => MkSym c Id where
+  mkSym = Symbol noContext
+
+class IsContext c => MkStr c s where
+  mkStr :: s -> Syntax c
+
+instance IsContext c => MkStr c String where
+  mkStr s = Literal noContext $ LitStr (Text.pack s)
+
+instance IsContext c => MkStr c Text where
+  mkStr s = Literal noContext $ LitStr s
+
+mkBool :: forall c . IsContext c => Bool -> Syntax c
+mkBool v = Literal noContext (LitBool v)
+
+
+class IsContext c => MkForm c a where
+ mkForm :: a-> [Syntax c] -> Syntax c
+
+instance (IsContext c, MkSym c s) => MkForm c s where
+ mkForm s sy = List noContext ( mkSym @c s :  sy )
+
+mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
+mkList = List noContext
+
+isFalse :: forall c . IsContext c => Syntax c -> Bool
+isFalse = \case
+    Literal _ (LitBool False) -> True
+    ListVal [] -> True
+    _ -> False
+
+eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
+eatNil f = \case
+  Nil -> pure ()
+  x   -> void $ f x
+
+class IsContext c => MkInt c s where
+  mkInt :: s -> Syntax c
+
+instance (Integral i, IsContext c) => MkInt c i where
+  mkInt n = Literal noContext $ LitInt (fromIntegral n)
+
+class OptionalVal c b where
+  optional :: b -> Syntax c -> b
+
+instance IsContext c => OptionalVal c Int where
+  optional d = \case
+    LitIntVal x -> fromIntegral x
+    _           -> d
+
+hasKey :: IsContext c => Id -> [Syntax c] -> Maybe (Syntax c)
+hasKey k ss = headMay [ e | ListVal [SymbolVal z, e] <- ss, z == k]
+
+stringLike :: Syntax c -> Maybe String
+stringLike = \case
+  LitStrVal s -> Just $ Text.unpack s
+  SymbolVal (Id s) -> Just $ Text.unpack s
+  _ -> Nothing
+
+stringLikeList :: [Syntax c] -> [String]
+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
+
+pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c
+pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e]
+
+pattern LambdaArgs :: [Id] -> Syntax c
+pattern LambdaArgs a <- (lambdaArgList -> Just a)
+
+
+lambdaArgList :: Syntax c -> Maybe [Id]
+
+lambdaArgList (ListVal a) = sequence argz
+  where
+    argz = flip fmap a \case
+      (SymbolVal x) -> Just x
+      _             -> Nothing
+
+lambdaArgList _ = Nothing
+
+blobLike :: Syntax c -> Maybe ByteString
+blobLike = \case
+  LitStrVal s -> Just $ BS8.pack (Text.unpack s)
+  ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s)
+  _ -> Nothing
+
+pattern PairList :: [Syntax c] -> [Syntax c]
+pattern PairList es <- (pairList -> es)
+
+pairList :: [Syntax c ] -> [Syntax c]
+pairList syn = [ isPair s | s <- syn ] & takeWhile isJust & catMaybes
+
+optlist :: IsContext c => [Syntax c] -> [(Id, Syntax c)]
+optlist = reverse . go []
+  where
+    go acc ( SymbolVal i : b : rest ) = go ((i, b) : acc) rest
+    go acc [ SymbolVal i ] = (i, nil) : acc
+    go acc _ = acc
+
+
+isPair :: Syntax c -> Maybe (Syntax c)
+isPair = \case
+  e@(ListVal [_,_]) -> Just e
+  _ -> Nothing
+
+data BindAction c ( m :: Type -> Type)  =
+    BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
+  | BindValue  (Syntax c)
+
+data Bind c ( m :: Type -> Type)  = Bind
+  { bindMan         :: Maybe (Man AnsiStyle)
+  , bindAction      :: BindAction c m
+  } deriving (Generic)
+
+deriving newtype instance Hashable Id
+
+newtype NameNotBoundException =
+  NameNotBound Id
+  deriving stock Show
+  deriving newtype (Generic,Typeable)
+
+newtype NotLambda = NotLambda Id
+                    deriving stock Show
+                    deriving newtype (Generic,Typeable)
+
+instance Exception NotLambda
+
+data BadFormException c = BadFormException (Syntax c)
+                        | ArityMismatch (Syntax c)
+
+newtype TypeCheckError c = TypeCheckError (Syntax c)
+
+instance Exception (TypeCheckError C)
+
+newtype BadValueException = BadValueException String
+                            deriving stock Show
+                            deriving newtype (Generic,Typeable)
+
+instance Exception NameNotBoundException
+
+instance IsContext c => Show (BadFormException c) where
+  show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
+  show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy
+
+instance IsContext c => Show (TypeCheckError c) where
+  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
+
+instance Exception (BadFormException C)
+
+instance Exception BadValueException
+
+type Dict c m = HashMap Id (Bind c m)
+
+newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadReader (TVar (Dict c m))
+                                      )
+
+instance MonadTrans (RunM c) where
+  lift = RunM . lift
+
+newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a }
+                          deriving newtype ( Applicative
+                                           , Functor
+                                           , Monad
+                                           , MonadWriter (Dict c m)
+                                           )
+
+makeDict :: (IsContext c, Monad m) =>  MakeDictM c m () -> Dict c m
+makeDict w = execWriter ( fromMakeDict w )
+
+entry :: Dict c m  -> MakeDictM c m ()
+entry = tell
+
+hide :: MakeDictM c m ()
+hide = pure ()
+
+desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()
+desc txt = censor (HM.map setDesc)
+  where
+    w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) }
+    setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
+
+brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()
+brief txt = censor (HM.map setBrief)
+  where
+    w0 = mempty { manBrief = Just txt }
+    setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
+
+returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m ()
+returns tp txt = censor (HM.map setReturns)
+  where
+    w0 = mempty { manReturns = Just (ManReturns tp txt) }
+    setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x
+
+
+addSynopsis :: ManSynopsis -> Bind c m -> Bind c m
+addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x
+  where
+    updatedMan = case w of
+      Nothing -> mempty { manSynopsis = [synopsis] }
+      Just man -> man { manSynopsis = manSynopsis man <> [synopsis] }
+
+noArgs :: MakeDictM c m () -> MakeDictM c m ()
+noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply []))))
+
+arg :: Text -> Text -> ManApplyArg
+arg = ManApplyArg
+
+
+args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m ()
+args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList))))
+
+opt :: Doc a -> Doc a -> Doc a
+opt n d = n <+> "-" <+> d
+
+examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
+examples (ManExamples s) = censor (HM.map setExamples )
+  where
+    ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
+    ex0 = mempty { manExamples = [ex] }
+    setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
+
+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 ) | isPrefixOf "-"  x =  go ( x : acc ) rest
+    go acc ( x : rest ) | isPrefixOf "--" x =  go ( x : acc ) rest
+    go acc ( x : rest ) = go ( x : acc ) rest
+    go acc [] = emit acc
+
+    emit = S.yield . reverse
+
+applyLambda :: forall c m . ( IsContext c
+                            , MonadUnliftIO m
+                            , Exception (BadFormException c)
+                            )
+            => [Id]
+            -> Syntax c
+            -> [Syntax c]
+            -> RunM c m (Syntax c)
+applyLambda decl body args = do
+
+  when (length decl /= length args) do
+    throwIO (ArityMismatch @c nil)
+
+  ev <- mapM eval args
+  tv <- ask
+  d0 <- readTVarIO tv
+
+  forM_ (zip decl ev) $ \(n,v) -> do
+    bind n v
+
+  e <- eval body
+
+  atomically $ writeTVar tv d0
+  pure e
+
+apply_ :: forall c m . ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      )
+      => Syntax c
+      -> [Syntax c]
+      -> RunM c m (Syntax c)
+
+apply_ s args = case s of
+  ListVal [SymbolVal "builtin:lambda", SymbolVal n]  -> apply n args
+  SymbolVal   what  -> apply what args
+  Lambda d body     -> applyLambda d body args
+  e -> throwIO $ BadFormException @c s
+
+apply :: forall c m . ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      )
+      => Id
+      -> [Syntax c]
+      -> RunM c m (Syntax c)
+apply name args' = do
+  -- notice $ red "APPLY" <+> pretty name
+  what <- ask >>=  readTVarIO <&> HM.lookup name
+
+  case bindAction <$> what of
+    Just (BindLambda e) -> mapM eval args' >>= e
+
+    Just (BindValue (Lambda argz body) )  -> do
+      applyLambda argz body args'
+
+    Just (BindValue _) -> do
+      throwIO (NotLambda name)
+
+    Nothing -> throwIO (NameNotBound name)
+
+bind :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     )
+     => Id
+     -> Syntax c
+     -> RunM c m ()
+bind name expr = do
+  t <- ask
+
+  what <- case expr of
+           ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do
+             m <- readTVarIO t
+             HM.lookup n m & maybe (throwIO (NameNotBound n)) pure
+
+           e -> pure $ Bind mzero (BindValue e)
+
+  atomically do
+    modifyTVar t (HM.insert name what)
+
+bindBuiltins ::  forall c m . ( IsContext c
+                              , MonadUnliftIO m
+                              , Exception (BadFormException c)
+                              )
+            => Dict c m
+            -> RunM c m ()
+
+bindBuiltins  dict = do
+  t <- ask
+  atomically do
+    modifyTVar t (<> dict)
+
+eval :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     ) => Syntax c -> RunM c m (Syntax c)
+eval syn = handle (handleForm syn) $ do
+
+    dict <- ask >>= readTVarIO
+
+    case syn of
+
+      ListVal [ w, SymbolVal ".", b] -> do
+        pure  $ mkList  [w, b]
+
+      ListVal [ SymbolVal "quot", ListVal b] -> do
+        pure  $ mkList  b
+
+      ListVal [SymbolVal "define", SymbolVal what, e] -> do
+        ev <- eval e
+        bind what ev>> pure nil
+
+      ListVal [SymbolVal "lambda", arglist, body] -> do
+        pure $ mkForm @c "lambda" [ arglist, body ]
+
+      ListVal [SymbolVal "define", LambdaArgs (name : args), e] -> do
+        bind name ( mkForm @c  "lambda" [ mkList [ mkSym s | s <- args], e ] )
+        pure nil
+
+      ListVal [SymbolVal "false?", e'] -> do
+        e <- eval e'
+        pure $ if isFalse e then mkBool True else mkBool False
+
+      ListVal [SymbolVal "if", w, e1, e2] -> do
+        what <- eval w
+        if isFalse what then eval e2 else eval e1
+
+      ListVal (SymbolVal "begin" : what) -> do
+        evalTop what
+
+      e@(ListVal (SymbolVal "blob" : what)) -> do
+        pure e
+        -- evalTop what
+
+      lc@(ListVal (Lambda decl body : args))  -> do
+        applyLambda decl body args
+
+      ListVal (SymbolVal name : args') -> do
+        apply name args'
+
+      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
+        pure (mkSym @c (Text.drop 1 s))
+
+      SymbolVal name | HM.member name dict -> do
+        let what = HM.lookup name dict
+                     & maybe (BindValue (mkSym name)) bindAction
+
+        case what of
+          BindValue e  -> pure e
+          BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
+
+      e@(SymbolVal name) | not (HM.member name dict) -> do
+        pure e
+
+      e@Literal{} -> pure e
+
+      e -> throwIO $ BadFormException @c e
+
+  where
+    handleForm syn = \case
+      (BadFormException _  :: BadFormException c) -> do
+        throwIO (BadFormException syn)
+      (ArityMismatch s  :: BadFormException c) -> do
+        throwIO (ArityMismatch syn)
+
+runM :: forall c m a. ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      ) => Dict c m -> RunM c m a ->  m a
+runM  d  m = do
+  tvd <- newTVarIO d
+  runReaderT (fromRunM m) tvd
+
+run :: forall c m . ( IsContext c
+                    , MonadUnliftIO m
+                    , Exception (BadFormException c)
+                    ) => Dict c m -> [Syntax c] -> m (Syntax c)
+run d sy = do
+  tvd <- newTVarIO d
+  lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
+
+evalTop :: forall c m . ( IsContext c
+                        , MonadUnliftIO m
+                        , Exception (BadFormException c))
+     => [Syntax c]
+     -> RunM c m (Syntax c)
+evalTop syn = lastDef nil <$> mapM eval syn
+
+bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
+bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
+  where
+    man = Just $ mempty { manName = Just (manNameOf n) }
+
+bindValue :: Id -> Syntax c -> Dict c m
+bindValue n e = HM.singleton n (Bind mzero (BindValue e))
+
+nil :: forall c . IsContext c => Syntax c
+nil = List noContext []
+
+nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
+nil_ m w = m w >> pure (List noContext [])
+
+fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
+fixContext = go
+  where
+    go = \case
+      List    _ xs -> List noContext (fmap go xs)
+      Symbol  _ w  -> Symbol noContext w
+      Literal _ l  -> Literal noContext l
+
+
+fmt :: Syntax c -> Doc ann
+fmt = \case
+  LitStrVal x -> pretty $ Text.unpack x
+  x -> pretty x
+
+internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
+internalEntries = do
+
+    entry $ bindValue "false"      (mkBool False)
+    entry $ bindValue "true"       (mkBool True)
+    entry $ bindValue "chr:semi"   (mkStr ";")
+    entry $ bindValue "chr:tilda"  (mkStr "~")
+    entry $ bindValue "chr:colon"  (mkStr ":")
+    entry $ bindValue "chr:comma"  (mkStr ",")
+    entry $ bindValue "chr:q"      (mkStr "'")
+    entry $ bindValue "chr:minus"  (mkStr "-")
+    entry $ bindValue "chr:dq"     (mkStr "\"")
+    entry $ bindValue "chr:lf"     (mkStr "\n")
+    entry $ bindValue "chr:cr"     (mkStr "\r")
+    entry $ bindValue "chr:tab"    (mkStr "\t")
+    entry $ bindValue "chr:space"  (mkStr " ")
+
+    brief "concatenates list of string-like elements into a string"
+      $ args [arg "list" "(list ...)"]
+      $ args [arg "..." "..."]
+      $ returns "string" ""
+      $ examples [qc|
+        (concat a b c d)
+        abcd|]
+      $ examples [qc|
+        (concat 1 2 3 4 5)
+        12345|]
+
+      $ entry $ bindMatch "concat" $ \syn -> do
+
+        case syn of
+          [ListVal xs] -> do
+            pure $ mkStr ( show $ hcat (fmap fmt xs) )
+
+          xs -> do
+            pure $ mkStr ( show $ hcat (fmap fmt xs) )
+
+    brief "creates a list of elements"
+      $ args [arg "..." "..."]
+      $ returns "list" ""
+      $ examples [qc|
+(list 1 2 3 fuu bar "baz")
+(1 2 3 fuu bar "baz")
+      |]
+      $ entry $ bindMatch "list" $ \case
+        es -> do
+          pure $ mkList es
+
+    entry $ bindMatch "dict" $ \case
+      (pairList -> es@(_:_)) -> do
+        pure $ mkForm "dict" es
+      [a, b] -> do
+        pure $ mkForm "dict" [ mkList [a, b] ]
+      _ -> throwIO (BadFormException @C nil)
+
+    brief "creates a dict from a linear list of string-like items"
+      $ args [arg "list-of-terms" "..."]
+      $ desc (    "macro; syntax sugar" <> line
+               <> "useful for creating function args" <> line
+               <> "leftover records are skipped"
+             )
+      $ returns "dict" ""
+      $ examples [qc|
+[kw a 1 b 2 c 3]
+(dict (a 1) (b 2) (c 3))
+
+[kw a]
+(dict (a ()))
+
+[kw a b]
+(dict (a b))
+
+[kw 1 2 3]
+(dict)
+
+[kw a b c]
+(dict (a b) (c ()))
+      |]
+      $ entry $ bindMatch "kw" $ \syn -> do
+         let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
+         pure $ mkForm "dict" wat
+
+    entry $ bindMatch "iterate" $ nil_ $ \syn -> do
+      case syn of
+        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
+          mapM_ (apply @c fn . List.singleton) rs
+
+        [Lambda decl body,  ListVal args]  -> do
+          mapM_ (applyLambda decl body . List.singleton) args
+
+        _ -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "repeat" $ nil_ $ \case
+      [LitIntVal n, Lambda [] b] -> do
+        replicateM_ (fromIntegral n) (applyLambda [] b [])
+
+      [LitIntVal n, e@(ListVal _)] -> do
+        replicateM_ (fromIntegral n) (eval e)
+
+      z ->
+        throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "map" $ \syn -> do
+      case syn of
+        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
+          mapM (apply @c fn . List.singleton) rs
+            <&> mkList
+
+        [Lambda decl body,  ListVal args]  -> do
+          mapM (applyLambda decl body . List.singleton) args
+            <&> mkList
+
+        _ -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "head" $ \case
+      [ ListVal es ] -> pure (head es)
+      _ -> throwIO (TypeCheckError @C nil)
+
+    brief "get tail of list"
+      $ args [arg "list" "list"]
+      $ desc "nil if the list is empty; error if not list"
+      $ examples [qc|
+      (tail [list 1 2 3])
+      (2 3)
+      (tail [list])
+      |]
+      $ entry $ bindMatch "tail" $ \case
+        [] -> pure nil
+        [ListVal []] -> pure nil
+        [ListVal es] -> pure $ mkList  (tail es)
+        _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "lookup" $ \case
+      [s, ListVal (SymbolVal "dict" : es) ] -> do
+        let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
+        pure val
+
+      [StringLike s, ListVal [] ] -> do
+        pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+    brief "returns current unix time"
+      $ returns "int" "current unix time in seconds"
+      $ noArgs
+      $ entry $ bindMatch "now" $ \case
+        [] -> mkInt . round <$> liftIO getPOSIXTime
+        _  -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "display" $ nil_ \case
+      [ sy ] -> display sy
+      ss     -> display (mkList ss)
+
+    brief "prints new line character to stdout"
+      $ entry $ bindMatch "newline" $ nil_ $ \case
+          [] -> liftIO (putStrLn "")
+          _  -> throwIO (BadFormException @c nil)
+
+    brief "prints a list of terms to stdout"
+      $ entry $ bindMatch "print" $ nil_ $ \case
+          [ sy ] -> display sy
+          ss     -> mapM_ display ss
+
+    entry $ bindMatch "println" $ nil_ $ \case
+      [ sy ] -> display sy >> liftIO (putStrLn "")
+      ss     -> mapM_ display ss >> liftIO (putStrLn "")
+
+    entry $ bindMatch "str:read-stdin" $ \case
+      [] -> liftIO getContents <&> mkStr @c
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "str:put" $ nil_ $ \case
+      [LitStrVal s] -> liftIO $ TIO.putStr s
+      _ -> throwIO (BadFormException @c nil)
+
+    brief "reads file as a string" do
+      entry $ bindMatch "str:read-file" $ \case
+        [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
+
+        _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "str:save" $ nil_ \case
+      [StringLike fn, StringLike what] ->
+        liftIO (writeFile fn what)
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindValue "space" $ mkStr " "
+
+    entry $ bindMatch "parse-top" $ \case
+
+      [SymbolVal w, LitStrVal s] -> do
+        pure $  parseTop s & either (const nil) (mkForm w . fmap fixContext)
+
+      [LitStrVal s] -> do
+        pure $  parseTop s & either (const nil) (mkList . fmap fixContext)
+
+      _ -> throwIO (BadFormException @c nil)
+
+    let atomFrom = \case
+          [StringLike s] -> pure (mkSym s)
+          [e]            -> pure (mkSym $ show $ pretty e)
+          _ -> throwIO (BadFormException @c nil)
+
+    brief "type of argument"
+      $ args [arg "term" "term"]
+      $ returns "symbol" "type"
+      $ entry $ bindMatch "type" \case
+        [ListVal _]    -> pure $ mkSym "list"
+        [SymbolVal _]  -> pure $ mkSym "symbol"
+        [LitStrVal _]  -> pure $ mkSym "string"
+        [LitIntVal _]  -> pure $ mkSym "int"
+        [LitScientificVal _] -> pure $ mkSym "float"
+        [LitBoolVal _] -> pure $ mkSym "bool"
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "creates a symbol from argument"
+      $ args [arg "any-term" "term"]
+      $ returns "symbol" ""
+      do
+        entry $ bindMatch "sym"  atomFrom
+        entry $ bindMatch "atom" atomFrom
+
+    brief "compares two terms" $
+      args [arg "term" "a", arg "term" "b"] $
+      returns "boolean" "#t if terms are equal, otherwise #f" $
+        entry $ bindMatch "eq?" $ \case
+          [a, b] -> do
+            pure $ if a == b then mkBool True else mkBool False
+          _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "length" $ \case
+      [ListVal es] -> pure $ mkInt (length es)
+      [StringLike es] -> pure $ mkInt (length es)
+      _ -> pure $ mkInt 0
+
+    entry $ bindMatch "nil?" $ \case
+      [ListVal []] -> pure $ mkBool True
+      _ -> pure $ mkBool False
+
+    entry $ bindMatch "not" $ \case
+      [w] -> do
+        pure $ if isFalse w then mkBool True else mkBool False
+      _ -> throwIO (BadFormException @c nil)
+
+    brief "get system environment"
+     $ args []
+     $ args [ arg "string" "string" ]
+     $ returns "env" "single var or dict of all vars"
+     $ examples [qc|
+      (env HOME)
+      /home/user
+
+      (env)
+      (dict
+         (HOME "/home/user") ... (CC "gcc") ...)
+     |]
+     $ entry $ bindMatch "env" $ \case
+         [] -> do
+           s <- liftIO getEnvironment
+           pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ]
+
+         [StringLike s] -> do
+           liftIO (lookupEnv s)
+              <&> maybe nil mkStr
+         _ -> throwIO (BadFormException @c nil)
+
+    -- FIXME: we-need-opaque-type
+    entry $ bindMatch "blob:read-stdin" $ \case
+      [] -> do
+        blob <- liftIO BS8.getContents <&> BS8.unpack
+        pure (mkForm "blob" [mkStr @c blob])
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:read-file" $ \case
+      [StringLike fn] -> do
+        blob <- liftIO (BS8.readFile fn) <&> BS8.unpack
+        pure (mkForm "blob" [mkStr @c blob])
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:save" $ nil_ $ \case
+      [StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack
+        liftIO $ BS8.writeFile fn s
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "blob:put" $ nil_ $ \case
+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack
+        liftIO $ BS8.putStr s
+
+      _ -> throwIO (BadFormException @c nil)
+
+

hbs2-cli/lib/HBS2/CLI.hs

@@ -0,0 +1 @@
+module HBS2.CLI where

hbs2-cli/lib/HBS2/CLI/Bind.hs

@@ -0,0 +1,4 @@
+module HBS2.CLI.Bind where
+
+import HBS2.CLI.Prelude
+

hbs2-cli/lib/HBS2/CLI/Prelude.hs

@@ -0,0 +1,26 @@
+module HBS2.CLI.Prelude
+  ( module HBS2.Prelude.Plated
+  , module HBS2.OrDie
+  , module UnliftIO
+  , module Data.Config.Suckless
+  , module Data.HashMap.Strict
+  , module Control.Monad.Reader
+  , module HBS2.System.Logger.Simple.ANSI
+  , module HBS2.Misc.PrettyStuff
+  , qc,qq,q
+  , Generic
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.System.Logger.Simple.ANSI
+import HBS2.Misc.PrettyStuff
+
+import Data.HashMap.Strict
+import Data.Config.Suckless
+
+import Control.Monad.Reader
+import UnliftIO
+
+import Text.InterpolatedString.Perl6 (qc,q,qq)
+

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

@@ -0,0 +1,9 @@
+{-# Language UndecidableInstances #-}
+module HBS2.CLI.Run
+  ( module HBS2.CLI.Run.Internal
+  ) where
+
+import HBS2.CLI.Run.Internal
+
+
+

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

@@ -0,0 +1,142 @@
+module HBS2.CLI.Run.GroupKey
+  ( module HBS2.CLI.Run.GroupKey
+  , loadGroupKey
+  ) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+
+import HBS2.Data.Types.Refs
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
+import HBS2.Base58
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.GroupKey as G
+import HBS2.Net.Auth.GroupKeySymm as Symm
+import HBS2.Storage
+
+
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+
+import Data.Text qualified as Text
+import Data.ByteString.Lazy.Char8 as LBS8
+import Data.ByteString.Lazy as LBS
+import Data.ByteString.Char8 as BS8
+import Data.HashMap.Strict qualified as HM
+import Control.Monad.Except
+import Codec.Serialise
+
+{- HLINT ignore "Functor law" -}
+
+
+groupKeyEntries :: forall c m . ( MonadUnliftIO m
+                                , IsContext c
+                                , HasClientAPI StorageAPI UNIX m
+                                , HasStorage m
+                                ) => MakeDictM c m ()
+groupKeyEntries = do
+
+  entry $ bindMatch "hbs2:groupkey:load" $ \case
+      [HashLike h] -> do
+        sto <- getStorage
+
+        gk <- loadGroupKey h
+                >>= orThrowUser "can not load groupkey"
+
+        pure $ mkStr (show $ pretty $ AsGroupKeyFile gk)
+
+      _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:groupkey:store" $ \case
+      [LitStrVal s] -> do
+        let lbs = LBS8.pack (Text.unpack s)
+        gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+                `orDie` "invalid group key"
+
+        sto <- getStorage
+        ha <- writeAsMerkle sto (serialise gk)
+        pure $ mkStr (show $ pretty ha)
+
+      _ -> throwIO $ BadFormException @C nil
+
+
+-- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \
+--             [list [remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8] \
+--                   [add . 5sJXsw7qhmq521hwhE67jYvrD6ZNVazc89rFwfWaQPyY]] ]
+--
+  entry $ bindMatch "hbs2:groupkey:update" $ \case
+    [LitStrVal s, ListVal ins] -> do
+
+      sto <- getStorage
+
+      let lbs = LBS8.pack (Text.unpack s)
+      gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+              `orDie` "invalid group key"
+
+      gk1 <- modifyGroupKey gk ins
+
+      pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1)
+
+    _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
+    case syn of
+      [ListVal (StringLikeList keys)] -> do
+        s <- groupKeyFromKeyList  keys
+                <&> AsGroupKeyFile
+                <&> show . pretty
+
+        pure $ mkStr s
+
+      StringLikeList keys -> do
+        s <- groupKeyFromKeyList  keys
+                <&> AsGroupKeyFile
+                <&> show . pretty
+
+        pure $ mkStr s
+
+      _ -> throwIO $ BadFormException @C nil
+
+
+  entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do
+    case syn of
+      [LitStrVal s] -> do
+
+        let lbs = LBS8.pack (Text.unpack s)
+        gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+                `orDie` "invalid group key"
+
+        let rcpt = recipients gk & HM.keys & fmap (mkStr . show . pretty . AsBase58)
+
+        pure $ mkList @c rcpt
+
+      _ -> throwIO $ BadFormException @C nil
+
+
+  entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
+    [BlobLike bs] -> do
+
+      sto <- getStorage
+
+      let lbs = LBS.fromStrict bs
+
+      seb <- pure (deserialiseOrFail lbs)
+               `orDie` "invalid SmallEncryptedBlock"
+
+      decrypted <- G.decryptBlock sto seb
+
+      pure $ mkForm @c "blob" [mkStr (BS8.unpack decrypted)]
+
+    _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:groupkey:encrypt-block" $ \case
+    [StringLike gkh, BlobLike what] -> do
+        sto <- getStorage
+        gk <- loadGroupKey (fromString gkh)
+                `orDie` "can't load group key"
+        seb <- G.encryptBlock sto gk what
+        pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))]
+
+    _ -> throwIO $ BadFormException @C nil
+

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

@@ -0,0 +1,28 @@
+module HBS2.CLI.Run.Help where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import Data.HashMap.Strict qualified as HM
+import Data.List qualified as List
+import Data.Text qualified as Text
+
+helpEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
+helpEntries = do
+
+  entry $ bindMatch "help" $ nil_ $ \syn -> do
+
+      display_ $ "hbs2-cli tool" <> line
+
+      case syn of
+
+        [StringLike "--documented"] -> do
+          helpList True Nothing
+
+        (StringLike p : _) -> do
+          helpList False (Just p)
+
+        HelpEntryBound what -> helpEntry what
+
+        _ -> helpList False Nothing
+

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

@@ -0,0 +1,213 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.CLI.Run.Internal
+  ( module HBS2.CLI.Run.Internal
+  , module SC
+  ) where
+
+import HBS2.CLI.Prelude
+
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.Client.StorageClient
+
+import Data.Config.Suckless.Script qualified as SC
+import Data.Config.Suckless.Script hiding (internalEntries)
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Data.ByteString.Char8 qualified as BS8
+import Data.Text qualified as Text
+import Lens.Micro.Platform
+
+pattern HashLike:: forall {c} . HashRef -> Syntax c
+pattern HashLike x <- (
+  \case
+    StringLike s -> fromStringMay @HashRef s
+    _            -> Nothing
+      -> Just x )
+
+pattern SignPubKeyLike :: forall {c} . (PubKey 'Sign 'HBS2Basic) -> Syntax c
+pattern SignPubKeyLike x <- (
+  \case
+    StringLike s -> fromStringMay s
+    _            -> Nothing
+      -> Just x )
+
+
+data HBS2CliEnv =
+  HBS2CliEnv
+  { _peerSocket      :: FilePath
+  , _peerRefChanAPI  :: ServiceCaller RefChanAPI UNIX
+  , _peerRefLogAPI   :: ServiceCaller RefLogAPI UNIX
+  , _peerLwwRefAPI   :: ServiceCaller LWWRefAPI UNIX
+  , _peerPeerAPI     :: ServiceCaller PeerAPI UNIX
+  , _peerStorageAPI  :: ServiceCaller StorageAPI UNIX
+  }
+
+makeLenses 'HBS2CliEnv
+
+newtype HBS2Cli m a = HBS2Cli { fromHBS2Cli :: ReaderT (TVar (Maybe HBS2CliEnv)) m a }
+                      deriving newtype ( Applicative
+                                       , Functor
+                                       , Monad
+                                       , MonadIO
+                                       , MonadUnliftIO
+                                       , MonadReader (TVar (Maybe HBS2CliEnv))
+                                       )
+
+withHBS2Cli :: TVar (Maybe HBS2CliEnv) -> HBS2Cli m a -> m a
+withHBS2Cli env action = runReaderT (fromHBS2Cli action) env
+
+recover :: HBS2Cli IO a -> HBS2Cli IO a
+recover what = do
+  catch what $ \case
+    PeerNotConnectedException -> do
+
+      soname <- detectRPC
+                  `orDie` "can't locate hbs2-peer rpc"
+
+      flip runContT pure do
+
+        client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+                    >>= orThrowUser ("can't connect to" <+> pretty soname)
+
+        void $ ContT $ withAsync $ runMessagingUnix client
+
+        peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+        refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+        refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
+        storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+        lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
+
+        -- let sto = AnyStorage (StorageClient storageAPI)
+
+        let endpoints = [ Endpoint @UNIX  peerAPI
+                        , Endpoint @UNIX  refLogAPI
+                        , Endpoint @UNIX  refChanAPI
+                        , Endpoint @UNIX  lwwAPI
+                        , Endpoint @UNIX  storageAPI
+                        ]
+
+        void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+        let env = Just (HBS2CliEnv soname refChanAPI refLogAPI lwwAPI peerAPI storageAPI)
+        tv <- newTVarIO env
+
+        liftIO $ withHBS2Cli tv what
+
+
+runHBS2Cli :: MonadUnliftIO m => HBS2Cli m a -> m a
+runHBS2Cli action = do
+   noenv <- newTVarIO Nothing
+   withHBS2Cli  noenv action
+
+data PeerException =
+  PeerNotConnectedException
+  deriving stock (Show, Typeable)
+
+instance Exception PeerException
+
+
+instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where
+  getClientAPI = lift (getClientAPI @api @proto)
+
+instance (MonadUnliftIO m, HasStorage m) => HasStorage  (RunM c m) where
+  getStorage = lift getStorage
+
+instance (MonadUnliftIO m, HasClientAPI StorageAPI UNIX m, HasStorage m) => HasStorage (ContT a (RunM c m)) where
+  getStorage = lift getStorage
+
+instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
+  getClientAPI = lift $ getClientAPI @api @proto
+
+instance MonadUnliftIO m => HasClientAPI RefChanAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerRefChanAPI what
+
+instance MonadUnliftIO m => HasClientAPI RefLogAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerRefLogAPI what
+
+instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerPeerAPI what
+
+instance MonadUnliftIO m => HasClientAPI StorageAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerStorageAPI what
+
+instance MonadUnliftIO m => HasClientAPI LWWRefAPI UNIX (HBS2Cli m) where
+  getClientAPI = do
+    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
+    pure $ view peerLwwRefAPI what
+
+instance MonadUnliftIO m => HasStorage (HBS2Cli m) where
+  getStorage = getClientAPI @StorageAPI @UNIX  <&> AnyStorage . StorageClient
+
+internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
+internalEntries = do
+    SC.internalEntries
+
+    entry $ bindMatch "blob:base58" $ \case
+      [LitStrVal t] -> do
+        bs <- pure (Text.unpack t & BS8.pack & fromBase58)
+               `orDie` "invalid base58"
+              <&> BS8.unpack
+
+        pure (mkForm "blob" [mkStr @c bs])
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+    let decodeB58 t = do
+          pure (Text.unpack t & BS8.pack & fromBase58)
+            `orDie` "invalid base58"
+
+    let decodeAndOut t = do
+          liftIO $ BS8.putStr =<< decodeB58 t
+
+    entry $ bindMatch "base58:encode" $ \case
+      [LitStrVal t] -> do
+        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
+        pure (mkForm "blob:base58" [mkStr @c s])
+
+      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
+        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
+        pure (mkForm "blob:base58" [mkStr @c s])
+
+      e -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "base58:decode" $ \case
+
+      [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do
+        s <- decodeB58 t <&> BS8.unpack
+        pure $ mkForm "blob" [mkStr @c s]
+
+      e -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "base58:put" $ nil_ $ \case
+      [ListVal [SymbolVal "blob:base58", LitStrVal t]] ->
+        decodeAndOut t
+
+      [LitStrVal t] -> decodeAndOut t
+
+      e -> throwIO (BadFormException @c nil)
+
+

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

@@ -0,0 +1,107 @@
+module HBS2.CLI.Run.Internal.GroupKey
+  ( module HBS2.CLI.Run.Internal.GroupKey
+  , SmallEncryptedBlock(..)
+  ) where
+
+import HBS2.CLI.Prelude hiding (mapMaybe)
+import HBS2.CLI.Run.Internal
+
+import HBS2.Base58
+import HBS2.Hash
+import HBS2.Storage
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SmallEncryptedBlock
+import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
+import HBS2.KeyMan.Keys.Direct
+import HBS2.Net.Auth.GroupKeySymm as Symm
+
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Except
+import Codec.Serialise
+import Data.ByteString (ByteString)
+
+groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic)
+groupKeyFromKeyList ks = do
+  let members = mapMaybe (fromStringMay @(PubKey 'Encrypt 'HBS2Basic)) ks
+  Symm.generateGroupKey @'HBS2Basic Nothing members
+
+
+encryptBlock :: (MonadUnliftIO m, Serialise t)
+             => AnyStorage
+             -> GroupKey 'Symm 'HBS2Basic
+             -> t
+             -> m (SmallEncryptedBlock t)
+
+encryptBlock sto gk x = do
+
+  let HbSyncHash non = hashObject (serialise x)
+
+  gks <- runKeymanClient (extractGroupKeySecret gk)
+           >>= orThrowUser "can't extract group key secret"
+
+  Symm.encryptBlock sto gks (Right gk) (Just non) x
+
+decryptBlock :: (MonadUnliftIO m, Serialise t)
+             => AnyStorage
+             -> SmallEncryptedBlock t
+             -> m t
+decryptBlock sto seb = do
+  let find gk = runKeymanClient (extractGroupKeySecret gk)
+
+  -- FIXME: improve-error-diagnostics
+  runExceptT (Symm.decryptBlock sto find seb)
+     >>= orThrowUser "can't decrypt block"
+
+loadGroupKey :: ( IsContext c
+                , MonadUnliftIO m
+                , HasStorage m
+                , HasClientAPI StorageAPI UNIX m
+                ) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic))
+loadGroupKey h = do
+
+  flip runContT pure do
+    sto <- getStorage
+
+    raw <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h)))
+            <&> either (const Nothing) Just
+
+    bs <- ContT (maybe1 raw (pure Nothing))
+
+    let gk = deserialiseOrFail bs
+              & either (const Nothing) Just
+
+    pure gk
+
+modifyGroupKey :: (IsContext c, MonadUnliftIO m)
+               => GroupKey 'Symm 'HBS2Basic
+               -> [Syntax c]
+               -> m (GroupKey 'Symm HBS2Basic)
+modifyGroupKey gk ins = do
+
+  gks <- runKeymanClient do
+          extractGroupKeySecret gk
+         `orDie` "can't extract group key secret"
+
+  let r = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k
+                    | ListVal [SymbolVal "remove", StringLike k] <- ins
+                    ] & HS.fromList
+
+  let a = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k
+                    | ListVal [SymbolVal "add", StringLike k] <- ins
+                    ] & HS.fromList
+
+  let x = recipients gk & HM.keysSet
+
+  let new = x `HS.difference` r `mappend` a & HS.toList
+
+  generateGroupKey @'HBS2Basic (Just gks) new
+
+

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

@@ -0,0 +1,59 @@
+module HBS2.CLI.Run.Internal.KeyMan where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Hash
+import HBS2.System.Dir
+import HBS2.Net.Auth.Credentials
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.State
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Either
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text.IO qualified as TIO
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+
+
+
+keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c]
+keymanGetConfig = do
+    (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed)
+
+    let conf = TE.decodeUtf8 (LBS.toStrict lbs)
+                 & parseTop
+                 & fromRight mempty
+
+    pure $ fmap fixContext conf
+
+keymanUpdate :: MonadUnliftIO m => m ()
+keymanUpdate = do
+  void $ runProcess (shell [qc|hbs2-keyman update|])
+
+keymanNewCredentials :: MonadUnliftIO m => Maybe String -> Int -> m (PubKey 'Sign 'HBS2Basic)
+keymanNewCredentials suff n = do
+  conf <- keymanGetConfig @C
+
+  path <- [ p
+          | ListVal [SymbolVal "default-key-path", StringLike p] <- conf
+          ] & headMay & orThrowUser "default-key-path not set"
+
+  creds <- newCredentialsEnc @'HBS2Basic n
+
+  let s = show $ pretty $ AsCredFile (AsBase58 creds)
+
+  let psk = view peerSignPk creds
+
+  let fpath = path </> show (pretty (AsBase58 psk) <> "-" <> pretty suff <> ".key")
+
+  liftIO $ writeFile fpath s
+
+  keymanUpdate
+
+  pure psk
+

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

@@ -0,0 +1,117 @@
+module HBS2.CLI.Run.Internal.Merkle where
+
+import HBS2.CLI.Prelude
+import HBS2.Defaults
+import HBS2.CLI.Run.Internal
+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.Merkle
+import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.Net.Auth.Schema()
+
+import Codec.Serialise
+import Data.ByteString.Lazy qualified as LBS
+import Data.HashMap.Strict qualified as HM
+import Data.Text qualified as Text
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Except
+
+--FIXME: move-somewhere-else
+getGroupKeyHash :: ( IsContext c
+                   , MonadUnliftIO m
+                   , HasStorage m
+                   , HasClientAPI StorageAPI UNIX m
+                   )
+                => HashRef
+                -> RunM c m (Maybe HashRef, MTreeAnn [HashRef])
+getGroupKeyHash h = do
+  flip runContT pure do
+    sto <- getStorage
+
+    headBlock <- getBlock sto (fromHashRef h)
+                   >>= orThrowUser  "no-block"
+                   <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                   >>= orThrowUser  "invalid block format"
+
+    case _mtaCrypt headBlock of
+      (EncryptGroupNaClSymm hash _) ->
+        pure $ (Just $ HashRef hash, headBlock)
+      _ -> pure (Nothing, headBlock)
+
+-- TODO: client-api-candidate
+createTreeWithMetadata :: (MonadUnliftIO m)
+                       => AnyStorage
+                       -> Maybe (GroupKey 'Symm 'HBS2Basic)
+                       -> HashMap Text Text
+                       -> LBS.ByteString
+                       -> m (Either OperationError HashRef)
+createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do
+
+    let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v) | (k,v) <- HM.toList meta ]
+               & show & Text.pack
+
+    case mgk of
+      Nothing -> Right <$> createSimpleTree mt
+      Just gk -> createEncryptedTree gk mt
+
+  where
+    createSimpleTree mt = do
+        t0 <- writeAsMerkle sto lbs
+                >>= getBlock sto
+                >>= orThrowUser "can't read merkle tree just written"
+                <&> deserialiseOrFail @(MTree [HashRef])
+                >>= orThrowUser "merkle tree corrupted/invalid"
+
+        let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0
+
+        putBlock sto (serialise mann)
+          >>= orThrowUser "can't write tree"
+          <&> HashRef
+
+    -- FIXME: support-encryption
+    createEncryptedTree gk mt = do
+      -- 1. find key
+      mgks <- runKeymanClient do
+                extractGroupKeySecret gk
+
+      gks <- orThrowUser "can't get groupkey's secret" mgks
+
+      -- FIXME: consider-other-nonce-calculation
+      --   надо считать начальный нонс (от чего / как?)
+      --   нонс: да так-то пофиг от чего, но:
+      --     если брать рандомные места в байтстроке --
+      --     она зафорсится
+      --     что вообще зависит от начального нонса:
+      --       если в файл будет допись в конец, то
+      --       "старые" блоки останутся такими же, как были
+      --       что хорошо для дедуплицирования, но
+      --       потенциально это менее безопасно.
+      --   можно еще с метаданными похэшировать, тогда
+      --   нонс будет более уникальный; но поменялись метаданные -- поменялось всё
+      let s0 = LBS.take ( 1024 * 1024 ) lbs
+
+      let (HbSyncHash nonce) = hashObject @HbSync s0
+      -- куда-то девать зашифрованные метаданные
+      --
+      let segments = readChunkedBS lbs defBlockSize
+
+      seb <- G.encryptBlock sto gk (ShortMetadata mt)
+
+      hmeta <- putBlock sto (serialise seb)
+                 >>= orThrowUser "can't put block"
+
+      let source = ToEncryptSymmBS gks (Right gk) nonce segments  (AnnHashRef hmeta) Nothing
+
+      runExceptT $ writeAsMerkle sto source <&> HashRef
+
+

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

@@ -0,0 +1,51 @@
+module HBS2.CLI.Run.KeyMan
+  (keymanEntries) where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Hash
+import HBS2.System.Dir
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.State
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Either
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text.IO qualified as TIO
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+
+
+keymanEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
+keymanEntries = do
+  entry $ bindMatch "hbs2:keyman:list" $ nil_ \case
+    _ -> do
+      void $ runKeymanClient  $ KeyManClient $ do
+        k <- listKeys
+        display_ $ vcat (fmap pretty k)
+
+  entry $ bindMatch "hbs2:keyman:update" $ nil_ $ \_ -> do
+    keymanUpdate
+
+  entry $ bindMatch "hbs2:keyman:config" $ \_ -> do
+    mkForm  "dict" <$> keymanGetConfig
+
+  entry $ bindMatch "hbs2:keyman:keys:add" $ \case
+    [ LitStrVal ke ] -> do
+      conf <- keymanGetConfig @C
+      let path = head [ s | ListVal [ SymbolVal "default-key-path", StringLike s ] <- conf ]
+      mkdir path
+      let n =  hashObject @HbSync (serialise ke) & pretty & show
+      let fname = n `addExtension` ".key"
+      let fpath = path </> fname
+      liftIO $ TIO.writeFile fpath ke
+      keymanUpdate
+      pure $ mkStr fpath
+
+    _ -> throwIO (BadFormException @C nil)
+

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

@@ -0,0 +1,60 @@
+module HBS2.CLI.Run.Keyring where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Net.Auth.Credentials
+import HBS2.KeyMan.App.Types
+
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.Text qualified as Text
+
+keyringEntries :: forall c m . ( MonadUnliftIO m
+                               , IsContext c
+                               , Exception (BadFormException c)
+                               ) => MakeDictM c m ()
+keyringEntries = do
+  entry $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do
+    lbs <- case syn of
+
+          [ ListVal [ SymbolVal "file", StringLike fn ] ] -> do
+            liftIO $ BS.readFile fn
+
+          [ LitStrVal s ] -> do
+            pure (BS8.pack (Text.unpack s))
+
+          _ -> throwIO (BadFormException @C nil)
+
+    cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs))
+              `orDie` "bad keyring file"
+
+    let e = [ mkStr @c (show (pretty (AsBase58 p))) | KeyringEntry p _ _ <- view peerKeyring cred ]
+
+    pure $ mkList @c e
+
+  brief "creates a new keyring (credentials)"
+    $ args [arg "int?" "encrypt-keys-num"]
+    $ returns "keyring" "string"
+    $ entry $ bindMatch "hbs2:keyring:new" $ \syn -> do
+      n <- case syn of
+            [LitIntVal k] -> pure k
+            []            -> pure 1
+            _ -> throwIO (BadFormException @C nil)
+
+      cred0 <- newCredentials @'HBS2Basic
+      cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
+      pure $ mkStr @c $ show $ pretty $ AsCredFile $ AsBase58 cred
+
+
+  entry $ bindMatch "hbs2:keyring:show" $ \case
+    [StringLike fn] -> do
+      bs <- liftIO $ BS.readFile fn
+      cred <- parseCredentials @'HBS2Basic (AsCredFile bs)
+                  & orThrowUser "bad credentials file"
+
+      pure $ mkStr $ show $ pretty (ListKeyringKeys cred)
+
+    _ -> throwIO $ BadFormException @c nil
+
+

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

@@ -0,0 +1,129 @@
+module HBS2.CLI.Run.LWWRef where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.LWWRef
+
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Data.Types.SignedBox
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Control.Monad.Trans.Cont
+
+
+lwwRefEntries :: forall c m . ( IsContext c
+                              , MonadUnliftIO m
+                              , Exception (BadFormException c)
+                              , HasClientAPI PeerAPI UNIX m
+                              , HasClientAPI LWWRefAPI UNIX m
+                              ) => MakeDictM  c m ()
+lwwRefEntries = do
+
+  brief "creates a new lwwref"
+    $ desc "Creates a new keyring; adds it to keyman and subsribes hbs2-peer to listen this lwwref"
+    $ returns "string" "lwwref public key"
+    $ entry $ bindMatch "hbs2:lwwref:create" $ \case
+        [] -> do
+          reflog <- keymanNewCredentials (Just "lwwref") 0
+          api <- getClientAPI @PeerAPI  @UNIX
+          void $ callService @RpcPollAdd api (reflog, "lwwref", 31)
+          pure $ mkStr (show $ pretty (AsBase58 reflog))
+
+        _ -> throwIO (BadFormException @C nil)
+
+  brief "lists all lwwref that hbs2-peer is subscribed to"
+    $ noArgs
+    $ returns "list of string" "lwwref list"
+    $ entry $ bindMatch "hbs2:lwwref:list" $ \case
+      [] -> do
+        api <- getClientAPI  @PeerAPI @UNIX
+        r <- callService @RpcPollList2 api (Just "lwwref", Nothing)
+               >>= orThrowUser "can't get lwwref list"
+        pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+      _ -> throwIO (BadFormException @C nil)
+
+
+  brief "fetches lwwref value"
+    $ desc "makes peer to request lwwref from neighbors"
+    $ args [arg "string" "lwwref"]
+    $ returns "atom" "okay"
+    $ entry $ bindMatch "hbs2:lwwref:fetch" $ \case
+      [StringLike puk] -> do
+        lww <- orThrowUser "bad lwwref key" (fromStringMay puk)
+        api <- getClientAPI @LWWRefAPI @UNIX
+        void $ callService @RpcLWWRefFetch api lww
+        pure $ mkStr "okay"
+
+      _ -> throwIO (BadFormException @C nil)
+
+
+  brief "get lwwref value"
+    $ args [arg "string" "lwwref"]
+    $ returns "string" "hashref"
+    $ examples [qc|
+
+(hbs2:lwwref:get BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP)
+(lwwref
+  (seq 4)
+  (value "74vDGwBYebH3oM6xPXC7kqpgu6deqi7E549QpvHvvQKf")
+  )
+    |]
+    $ entry $ bindMatch "hbs2:lwwref:get" $ \case
+      [StringLike puk] -> do
+
+        ref <- orThrowUser "bad lwwref key" (fromStringMay puk)
+        api <- getClientAPI @LWWRefAPI  @UNIX
+        what <- callService @RpcLWWRefGet api ref
+                  >>= orThrowUser "can't get lwwref value"
+        pure $ mkStr (show $ pretty what)
+
+      _ -> throwIO (BadFormException @C nil)
+
+
+  brief "updates lwwref"
+    $ desc "updates lwwref value and increments it's counter"
+    $ args [arg "string" "lwwref", arg "string" "hash"]
+    $ returns "nil" ""
+    $ entry $ bindMatch "hbs2:lwwref:update" $ \case
+      [StringLike puks, HashLike new] -> do
+
+        puk <- orThrowUser "bad lwwref key" (fromStringMay  puks)
+        api <- getClientAPI @LWWRefAPI  @UNIX
+
+        (sk,pk) <- liftIO $ runKeymanClient do
+                     creds  <- loadCredentials puk
+                                 >>= orThrowUser "can't load credentials"
+                     pure ( view peerSignSk  creds, view peerSignPk creds )
+
+        what <- callService @RpcLWWRefGet api puk
+                  >>= orThrowUser "can't get lwwref value"
+
+        sno' <- case what of
+                 Nothing    -> pure 0
+                 Just lwwv  -> pure (lwwSeq lwwv)
+
+        let sno =  succ sno'
+
+        let box =  makeSignedBox pk sk (LWWRef sno new Nothing)
+
+        callService @RpcLWWRefUpdate api box
+          >>= orThrowUser "lww ref update error"
+
+        pure nil
+
+      _ -> throwIO (BadFormException @C nil)
+

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

@@ -0,0 +1,329 @@
+{-# Language MultiWayIf #-}
+
+module HBS2.CLI.Run.MetaData
+  ( metaDataEntries
+  , createTreeWithMetadata
+  ) where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.GroupKey as G
+import HBS2.CLI.Run.Internal.Merkle
+
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.System.Dir
+import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
+
+import HBS2.Net.Auth.Schema()
+
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+
+import Codec.Serialise
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either
+import Data.Set qualified as Set
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Data.Text.Encoding qualified as TE
+import Data.Text qualified as Text
+
+import Magic.Data
+import Magic.Init       (magicLoadDefault,magicOpen)
+import Magic.Operations (magicFile)
+
+{- HLINT ignore "Functor law" -}
+
+data CreateMetaDataOpt =
+    Auto
+  | Stdin
+  | Encrypted String
+  | MetaDataEntry Id String
+  | MetaDataFile FilePath
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+txt :: Pretty  a => a -> Text
+txt a = Text.pack (show $ pretty a)
+
+metaFromSyntax :: [Syntax c] -> HashMap Text Text
+metaFromSyntax syn =
+  HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
+  where
+    t x = Text.pack (show $ pretty x)
+
+
+metaDataEntries :: forall c m . ( IsContext c
+                                , MonadUnliftIO m
+                                , Exception (BadFormException c)
+                                , HasStorage m
+                                , HasClientAPI StorageAPI UNIX m
+                                ) => MakeDictM c m ()
+metaDataEntries = do
+
+  brief "update group key for tree"
+    $ args [arg "string" "tree", arg "list" "update-ops"]
+    $ desc ( "update-ops is a list of pairs, like" <> line
+               <> indent 4 ( parens ("list"
+                     <+> indent 2 (vcat [ parens "remove . PUBLIC-KEY-ID"
+                                        , parens "add . PUBLIC-KEY-ID"
+                        ]))))
+    $ returns "string" "new-tree-hash"
+    $ examples [qc|
+
+(define gk (hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N))
+
+(hbs2:groupkey:update gk
+      (list (remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8)
+            (add . EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn)))
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:update-gk" $ \case
+      [StringLike tree, ListVal ins] -> do
+
+        ha <- orThrowUser "invalid hash" (fromStringMay tree)
+
+        -- 1. load-group-key
+        (gkh', headBlk) <- getGroupKeyHash ha
+
+        gkh <- orThrowUser "not encrypted" gkh'
+
+        gk <- loadGroupKey gkh
+                >>= orThrowUser "can't load gk"
+
+        gk1 <- modifyGroupKey gk ins
+
+        sto <- getStorage
+        gk1h <- writeAsMerkle sto (serialise gk1)
+
+        case headBlk of
+          w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do
+            let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce }
+
+            h <- putBlock sto (serialise w1)
+                   >>= orThrowUser "can't put block"
+
+            pure $ mkStr (show $ pretty h)
+
+          _ -> pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "get group key from encrypted tree"
+    $ args [arg "string" "tree-hash"]
+    $ returns "group-key-hash" "string"
+    $ examples [qc|
+
+(hbs2:tree:metadata:get-gk 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd)
+5fshZRucawt47YJLuD1rVXRez2dcvCbz17m69YyduTEm
+
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:get-gk" $ \case
+      [ StringLike hash ] -> flip runContT pure do
+
+        (gk,_) <- lift $ getGroupKeyHash (fromString hash)
+
+        case gk of
+          Just h -> pure $ mkStr (show $ pretty h)
+          _      -> pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "get metadata from tree"
+    $ args [arg "symbol?" "method", arg "string" "tree-hash"]
+    $ returns "group-key-hash" "string"
+    $ desc ( opt "symbol?" ":parsed" <+> "return metadata as dict" <> line
+              <> "if other value or absense then return metadata as string"
+           )
+    $ examples [qc|
+
+(hbs2:tree:metadata:get :parsed 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd)
+(dict (mime-type: "text/plain; charset=us-ascii") (file-name: "qqq.txt"))
+
+(hbs2:tree:metadata:get :raw 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd
+mime-type: "text/plain; charset=us-ascii"
+file-name: "qqq.txt"
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:get"
+    $ \case
+      [ SymbolVal how, StringLike hash ] -> do
+
+        r <- flip runContT pure do
+
+          sto <- getStorage
+
+          runMaybeT do
+
+            headBlock <- getBlock sto (fromString hash)
+                           >>= toMPlus
+                           <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                           >>= toMPlus
+
+            case headBlock of
+              MTreeAnn { _mtaMeta = ShortMetadata s } -> do
+                pure $ mkStr s
+
+              MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do
+                getBlock sto h
+                   >>= toMPlus
+                   <&> LBS.toStrict
+                   <&> TE.decodeUtf8
+                   <&> mkStr
+
+              MTreeAnn { _mtaMeta = AnnHashRef h } -> do
+                getBlock sto h
+                   >>= toMPlus
+                   <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
+                   >>= toMPlus
+                   >>= lift . lift . G.decryptBlock sto
+                   <&> \case
+                    ShortMetadata s -> mkStr s
+                    _ -> nil
+
+              _ -> mzero
+
+        case (how, r) of
+          ("parsed", Just (LitStrVal r0)) -> do
+
+
+            let xs = parseTop r0
+                       & either mempty (fmap fixContext)
+
+            pure $ mkForm  "dict" xs
+
+          _ -> pure $ fromMaybe nil r
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "creates a merkle tree with metadata"
+    $ returns "string" "hash"
+    $ args [ arg "list-of-options" "..." ]
+    $ desc ( "options:" <> line
+             <> indent 4 (
+                  vcat [ opt ":stdin" "read data from stdin"
+                       , opt ":auto"  "create metadata from file using libmagic"
+                       , opt  "[kw [encrypted group-key-hash]]" "encrypt metadata with given group key"
+                       , opt  "dict" "custom metadata dictionary"
+                       , opt  "filename : string-like" "file name, ignored if stdin option set"
+                       ])
+             )
+    $ examples [qc|
+Create not encrypted merkle tree for string from stdin without metadata
+
+$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin
+7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz
+
+;; empty metadata
+
+hbs2-cli hbs2:tree:metadata:get :raw 7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz
+
+Create merkle tree with custom metadata
+
+$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin [kw hello world]
+2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6
+
+$ hbs2-cli hbs2:tree:metadata:get :raw 2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6
+hello: "world"
+
+$ hbs2-cli hbs2:tree:metadata:create :auto ./lambda.svg
+3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg
+
+$ hbs2-cli hbs2:tree:metadata:get :raw 3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg
+mime-type: "image/svg+xml; charset=us-ascii"
+file-name: "lambda.svg"
+
+Create encrypted tree metadata with a new groupkey
+
+$ hbs2-cli [define pks [list EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn]] \
+  and [define gk [hbs2:groupkey:store [hbs2:groupkey:create pks]]] \
+  and [hbs2:tree:metadata:create :auto [kw :encrypted gk] ./lambda.svg]
+
+BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4
+
+Check group key
+
+$ hbs2-cli hbs2:tree:metadata:get-gk BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y
+
+GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u
+
+Check metadata
+
+$ hbs2-cli hbs2:tree:metadata:get :raw BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y
+
+mime-type: "image/svg+xml; charset=us-ascii"
+file-name: "lambda.svg"
+
+List group key
+
+$ hbs2-cli hbs2:groupkey:list-public-keys [hbs2:groupkey:load GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u]
+("EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn")
+    |]
+    $ entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
+        case syn of
+
+          args -> do
+            opts' <- for args $ \case
+              SymbolVal "stdin"     -> pure [Stdin]
+
+              SymbolVal "auto"      -> pure [Auto]
+
+              ListVal (SymbolVal "dict" : [ListVal [SymbolVal "encrypted", StringLike key]])
+                -> do
+                  pure [Encrypted key]
+
+              ListVal (SymbolVal "dict" : w)  -> do
+                pure [MetaDataEntry x y | ListVal [SymbolVal x, StringLike y] <- w ]
+
+              StringLike rest  -> do
+                pure [MetaDataFile rest]
+
+              _ -> pure mempty
+
+            let opts = mconcat opts' & Set.fromList
+            let inFile = headMay [ x | MetaDataFile x <- universeBi opts ]
+
+            lbs <- case (Set.member Stdin opts, inFile) of
+                     (True, _) -> liftIO LBS.getContents
+                     (False, Just fn) -> liftIO (LBS.readFile fn)
+                     (_, Nothing) -> liftIO LBS.getContents
+
+            meta0 <- if not (Set.member Auto opts) || isNothing inFile then
+                       pure (mempty :: HashMap Text Text)
+                     else liftIO do
+                        let fn = fromJust inFile
+                        magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding]
+                        magicLoadDefault magic
+                        mime <- magicFile magic fn
+                        pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn))
+                                           , ("mime-type", Text.pack mime)
+                                           ]
+
+            let meta1  = HM.fromList [  (txt n, txt e) | MetaDataEntry n e <- universeBi opts ]
+
+            let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ]
+
+            gk <- runMaybeT do
+                    s <- toMPlus enc
+                    g <- lift $ loadGroupKey (fromString s)
+                    toMPlus g
+
+            when (isJust enc && isNothing gk) do
+              error $ show $  "Can't load group key" <+> pretty enc
+
+            sto <- getStorage
+
+            href <- lift (createTreeWithMetadata sto  gk (meta0 <> meta1) lbs)
+                      `orDie` "encryption error"
+
+            pure $ mkStr (show $ pretty href)
+
+  entry $ bindMatch "cbor:base58" $ \case
+    [ LitStrVal x ] -> do
+      pure $ mkForm "cbor:base58" [mkStr x]
+
+    _ -> throwIO (BadFormException @c nil)
+
+

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

@@ -0,0 +1,121 @@
+module HBS2.CLI.Run.Peer where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Hash
+import HBS2.Base58
+import HBS2.Data.Types.Refs
+import HBS2.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Net.Auth.Schema()
+
+import Data.List qualified as L
+import Data.Maybe
+import Control.Monad.Trans.Cont
+import Data.Text qualified as Text
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Lens.Micro.Platform
+
+import Text.InterpolatedString.Perl6 (qc)
+
+{- HLINT ignore "Functor law" -}
+
+putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
+           => AnyStorage
+           -> Text
+           -> RunM c m (Syntax c)
+
+putTextLit sto s = do
+    h <- putBlock sto (LBS8.pack (Text.unpack s))
+           `orDie` "can't store block"
+         <&> HashRef
+
+    pure (mkStr @c (show $ pretty h))
+
+peerEntries :: forall c m . ( IsContext c
+                            , MonadUnliftIO m
+                            , HasClientAPI PeerAPI UNIX m
+                            , HasClientAPI StorageAPI UNIX m
+                            , HasStorage m
+                            , Exception (BadFormException c)
+                            ) => MakeDictM c m ()
+peerEntries = do
+
+  entry $ bindMatch "hbs2:peer:detect" $ \case
+    _ -> detectRPC <&> maybe (nil @c) mkStr
+
+  entry $ bindMatch "hbs2:peer:get-block" $ \case
+    [StringLike s] -> do
+      flip runContT pure do
+
+        sto <- getStorage
+        ha <- pure (fromStringMay @HashRef s)
+               `orDie` "invalid hash"
+
+        lbs <- getBlock sto (fromHashRef ha)
+                `orDie` show ("missed-block" <+> pretty ha)
+
+        pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)]
+
+    _ -> throwIO $ BadFormException @c nil
+
+  entry $ bindMatch "hbs2:peer:has-block" $ \case
+    [StringLike s] -> do
+      flip runContT pure do
+
+        sto <- getStorage
+
+        ha <- pure (fromStringMay @HashRef s)
+               `orDie` "invalid hash"
+
+        mbsz <- hasBlock sto (fromHashRef ha)
+
+        pure $ maybe (mkSym "no-block") mkInt mbsz
+
+    _ -> throwIO $ BadFormException @c nil
+
+  -- stores *small* block
+  entry $ bindMatch "hbs2:peer:put-block" $ \case
+    [ListVal [SymbolVal "blob", LitStrVal s]] -> do
+      flip runContT pure do
+        sto <- getStorage
+        lift $ putTextLit sto s
+
+    [LitStrVal s] -> do
+      flip runContT pure do
+        sto <- getStorage
+        lift $ putTextLit sto s
+
+    _ -> throwIO $ BadFormException @c nil
+
+  brief "checks if peer available"
+    $ noArgs
+    $ returns "dict" "dictionary of peer attributes"
+    $ examples [qc|
+(hbs2:peer:poke)
+
+(dict
+ (peer-key: "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3")
+ (udp: "0.0.0.0:7354")
+ (tcp: "tcp://0.0.0.0:3001")
+ (local-multicast: "239.192.152.145:10153")
+ (rpc: "/tmp/hbs2-rpc.socket")
+ (http-port: 5000))
+    |]
+    $ entry $ bindMatch "hbs2:peer:poke" $ \case
+      _ -> do
+        api <- getClientAPI @PeerAPI @UNIX
+        callRpcWaitMay @RpcPoke (TimeoutSec 1) api ()
+          <&> fromMaybe ""
+          <&> parseTop
+          <&> either (const nil) (mkForm "dict" . fmap fixContext)
+
+
+

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

@@ -0,0 +1,297 @@
+module HBS2.CLI.Run.RefChan where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Data.Types.Refs
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.Client.RefChan as Client
+
+import HBS2.Storage.Operations.ByteString
+
+-- import HBS2.Net.Proto
+-- import HBS2.Net.Auth.Credentials
+-- import HBS2.Base58
+-- import HBS2.Defaults
+-- import HBS2.Events
+-- import HBS2.Peer.Proto.Peer
+-- import HBS2.Net.Proto.Sessions
+-- import HBS2.Data.Types.Refs
+-- import HBS2.Data.Types.SignedBox
+-- import HBS2.Storage
+
+
+import HBS2.Peer.Proto.RefChan
+import Data.Either
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Storage
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.Coerce
+import Control.Monad.Trans.Cont
+import Control.Monad.Except
+
+import Text.InterpolatedString.Perl6 (qc)
+
+refchanEntries :: forall c m . ( IsContext c
+                               , MonadUnliftIO m
+                               , Exception (BadFormException c)
+                               , HasClientAPI RefChanAPI UNIX m
+                               , HasClientAPI StorageAPI UNIX m
+                               , HasClientAPI PeerAPI UNIX m
+                               , HasStorage m
+                               ) => MakeDictM  c m ()
+refchanEntries = do
+
+  brief "requests all rechans that peer is subcribed to"
+    $ args []
+    $ returns "list" "list of all refchans"
+    $ examples [qc|
+
+(hbs2:refchan:list)
+("Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP"
+ "A5W6jPBjzvdpxaQ2e8xBLYaRZjPXzi4yX7xjC52gTiKk"
+ "EjjK7rpgRRJ4yzAhTcwis4XawwagCbmkns8n73ogY3uS")
+    |]
+    $ entry $ bindMatch "hbs2:refchan:list" $ \case
+        [] -> do
+          flip runContT pure do
+            api <- getClientAPI @PeerAPI @UNIX
+            r <- callService @RpcPollList2 api (Just "refchan", Nothing)
+                   >>= orThrowUser "can't get refchan list"
+            pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+        _ -> throwIO (BadFormException @c nil)
+
+
+  brief "reads refchan head block"
+    $ args [arg "symbol" "parsed|_", arg "string" "PUBKEY"]
+    $ returns "" "string"
+    $ examples [qc|
+
+(hbs2:refchan:head:get :parsed ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd)
+(version 2)
+(quorum 1)
+(wait 10)
+(peer "5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf" 1)
+(peer "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3" 1)
+(peer "5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb" 1)
+(author "Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH")
+(author "ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd")
+(reader "5UXrEhYECJ2kEQZZPEf4TisfWsLNdh2nGYQQz8X9ioMv")
+(reader "CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8")
+; (head-extensions: (count: 0) (size 0))
+
+
+(hbs2:refchan:head:get :whatever ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd)
+HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
+
+    |]
+    $ entry $ bindMatch "hbs2:refchan:head:get" $ \case
+      [StringLike what, SignPubKeyLike puk] -> do
+
+        flip runContT pure do
+
+          callCC $ \exit -> do
+
+            w <- lift (getRefChanHeadHash @UNIX puk)
+
+            hx <- ContT $ maybe1 w (pure nil)
+
+            case what of
+              "parsed"  -> do
+                  hdblk <- lift (Client.getRefChanHead @UNIX puk)
+
+                  exit $ mkStr (show $ pretty hdblk)
+
+              _ -> exit $ mkStr (show $ pretty $ AsBase58 hx)
+
+            pure nil
+
+
+      _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "hbs2:refchan:head:update" $ \case
+      [SignPubKeyLike rchan, StringLike headFile] -> do
+
+        sto <- getStorage
+
+        rchanApi <- getClientAPI @RefChanAPI @UNIX
+
+        rch <- liftIO (readFile headFile)
+                 <&> fromStringMay @(RefChanHeadBlock L4Proto)
+                 >>= orThrowUser "can't parse RefChanHeadBlock"
+
+        creds <- runKeymanClient $ loadCredentials rchan
+                       >>= orThrowUser "can't load credentials"
+
+        let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
+
+        href <- writeAsMerkle sto  (serialise box)
+
+        callService @RpcRefChanHeadPost rchanApi (HashRef href)
+            >>= orThrowUser "can't post refchan head"
+
+        pure nil
+
+      _ -> throwIO (BadFormException @c nil)
+
+
+  entry $ bindMatch "hbs2:refchan:get" $ \case
+    [SignPubKeyLike rchan] -> do
+
+      api <- getClientAPI @RefChanAPI @UNIX
+
+      h <- callService @RpcRefChanGet api rchan
+             >>= orThrowUser "can't request refchan head"
+
+      pure $ maybe nil (mkStr . show . pretty . AsBase58) h
+
+    _ -> throwIO (BadFormException @c nil)
+
+  entry $ bindMatch "hbs2:refchan:create" $ \syn -> do
+
+    peerApi  <- getClientAPI @PeerAPI @UNIX
+    rchanApi <- getClientAPI @RefChanAPI @UNIX
+    sto      <- getStorage
+
+    rch <- case syn of
+      [StringLike headFile] -> do
+        liftIO (readFile headFile)
+           <&> fromStringMay @(RefChanHeadBlock L4Proto)
+           >>= orThrowUser "can't parse RefChanHeadBlock"
+
+      [] -> do
+       poked <- callService @RpcPoke peerApi ()
+                   >>= orThrowUser "can't poke hbs2-peer"
+                   <&> parseTop
+                   >>= orThrowUser "invalid hbs2-peer attributes"
+
+       ke <- [ x
+             | ListVal [SymbolVal "peer-key:", SignPubKeyLike x] <- poked
+             ] & headMay & orThrowUser "hbs2-peer key not found"
+
+       let rch0 = refChanHeadDefault @L4Proto
+                   & set refChanHeadPeers (HM.singleton ke 1)
+                   & set refChanHeadAuthors (HS.singleton ke)
+
+       pure rch0
+
+      _ -> throwIO (BadFormException @c nil)
+
+    refchan <- keymanNewCredentials (Just "refchan") 0
+
+    creds <- runKeymanClient $ loadCredentials refchan
+                   >>= orThrowUser "can't load credentials"
+
+    let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
+
+    href <- writeAsMerkle sto  (serialise box)
+
+    callService @RpcPollAdd peerApi (refchan, "refchan", 17)
+        >>= orThrowUser "can't subscribe to refchan"
+
+    callService @RpcRefChanHeadPost rchanApi (HashRef href)
+        >>= orThrowUser "can't post refchan head"
+
+    let r = mkStr @c $ show $ "; refchan " <+> pretty (AsBase58 refchan) <> line
+                           <> pretty rch
+
+    pure r
+
+  brief "prints refchan head example"
+    $ returns "nil" mempty
+    $ entry $ bindMatch "hbs2:refchan:head:example" $ nil_ $ \case
+        [] -> flip runContT pure do
+
+          let rch0 = refChanHeadDefault @L4Proto
+
+          api <- getClientAPI @PeerAPI  @UNIX
+
+          pips <- callService @RpcPeers api ()
+                    <&> either (const mempty) (HM.fromList . fmap ((,1) . fst) . take 3)
+
+
+          creds <- replicateM 3 (newCredentialsEnc @HBS2Basic 1)
+
+          let authors = fmap (view peerSignPk) creds
+                            & HS.fromList
+
+          let readers = foldMap (view peerKeyring) creds
+                            & fmap (view krPk)
+                            & take 3
+                            & HS.fromList
+
+          let rch = ( set refChanHeadPeers pips
+                    . set refChanHeadAuthors authors
+                    . set refChanHeadReaders readers
+                    . set refChanHeadNotifiers authors
+                    ) rch0
+
+          liftIO $ print $
+               ";" <+> "this is an example of refchan head block config"
+            <> line
+            <> ";" <+> "edit it before applying" <> line
+            <> ";"  <+> "set up the actual keys / credentials you need" <> line
+            <> line <> line
+            <> ";" <+> "(version INT) is the head block version" <> line
+            <> ";" <+> "the refchan head block will be set only" <>line
+            <> ";" <+> "if it's version  if greater than the already existed one" <> line
+            <> line
+
+            <> ";" <+> "(quorum INT) is a number of accept messages issued by peers" <> line
+            <> ";" <+> "to include propose message to the refchan" <> line
+            <> line
+
+            <> ";" <+> "(wait INT) is an quorum  wait time in seconds" <> line
+            <> line
+
+            <> ";" <+> "(peer PUBKEY WEIGHT) sets the peer allowed for posting propose/accept messages" <> line
+            <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line
+            <> ";" <+> "only messages from that peers will be accepted" <> line
+            <> ";" <+> "WEIGHT is not used yet but reserved for the future" <> line
+            <> ";" <+> "this parameter is optional but there is should be some peers or" <> line
+            <> ";" <+> "all messages will be sent to nowhere" <> line
+            <> line
+
+            <> ";" <+> "(author PUBKEY) adds 'author' i.e. key that is allowed to sign the propose message" <> line
+            <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line
+            <> ";" <+> "only the propose  messages signed by one of thise keys will be accepted" <> line
+            <> line
+
+            <> ";" <+> "(notifier PUBKEY) adds 'notifier' i.e. key that is allowed to sign the notify message" <> line
+            <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line
+            <> ";" <+> "only the propose  messages signed by one of thise keys will be accepted" <> line
+            <> ";" <+> "notify messages are not written to the refchan merkle tree" <> line
+            <> ";" <+> "and they useful for implementing any sort of ephemeral messaging" <> line
+            <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line
+            <> line
+
+            <> ";" <+> "(reader PUBKEY) adds 'author' i.e. key that is allowed to decrypt messages" <> line
+            <> ";" <+> "PUBKEY is a ENCRYPTION public key as base58 string" <> line
+            <> ";" <+> "NOTE: messages in a refchan are not encrypted by default" <> line
+            <> ";" <+> "    it's totally up to an application for this refchan" <> line
+            <> ";" <+> "    therefore this clause is just used for setting reader keys to" <> line
+            <> ";" <+> "    implement any ACL/encrypting mechanism" <> line
+            <> ";" <+> "    i.e. groupkey may be inherited from the RefChanHead block" <> line
+            <> ";" <+> "    to encrypt data posted to a refchan" <> line
+            <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line
+            <> line
+
+            <> pretty rch
+
+        _ -> throwIO (BadFormException @C nil)
+

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

@@ -0,0 +1,220 @@
+module HBS2.CLI.Run.RefLog where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Storage
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.Storage
+
+import HBS2.Peer.Proto hiding (request)
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Coerce
+import Data.Either
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text qualified as Text
+import Control.Monad.Trans.Cont
+
+import Streaming.Prelude qualified as S
+
+getCredentialsForReflog :: MonadUnliftIO m => RefLogKey 'HBS2Basic -> m (PeerCredentials 'HBS2Basic)
+getCredentialsForReflog reflog = do
+  runKeymanClient (loadCredentials reflog)
+     >>= orThrowUser "credentials not found"
+
+mkRefLogUpdateFrom :: (MonadUnliftIO m) => RefLogKey 'HBS2Basic -> m ByteString ->  m (RefLogUpdate L4Proto)
+mkRefLogUpdateFrom reflog mbs = do
+  what <- getCredentialsForReflog reflog
+  let puk = view peerSignPk what
+  let privk = view peerSignSk what
+  txraw <- mbs
+  makeRefLogUpdate @L4Proto @'HBS2Basic (coerce puk) privk txraw
+
+
+reflogEntries :: forall c m . ( IsContext c
+                              , Exception (BadFormException c)
+                              , MonadUnliftIO m
+                              , HasStorage m
+                              , HasClientAPI PeerAPI UNIX m
+                              , HasClientAPI RefLogAPI UNIX m
+                              , HasClientAPI StorageAPI UNIX m
+                              ) => MakeDictM  c m ()
+reflogEntries = do
+
+  entry $ bindMatch "hbs2:reflog:create" $ \case
+    [] -> do
+      reflog <- keymanNewCredentials (Just "reflog") 0
+
+      api <- getClientAPI @PeerAPI  @UNIX
+      void $ callService @RpcPollAdd api (reflog, "reflog", 31)
+      pure $ mkStr (show $ pretty (AsBase58 reflog))
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:add" $ \case
+    [SignPubKeyLike reflog] -> do
+      -- reflog <- keymanNewCredentials (Just "reflog") 0
+
+      api <- getClientAPI @PeerAPI @UNIX
+      void $ callService @RpcPollAdd api (reflog, "reflog", 31)
+      pure $ mkStr (show $ pretty (AsBase58 reflog))
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+
+  entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case
+    [StringLike puk, StringLike hash] -> do
+      reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+      sto <- getStorage
+      hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
+      void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
+      let sref = AnnotatedHashRef Nothing hashref
+      rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case
+    [BlobLike blob] -> do
+      caller <- getClientAPI @RefLogAPI @UNIX
+      wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob)
+              & orThrowUser "invalid tx"
+      void $ callService @RpcRefLogPost caller wtf
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case
+    [StringLike puk, LitIntVal sn, StringLike hash] -> do
+      reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+      sto <- getStorage
+      hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
+      void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
+      let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref)
+      rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:tx:raw:create" $ \case
+    [SymbolVal "stdin", SignPubKeyLike reflog] -> do
+
+      rlu <- mkRefLogUpdateFrom (RefLogKey reflog) ( liftIO BS.getContents )
+                <&> serialise
+
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    [LitStrVal s, StringLike rlo] -> do
+      reflog <- orThrowUser "bad reflog" (fromStringMay rlo)
+
+      rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) )
+               <&> serialise
+
+      pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:reflog:get" $ \case
+    [StringLike puk] -> do
+
+      flip runContT pure do
+        reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+        api <- getClientAPI @RefLogAPI  @UNIX
+        what <- callService @RpcRefLogGet api reflog
+                  >>= orThrowUser "can't get reflog"
+        pure $ mkStr (show $ pretty what)
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:fetch" $ \case
+    [StringLike puk] -> do
+      flip runContT pure do
+        reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+        api <- getClientAPI @RefLogAPI  @UNIX
+        void $ callService @RpcRefLogFetch api reflog
+        pure $ mkStr "okay"
+
+    _ -> throwIO (BadFormException @C nil)
+
+  entry $ bindMatch "hbs2:reflog:list" $ \case
+    [] -> do
+      flip runContT pure do
+        api <- getClientAPI @PeerAPI @UNIX
+        r <- callService @RpcPollList2 api (Just "reflog", Nothing)
+               >>= orThrowUser "can't get reflog list"
+        pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:reflog:tx:seqref:decode" $ \case
+    [ListVal [SymbolVal "blob", LitStrVal s]] -> do
+      let lbs =  Text.unpack s & BS8.pack & LBS.fromStrict
+
+      SequentialRef n (AnnotatedHashRef _ h) <-  deserialiseOrFail @SequentialRef lbs
+                                                   & orThrowUser "FUCKED"
+
+      pure $ mkForm "seqref" [mkInt n, mkStr (show $ pretty h)]
+
+    e -> throwIO $ BadFormException @c nil
+
+  entry $ bindMatch "hbs2:reflog:tx:list" $ \case
+     [e, SignPubKeyLike puk] -> do
+
+      flip runContT pure do
+
+        callCC \exit -> do
+
+          api <- getClientAPI @RefLogAPI  @UNIX
+          sto <- getStorage
+
+          r <- callService @RpcRefLogGet api puk
+                 >>= orThrowUser "can't get reflog value"
+
+          rlh <- ContT $ maybe1 r (pure nil)
+
+          hashes <- S.toList_ do
+                      walkMerkle @[HashRef] (fromHashRef rlh) (getBlock sto) $ \case
+                        (Left _) -> lift $ exit nil
+                        (Right (hs :: [HashRef]))  -> S.each hs
+
+          rr <- forM hashes $ \ha -> do
+
+            tx <- getBlock sto (coerce ha)
+                     >>= orThrowUser "missed-block"
+                     <&> deserialiseOrFail @(RefLogUpdate L4Proto)
+                     >>= orThrowUser "invalid-tx"
+
+            let bs = view refLogUpdData tx
+            let bs8 = BS8.unpack bs
+
+            lift $ apply_ e [mkForm "blob" [mkStr bs8]]
+
+          pure $ mkList rr
+
+     _ -> throwIO (BadFormException @C nil)
+
+
+
+

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

@@ -0,0 +1,82 @@
+module HBS2.CLI.Run.Sigil where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Base58
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Credentials.Sigil
+
+import Data.List qualified as L
+import Data.ByteString.Char8 qualified as BS8
+import Data.Text qualified as Text
+import Lens.Micro.Platform
+
+
+sigilEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
+sigilEntries = do
+
+  entry $ bindMatch "hbs2:sigil:sign-pubkey" $ \case
+    [ ListVal (SymbolVal sigil : (hasKey "sign-pubkey" -> Just s)) ] -> do
+      pure s
+
+    _ -> throwIO $ BadFormException @C nil
+
+
+  entry $ bindMatch "hbs2:sigil:encrypt-pubkey" $ \case
+    [ ListVal (SymbolVal sigil : (hasKey "encrypt-pubkey" -> Just s)) ] -> do
+      pure s
+
+    _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:sigil:parse" $ \case
+    [StringLike s] -> do
+
+      let bs = BS8.pack s
+      sigil <- pure (parseSerialisableFromBase58 @(Sigil 'HBS2Basic) bs)
+                  `orDie` "parse sigil failed"
+
+      (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
+                  `orDie` "signature check failed"
+
+      pure (parseTop $ show $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd])))
+              `orDie` "bad sigil"
+              <&> head
+
+    _ -> throwIO $ BadFormException @C nil
+
+  entry $ bindMatch "hbs2:sigil:create-from-keyring" $ \syn -> do
+
+    args <- case syn of
+      [ StringLike s ] -> pure (fmap snd . headMay, s)
+      [ StringLike p, StringLike s ] -> pure ( findKey p, s)
+      [ LitIntVal n, StringLike s ] -> pure ( L.lookup n, s)
+
+      _ -> throwIO $ BadFormException @C nil
+
+    let lbs = BS8.pack (snd args)
+
+    cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs))
+               `orDie` "bad keyring data"
+
+    let es = zip [0..]
+                 [ p | KeyringEntry p _ _
+                     <- view peerKeyring cred
+                 ]
+
+    enc <- pure (fst args es)
+           `orDie` "key not found"
+
+    sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing)
+              `orDie` "can't create a sigil"
+
+    pure $ mkStr (show $ pretty $ AsBase58 sigil)
+
+  where
+    findKey s xs = headMay [ k
+                           | e@(_,k) <- xs
+                           , L.isPrefixOf s (show $ pretty (AsBase58 k))
+                           ]
+
+

hbs2-core/hbs2-core.cabal

@@ -94,6 +94,7 @@ library
                     , HBS2.Polling
                     , HBS2.Hash
                     , HBS2.Merkle
+                    , HBS2.Merkle.MetaData
                     , HBS2.Net.Auth.Schema
                     , HBS2.Net.Auth.GroupKeyAsymm
                     , HBS2.Net.Auth.GroupKeySymm
@@ -105,6 +106,7 @@ library
                     , HBS2.Net.Messaging.UDP
                     , HBS2.Net.Messaging.TCP
                     , HBS2.Net.Messaging.Unix
+                    , HBS2.Net.Messaging.Pipe
                     , HBS2.Net.Messaging.Stream
                     , HBS2.Net.Messaging.Encrypted.RandomPrefix
                     , HBS2.Net.Messaging.Encrypted.ByPass
@@ -126,10 +128,6 @@ library
                     , HBS2.System.Logger.Simple.ANSI
                     , HBS2.System.Logger.Simple.Class
                     , HBS2.System.Dir
-                    , HBS2.Net.Dialog.Core
-                    , HBS2.Net.Dialog.Client
-                    , HBS2.Net.Dialog.Helpers.List
-                    , HBS2.Net.Dialog.Helpers.Streaming
                     , HBS2.Misc.PrettyStuff
                     , HBS2.Version
 
@@ -196,6 +194,7 @@ library
                     , time
                     , transformers
                     , uniplate
+                    , unix
                     , unordered-containers
                     , unliftio
                     , unliftio-core
@@ -216,7 +215,6 @@ test-suite test
                   -- , TestUniqProtoId
                   , FakeMessaging
                   , HasProtocol
-                  , DialogSpec
                   , TestScheduled
                   , TestDerivedKey
 

hbs2-core/lib/HBS2/Data/Bundle.hs

@@ -26,8 +26,8 @@ import Streaming()
 
 {- HLINT ignore "Use newtype instead of data" -}
 
-data BundleRefValue e =
+data BundleRefValue s =
-  BundleRefValue (SignedBox BundleRef e)
+  BundleRefValue (SignedBox BundleRef s)
   deriving stock (Generic)
 
 instance ForSignedBox e => Serialise (BundleRefValue e)
@@ -39,13 +39,13 @@ data BundleRef =
 instance Serialise BundleRef
 
 
-makeBundleRefValue :: forall e . (ForSignedBox e, Signatures (Encryption e))
+makeBundleRefValue :: forall s . (ForSignedBox s, Signatures s)
-                   => PubKey 'Sign (Encryption e)
+                   => PubKey 'Sign s
-                   -> PrivKey 'Sign (Encryption e)
+                   -> PrivKey 'Sign s
                    -> BundleRef
-                   -> BundleRefValue e
+                   -> BundleRefValue s
 
-makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @e pk sk ref
+makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @s pk sk ref
 
 -- у нас может быть много способов хранить данные:
 --   сжимать целиком (эффективно, но медленно)

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -23,6 +23,10 @@ newtype HashRef = HashRef { fromHashRef :: Hash HbSync }
                   deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync)
                   deriving stock (Data,Generic,Show)
 
+newtype TaggedHashRef t = TaggedHashRef { fromTaggedHashRef :: HashRef }
+                          deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync)
+                          deriving stock (Data,Generic,Show)
+
 
 instance Pretty (AsBase58 HashRef) where
   pretty (AsBase58 x) = pretty x
@@ -38,6 +42,9 @@ newtype TheHashRef t = TheHashRef { fromTheHashRef :: Hash HbSync }
 instance Pretty (AsBase58 (TheHashRef t)) where
   pretty (AsBase58 x) = pretty x
 
+instance Pretty (AsBase58 (TaggedHashRef t)) where
+  pretty (AsBase58 x) = pretty x
+
 instance FromStringMaybe (TheHashRef t) where
   fromStringMay = fmap TheHashRef . fromStringMay
 
@@ -65,6 +72,7 @@ data SequentialRef =
 instance Serialise AnnotatedHashRef
 instance Serialise SequentialRef
 instance Serialise HashRef
+instance Serialise (TaggedHashRef e)
 
 
 type IsRefPubKey s =  ( Eq (PubKey 'Sign s)

hbs2-core/lib/HBS2/Data/Types/SignedBox.hs

@@ -11,62 +11,62 @@ import Data.Hashable
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
 import Control.Monad.Trans.Maybe
-import Data.Function
 import Control.Monad.Identity
 
-data SignedBox p e =
+data SignedBox p s =
-  SignedBox (PubKey 'Sign (Encryption e)) ByteString (Signature (Encryption e))
+  SignedBox (PubKey 'Sign s) ByteString (Signature s)
   deriving stock (Generic)
 
 deriving stock instance
-  ( Eq (PubKey 'Sign (Encryption e))
+  ( Eq (PubKey 'Sign s)
-  , Eq (Signature (Encryption e))
+  , Eq (Signature s)
-  ) => Eq (SignedBox p e)
+  ) => Eq (SignedBox p s)
 
-instance ( Eq (PubKey 'Sign (Encryption e))
+instance ( Eq (PubKey 'Sign s)
-         , Eq (Signature (Encryption e))
+         , Eq (Signature s)
-         , Serialise (SignedBox p e)
+         , Serialise (SignedBox p s)
-         ) =>  Hashable (SignedBox p e) where
+         ) =>  Hashable (SignedBox p s) where
   hashWithSalt salt box = hashWithSalt salt (serialise box)
 
 
-type ForSignedBox e = ( Serialise ( PubKey 'Sign (Encryption e))
+type ForSignedBox s = ( Serialise ( PubKey 'Sign s)
-                      , FromStringMaybe (PubKey 'Sign (Encryption e))
+                      , FromStringMaybe (PubKey 'Sign s)
-                      , Serialise (Signature (Encryption e))
+                      , Serialise (Signature s)
-                      , Signatures (Encryption e)
+                      , Signatures s
-                      , Hashable (PubKey 'Sign (Encryption e))
+                      , Hashable (PubKey 'Sign s)
                       )
 
-instance ForSignedBox e => Serialise (SignedBox p e)
+instance ForSignedBox s => Serialise (SignedBox p s)
 
-makeSignedBox :: forall e p . (Serialise p, ForSignedBox e, Signatures (Encryption e))
+makeSignedBox :: forall s p . (Serialise p, ForSignedBox s, Signatures s)
-              => PubKey 'Sign (Encryption e)
+              => PubKey 'Sign s
-              -> PrivKey 'Sign (Encryption e)
+              -> PrivKey 'Sign s
               -> p
-              -> SignedBox p e
+              -> SignedBox p s
 
-makeSignedBox pk sk msg = SignedBox @p @e pk bs sign
+makeSignedBox pk sk msg = SignedBox @p @s pk bs sign
   where
     bs = LBS.toStrict (serialise msg)
-    sign = makeSign @(Encryption e) sk bs
+    sign = makeSign @s sk bs
 
 
-unboxSignedBox0 :: forall p e . (Serialise p, ForSignedBox e, Signatures (Encryption e))
+unboxSignedBox0 :: forall p s . (Serialise p, ForSignedBox s, Signatures s)
-               => SignedBox p e
+               => SignedBox p s
-               -> Maybe (PubKey 'Sign (Encryption e), p)
+               -> Maybe (PubKey 'Sign s, p)
 
 unboxSignedBox0 (SignedBox pk bs sign) = runIdentity $ runMaybeT do
-  guard $ verifySign @(Encryption e) pk sign bs
+  guard $ verifySign @s pk sign bs
   p <- MaybeT $ pure $ deserialiseOrFail @p (LBS.fromStrict bs) & either (const Nothing) Just
   pure (pk, p)
 
-unboxSignedBox :: forall p e . (Serialise p, ForSignedBox e, Signatures (Encryption e))
+unboxSignedBox :: forall p s . (Serialise p, ForSignedBox s, Signatures s)
                => LBS.ByteString
-               -> Maybe (PubKey 'Sign (Encryption e), p)
+               -> Maybe (PubKey 'Sign s, p)
 
 unboxSignedBox bs = runIdentity $ runMaybeT do
 
-  box <- MaybeT $ pure $ deserialiseOrFail @(SignedBox p e) bs
+  box <- MaybeT $ pure $ deserialiseOrFail @(SignedBox p s) bs
                           & either (pure Nothing) Just
 
   MaybeT $ pure $ unboxSignedBox0 box
+

hbs2-core/lib/HBS2/Merkle/MetaData.hs

@@ -0,0 +1,81 @@
+module HBS2.Merkle.MetaData where
+
+import HBS2.Prelude
+import HBS2.OrDie
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Storage
+import HBS2.Data.Types.SmallEncryptedBlock
+import HBS2.Net.Auth.GroupKeySymm as G
+import HBS2.Storage.Operations.Class
+
+import Data.Coerce
+import Data.ByteString.Lazy qualified as LBS
+import Codec.Serialise
+import Data.Text.Encoding qualified as TE
+import Control.Monad.Except
+import Control.Monad.Trans.Maybe
+
+import UnliftIO
+
+{- HLINT ignore "Functor law" -}
+
+extractMetaData :: forall s m . (MonadIO m, ForGroupKeySymm s, MonadError OperationError m)
+
+                => (GroupKey 'Symm s -> m (Maybe GroupSecret))
+                -> AnyStorage
+                -> HashRef
+                -> m Text
+extractMetaData fk sto hash = do
+
+    headBlock <- getBlock sto (coerce hash)
+                   >>= orThrowError MissedBlockError
+                   <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                   >>= orThrowError UnsupportedFormat
+
+    case headBlock of
+      MTreeAnn { _mtaMeta = ShortMetadata s } -> do
+        pure  s
+
+      MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do
+        getBlock sto h
+           >>= orThrowError MissedBlockError
+           <&> LBS.toStrict
+           <&> TE.decodeUtf8
+
+      MTreeAnn { _mtaMeta = AnnHashRef h } -> do
+        getBlock sto h
+           >>= orThrowError MissedBlockError
+           <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
+           >>= orThrowError UnsupportedFormat
+           >>= G.decryptBlock @_ @s sto fk
+           >>= \case
+            ShortMetadata s -> pure s
+            _ -> throwError UnsupportedFormat
+
+      _ -> throwError UnsupportedFormat
+
+
+loadGroupKeyForTree :: ( ForGroupKeySymm s
+                       , MonadIO m
+                       )
+                  => AnyStorage
+                  -> HashRef
+                  -> m (Maybe (GroupKey 'Symm s))
+
+loadGroupKeyForTree sto h = do
+
+  runMaybeT do
+
+    headBlock <- getBlock sto (fromHashRef h)
+                  >>= toMPlus
+                  <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                  >>= toMPlus
+
+    gkh <- case _mtaCrypt headBlock of
+             (EncryptGroupNaClSymm h1 _) -> pure (HashRef h1)
+             _ -> mzero
+
+    G.loadGroupKeyMaybe sto gkh >>= toMPlus
+
+

hbs2-core/lib/HBS2/Net/Auth/Credentials.hs

@@ -15,6 +15,7 @@ import HBS2.Net.Auth.Schema
 import HBS2.Base58
 import HBS2.Hash
 
+import Control.Applicative
 import Codec.Serialise
 import Crypto.Saltine.Core.Sign (Keypair(..))
 import Crypto.Saltine.Core.Sign qualified as Sign
@@ -28,14 +29,10 @@ import Data.List.Split (chunksOf)
 import Data.List qualified as List
 import Lens.Micro.Platform
 import Data.Kind
+import Control.Monad
 
-type instance PubKey  'Sign HBS2Basic = Sign.PublicKey
+instance Signatures 'HBS2Basic where
-type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
+  type Signature 'HBS2Basic = Sign.Signature
-type instance PubKey  'Encrypt HBS2Basic = Encrypt.PublicKey
-type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
-
-instance Signatures HBS2Basic where
-  type Signature HBS2Basic = Sign.Signature
   makeSign = Sign.signDetached
   verifySign = Sign.signVerifyDetached
 
@@ -68,10 +65,10 @@ class AsymmPubKey e ~ PubKey 'Encrypt e => Asymm e where
 class HasCredentials s m where
   getCredentials :: m (PeerCredentials s)
 
-data KeyringEntry e =
+data KeyringEntry s =
   KeyringEntry
-  { _krPk   :: PubKey  'Encrypt e
+  { _krPk   :: PubKey  'Encrypt s
-  , _krSk   :: PrivKey 'Encrypt e
+  , _krSk   :: PrivKey 'Encrypt s
   , _krDesc :: Maybe Text
   }
   deriving stock (Generic)
@@ -95,23 +92,24 @@ makeLenses 'KeyringEntry
 makeLenses 'PeerCredentials
 
 type ForHBS2Basic s = ( Signatures s
-                      , PrivKey 'Sign s ~ Sign.SecretKey
+                       , PrivKey 'Sign s ~ Sign.SecretKey
-                      , PubKey 'Sign s ~ Sign.PublicKey
+                       , PubKey 'Sign s ~ Sign.PublicKey
-                      , Eq (PubKey 'Encrypt HBS2Basic)
+                       , Eq (PubKey 'Encrypt 'HBS2Basic)
-                      , IsEncoding (PubKey 'Encrypt s)
+                       , IsEncoding (PubKey 'Encrypt s)
-                      , Eq (PubKey 'Encrypt HBS2Basic)
+                       , Eq (PubKey 'Encrypt 'HBS2Basic)
-                      , s ~ HBS2Basic
+                       , s ~ 'HBS2Basic
-                      )
+                       )
 
-type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e)
+type SerialisedCredentials ( s :: CryptoScheme ) =
-                               , Serialise (PubKey 'Sign e)
+    ( Serialise (PrivKey 'Sign s)
-                               , Serialise (PubKey 'Encrypt e)
+    , Serialise (PubKey 'Sign s)
-                               , Serialise (PrivKey 'Encrypt e)
+    , Serialise (PubKey 'Encrypt s)
-                               )
+    , Serialise (PrivKey 'Encrypt s)
+    )
 
-instance SerialisedCredentials e => Serialise (KeyringEntry e)
+instance SerialisedCredentials s => Serialise (KeyringEntry s)
 
-instance SerialisedCredentials e => Serialise (PeerCredentials e)
+instance SerialisedCredentials s => Serialise (PeerCredentials s)
 
 newtype AsCredFile a = AsCredFile a
 
@@ -130,6 +128,17 @@ newCredentials = do
   pure $ PeerCredentials @s (secretKey pair) (publicKey pair) mempty
 
 
+newCredentialsEnc :: forall s m . ( MonadIO m
+                                  , Signatures s
+                                  , PrivKey 'Sign s ~ Sign.SecretKey
+                                  , PubKey 'Sign s ~ Sign.PublicKey
+                                  , PrivKey 'Encrypt s ~ Encrypt.SecretKey
+                                  , PubKey 'Encrypt s ~ Encrypt.PublicKey
+                                  ) => Int -> m (PeerCredentials s)
+newCredentialsEnc n = do
+  cred0 <- newCredentials @s
+  foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
+
 newKeypair :: forall s m . ( MonadIO m
                            , PrivKey 'Encrypt s ~ Encrypt.SecretKey
                            , PubKey 'Encrypt s ~ Encrypt.PublicKey
@@ -164,7 +173,13 @@ parseCredentials :: forall s . ( -- ForHBS2Basic s
                                  SerialisedCredentials s
                                )
                  =>  AsCredFile ByteString -> Maybe (PeerCredentials s)
-parseCredentials (AsCredFile bs) = parseSerialisableFromBase58 bs
+parseCredentials (AsCredFile bs) =
+  parseSerialisableFromBase58 bs <|> parseSerialisableFromCbor (LBS.fromStrict bs)
+
+parseSerialisableFromCbor :: SerialisedCredentials s => LBS.ByteString -> Maybe (PeerCredentials s)
+parseSerialisableFromCbor = fromCbor
+    where fromCbor s = deserialiseOrFail s
+                        & either (const Nothing) Just
 
 parseSerialisableFromBase58 :: Serialise a => ByteString -> Maybe a
 parseSerialisableFromBase58 bs = maybe1 b58_1 Nothing fromCbor
@@ -234,11 +249,11 @@ instance IsEncoding (PubKey 'Encrypt e)
   pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke)))
 
 
-instance Asymm HBS2Basic where
+instance Asymm 'HBS2Basic where
-  type AsymmKeypair HBS2Basic = Encrypt.Keypair
+  type AsymmKeypair 'HBS2Basic = Encrypt.Keypair
-  type AsymmPrivKey HBS2Basic = Encrypt.SecretKey
+  type AsymmPrivKey 'HBS2Basic = Encrypt.SecretKey
-  type AsymmPubKey HBS2Basic = Encrypt.PublicKey
+  type AsymmPubKey 'HBS2Basic = Encrypt.PublicKey
-  type CommonSecret HBS2Basic = Encrypt.CombinedKey
+  type CommonSecret 'HBS2Basic = Encrypt.CombinedKey
   asymmNewKeypair = liftIO Encrypt.newKeypair
   privKeyFromKeypair = Encrypt.secretKey
   pubKeyFromKeypair = Encrypt.publicKey

hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs

@@ -26,9 +26,9 @@ import Lens.Micro.Platform
 -- Contains an encryption public key, optional additional information,
 -- and a possible reference to an additional information block.
 
-data SigilData e =
+data SigilData s =
   SigilData
-  { sigilDataEncKey :: PubKey 'Encrypt (Encryption e)
+  { sigilDataEncKey :: PubKey 'Encrypt s
   , sigilDataInfo   :: Maybe Text
   , sigilDataExt    :: Maybe HashRef
   }
@@ -40,34 +40,34 @@ data SigilData e =
 -- Includes a signature public key and signed 'SigilData',
 -- ensuring user authentication and verification.
 
-data Sigil e =
+data Sigil s =
   Sigil
-  { sigilSignPk     :: PubKey 'Sign (Encryption e)
+  { sigilSignPk     :: PubKey 'Sign s
-  , sigilData       :: SignedBox (SigilData e) e
+  , sigilData       :: SignedBox (SigilData s) s
   }
   deriving stock (Generic)
 
 
-type ForSigil e = ( Serialise (PubKey 'Encrypt (Encryption e))
+type ForSigil s = ( Serialise (PubKey 'Encrypt s)
-                  , Serialise (PubKey 'Sign (Encryption e))
+                  , Serialise (PubKey 'Sign s)
-                  , Serialise (Signature (Encryption e))
+                  , Serialise (Signature s)
-                  , Signatures (Encryption e)
+                  , Signatures s
-                  , Hashable (PubKey 'Sign (Encryption e))
+                  , Hashable (PubKey 'Sign s)
-                  , IsEncoding (PubKey 'Encrypt (Encryption e))
+                  , IsEncoding (PubKey 'Encrypt s)
-                  , Eq (PubKey 'Encrypt (Encryption e))
+                  , Eq (PubKey 'Encrypt s)
-                  , FromStringMaybe (PubKey 'Sign (Encryption e))
+                  , FromStringMaybe (PubKey 'Sign s)
                   )
 
-type ForPrettySigil e =
+type ForPrettySigil s =
-  ( IsEncoding (PubKey 'Encrypt (Encryption e))
+  ( IsEncoding (PubKey 'Encrypt s)
-  , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
+  , Pretty (AsBase58 (PubKey 'Sign s))
   )
 
-instance ForSigil e => Serialise (SigilData e)
+instance ForSigil s => Serialise (SigilData s)
-instance ForSigil e => Serialise (Sigil e)
+instance ForSigil s => Serialise (Sigil s)
 
 
-instance ForPrettySigil e => Pretty (SigilData e) where
+instance ForPrettySigil s => Pretty (SigilData s) where
   pretty s = vcat $ [ parens ("encrypt-pubkey" <+> dquotes epk)
                     ] <> catMaybes [pinfo, pext]
     where
@@ -75,7 +75,7 @@ instance ForPrettySigil e => Pretty (SigilData e) where
       pinfo = sigilDataInfo s >>= \x -> pure $ parens ("info" <+> dquotes (pretty x))
       pext = sigilDataExt s >>= \x -> pure $ parens ("ext" <+> dquotes (pretty x))
 
-instance ForPrettySigil e => Pretty (Sigil e) where
+instance ForPrettySigil s => Pretty (Sigil s) where
   pretty s = vcat
              [ parens ("sign-pubkey" <+> psk)
              ]
@@ -83,12 +83,12 @@ instance ForPrettySigil e => Pretty (Sigil e) where
       psk = dquotes (pretty (AsBase58 (sigilSignPk s)))
 
 -- Nothing, если ключ отсутствует в Credentials
-makeSigilFromCredentials :: forall e . ForSigil e
+makeSigilFromCredentials :: forall s . ForSigil s
-                         => PeerCredentials (Encryption e)
+                         => PeerCredentials s
-                         -> PubKey 'Encrypt (Encryption e)
+                         -> PubKey 'Encrypt s
                          -> Maybe Text
                          -> Maybe HashRef
-                         -> Maybe (Sigil e)
+                         -> Maybe (Sigil s)
 
 makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
 
@@ -102,7 +102,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
 
   let sd = SigilData ke i ha
 
-  let box = makeSignedBox @e ppk psk sd
+  let box = makeSignedBox @s ppk psk sd
 
   let sigil = Sigil
               { sigilSignPk = view peerSignPk cred
@@ -112,7 +112,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do
   pure sigil
 
 
-instance ForSigil e => Pretty (AsBase58 (Sigil e)) where
+instance ForSigil s => Pretty (AsBase58 (Sigil s)) where
   pretty (AsBase58 s) = "# sigil file. public data" <> line <> sd
     where
       sd = vcat $ fmap pretty

hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs

@@ -8,7 +8,6 @@ import HBS2.Base58
 import HBS2.Data.Types
 import HBS2.Data.Types.EncryptedBox
 import HBS2.Net.Auth.Credentials
-import HBS2.Net.Proto.Types
 import HBS2.Prelude.Plated
 
 import Codec.Serialise
@@ -21,20 +20,18 @@ import Data.ByteString.Char8 (ByteString)
 import Data.List.Split (chunksOf)
 
 
-type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s)
+type ForAccessKey (s :: CryptoScheme)  = ( Crypto.IsEncoding (PubKey 'Encrypt s)
-                      , Serialise (PubKey 'Encrypt s)
+                                         , Serialise (PubKey 'Encrypt s)
-                      , Serialise (PubKey 'Sign s)
+                                         , Serialise (PubKey 'Sign s)
-                      , Serialise (PrivKey 'Sign s)
+                                         , Serialise (PrivKey 'Sign s)
-                      , Serialise (PrivKey 'Encrypt s)
+                                         , Serialise (PrivKey 'Encrypt s)
-                      )
+                                         )
 
 
 
----
+data family AccessKey ( s :: CryptoScheme )
 
-data family AccessKey s
+newtype instance AccessKey (s :: CryptoScheme) =
-
-newtype instance AccessKey s =
   AccessKeyNaClAsymm
   { permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))]
   }

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -13,11 +13,13 @@ import HBS2.Base58
 import HBS2.Data.Types.EncryptedBox
 import HBS2.Data.Types.SmallEncryptedBlock
 import HBS2.Data.Types.Refs
+import HBS2.Net.Auth.Schema
 import HBS2.Hash
 import HBS2.Merkle
 import HBS2.Data.Detect
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Types
+import HBS2.Storage hiding (Key)
 import HBS2.Storage.Operations.Class
 import HBS2.Storage.Operations.ByteString
 import HBS2.Storage(Storage(..))
@@ -96,14 +98,17 @@ data instance ToEncrypt 'Symm s LBS.ByteString =
   }
   deriving (Generic)
 
-type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s)
+type ForGroupKeySymm (s :: CryptoScheme ) =
-                         , PubKey 'Encrypt s ~ AK.PublicKey
+  (
-                         , PrivKey 'Encrypt s ~ AK.SecretKey
+    -- Eq (PubKey 'Encrypt s)
-                         , Serialise (PubKey 'Encrypt s)
+  -- , PubKey 'Encrypt s
-                         , Serialise GroupSecret
+  -- , PrivKey 'Encrypt s
-                         , Serialise SK.Nonce
+    Serialise (PubKey 'Encrypt s)
-                         , FromStringMaybe (PubKey 'Encrypt s)
+  , Serialise GroupSecret
-                         )
+  , Serialise SK.Nonce
+  , FromStringMaybe (PubKey 'Encrypt s)
+  , Hashable (PubKey 'Encrypt s)
+  )
 
 instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s)
 
@@ -142,7 +147,7 @@ instance ( Serialise  (GroupKey 'Symm s)
     pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
 
 
-generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m)
+generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
                  => Maybe GroupSecret
                  -> [PubKey 'Encrypt s]
                  -> m (GroupKey 'Symm s)
@@ -155,7 +160,10 @@ generateGroupKey mbk pks = GroupKeySymm <$> create
         box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
         pure (pk, box)
 
-lookupGroupKey :: ForGroupKeySymm s
+lookupGroupKey :: forall s .  ( ForGroupKeySymm s
+                              , PubKey 'Encrypt s ~ AK.PublicKey
+                              , PrivKey 'Encrypt s ~ AK.SecretKey
+                              )
                => PrivKey 'Encrypt s
                -> PubKey 'Encrypt s
                -> GroupKey 'Symm s
@@ -163,9 +171,7 @@ lookupGroupKey :: ForGroupKeySymm s
 
 lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
   (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk)
-  -- error  "FOUND SHIT!"
   gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs
-  -- error $ "DECRYPTED SHIT!"
   MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
 
 
@@ -278,8 +284,8 @@ instance ( MonadIO m
          , MonadError OperationError m
          , h ~ HbSync
          , Storage s h ByteString m
+         , sch ~ 'HBS2Basic
          -- TODO: why?
-         , sch ~ HBS2Basic
          ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
 
   data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
@@ -394,16 +400,17 @@ decryptBlock :: forall t s sto h m . ( MonadIO m
                                      )
 
              => sto
-             -> [KeyringEntry s]
+             -> (GroupKey 'Symm s -> m (Maybe GroupSecret))
              -> SmallEncryptedBlock t
              -> m t
 
-decryptBlock sto keys (SmallEncryptedBlock{..}) = do
+decryptBlock sto findKey (SmallEncryptedBlock{..}) = do
 
   gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0))
   gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs)
 
-  let gksec' = [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay
+  gksec' <- findKey gk
+  -- [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay
 
   gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
 
@@ -425,3 +432,17 @@ deriveGroupSecret n bs = key0
     prk = HKDF.extractSkip @_ @HbSyncHash bs
     key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
 
+
+loadGroupKeyMaybe :: ( ForGroupKeySymm s, MonadIO m
+                     ) => AnyStorage -> HashRef -> m (Maybe (GroupKey 'Symm s))
+loadGroupKeyMaybe sto h = do
+
+  runMaybeT do
+
+    bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h)))
+            <&> either (const Nothing) Just
+            >>= toMPlus
+
+    deserialiseOrFail bs
+      &  toMPlus
+

hbs2-core/lib/HBS2/Net/Auth/Schema.hs

@@ -5,7 +5,7 @@ module HBS2.Net.Auth.Schema
   , module HBS2.Net.Proto.Types
   ) where
 
-import HBS2.Prelude
+import HBS2.Prelude.Plated
 import HBS2.OrDie
 import HBS2.Net.Proto.Types
 import HBS2.Hash
@@ -17,21 +17,36 @@ import Crypto.PubKey.Ed25519 qualified as Ed
 import Crypto.KDF.HKDF qualified as HKDF
 import Crypto.Saltine.Class qualified as Saltine
 import Crypto.Saltine.Class (IsEncoding(..))
+import Crypto.Saltine.Core.Sign qualified as Sign
+import Crypto.Saltine.Core.Box qualified as Encrypt
+
 import Codec.Serialise
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString (ByteString)
 import Data.ByteArray ( convert)
 
-data HBS2Basic
 
-type instance Encryption L4Proto = HBS2Basic
+-- type ForSignatures s = ( Serialise ( PubKey 'Sign s)
+--                        , FromStringMaybe (PubKey 'Sign s)
+--                        , Signatures s
+--                        )
 
-type instance Encryption UNIX = HBS2Basic
+type instance Encryption L4Proto = 'HBS2Basic
 
+type instance Encryption UNIX = 'HBS2Basic
 
 type ForDerivedKey s = (IsEncoding (PrivKey 'Sign s), IsEncoding (PubKey 'Sign s))
 
-instance (MonadIO m, ForDerivedKey s, s ~ HBS2Basic) => HasDerivedKey s 'Sign Word64 m where
+type instance PubKey  'Sign 'HBS2Basic = Sign.PublicKey
+type instance PrivKey 'Sign 'HBS2Basic = Sign.SecretKey
+type instance PubKey  'Encrypt 'HBS2Basic = Encrypt.PublicKey
+type instance PrivKey 'Encrypt 'HBS2Basic = Encrypt.SecretKey
+
+-- type PrivKey 'Encrypt s
+
+-- type instance PubKey 'Sign
+
+instance (MonadIO m, ForDerivedKey s, s ~ 'HBS2Basic) => HasDerivedKey s 'Sign Word64 m where
   derivedKey nonce sk = do
 
     sk0 <- liftIO $ throwCryptoErrorIO (Ed.secretKey k0)

hbs2-core/lib/HBS2/Net/Dialog/Client.hs

@@ -1,194 +0,0 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE StrictData #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-module HBS2.Net.Dialog.Client where
-
--- import System.Clock
--- import System.Timeout
-import Codec.Serialise
-import Control.Arrow
-import Control.Exception qualified as Exception
-import Control.Monad
-import Control.Monad.Cont
-import Control.Monad.Error.Class
-import Control.Monad.Except (ExceptT(..), runExcept, runExceptT)
-import Control.Monad.IO.Unlift
-import Control.Monad.State.Class as State
-import Control.Monad.State.Strict (evalState, evalStateT)
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import Data.ByteString.Builder
-import Data.ByteString.Lazy qualified as BSL
-import Data.Default
-import Data.Generics.Labels
-import Data.Generics.Product.Fields
-import Data.List qualified as List
-import Data.Map.Strict as Map
-import Data.String.Conversions (cs, ConvertibleStrings)
-import Data.Time
-import GHC.Generics(Generic)
-import Lens.Micro.Platform
-import Streaming as S
-import Streaming.Prelude qualified as S
-import UnliftIO.Exception
-import UnliftIO.STM
-import UnliftIO.Timeout
-
-import HBS2.Net.Dialog.Core
-import HBS2.Net.Dialog.Helpers.Streaming
-
----
-
-dQuery_ :: MonadUnliftIO m
-    => RequestParams
-    -> DialogClient m peer
-    -> peer
-    -> Frames
-    -> m ()
-dQuery_ _par dcli peer rq =
-    withClientQuery dcli & \dialf ->
-        dialf peer rq' \_flow -> pure ()
-  where
-    rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>)
-
---
-dQuery1 :: (MonadUnliftIO m)
-    => RequestParams
-    -> DialogClient m peer
-    -> peer
-    -> Frames
-    -> m Frames
-
-dQuery1 par dcli peer rq = dQuery' par dcli peer rq \flow ->
-    either (throwIO . DQuery1Error) (pure . view _2) =<< headEither flow
-
-data DQuery1Error = DQuery1Error RequestResult
-  deriving (Show)
-
-instance Exception DQuery1Error
-
---
-dQuery' :: MonadUnliftIO m
-    => RequestParams
-    -> DialogClient m peer
-    -> peer
-    -> Frames
-    -> (Stream (Of (ResponseHeader, Frames)) m RequestResult -> m r)
-    -> m r
-
-dQuery' par dcli peer rq go =
-    withClientQuery dcli & \dialf -> do
-        dialf peer rq' \flow -> go $
-              flow
-            & withEffectsMay RequestTimeout (timeout' (requestParamsTimeout par))
-            & S.map decodeHeader
-            & stopAfterLeftMay (either
-                  (\(merr, xs) -> Left (Nothing, RequestErrorBadResponse merr xs))
-                  processResponseHeader
-                )
-
-  where
-
-    processResponseHeader :: (ResponseHeader, Frames) ->
-        Either
-            (Maybe (ResponseHeader, Frames), RequestResult)
-            (ResponseHeader, Frames)
-
-    processResponseHeader rhxs@(rh, xs) = case ((responseStatusCode . respStatus) rh) of
-        Success200 -> Left (Just rhxs, RequestDone)
-        SuccessNoContent204 -> Left (Just rhxs, RequestDone)
-        SuccessMore -> Right rhxs
-        BadRequest400 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
-        Forbidden403 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
-        NotFound404 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
-
-    rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>)
-
-timeout' :: MonadUnliftIO m => NominalDiffTime -> m a -> m (Maybe a)
-timeout' = timeout . round . (* 10^6) . nominalDiffTimeToSeconds
-
---
-decodeHeader :: Frames -> Either (BadResponse, Frames) (ResponseHeader, Frames)
-decodeHeader = evalState do
-    ex <- runExceptT cutFrameDecode'
-    xs <- State.get
-    pure $ ex
-        & left ((, xs) . maybe ResponseInsufficientFrames ResponseParseError)
-        & right (, xs)
-
-data RequestParams = RequestParams
-  { requestParamsTimeout :: NominalDiffTime
-  }
-  deriving (Generic)
-
-instance Default RequestParams where
-  def = RequestParams
-      { requestParamsTimeout = 5
-      }
-
-data DialogClient m p = DialogClient
-  { withClientQuery :: ClientQuery m p
-  }
-
-type ClientQuery m p = forall r .
-       p
-    -> Frames
-    -> (Stream (Of Frames) m RequestResult -> m r)
-    -> m r
-
-withClient :: forall m p i r . MonadUnliftIO m
-    => DClient m p i -> (DialogClient m p -> m r) -> m r
-withClient dclient go = do
-    callerID <- newCallerID
-
-    requestIDtvar <- newTVarIO 1
-
-    -- У обработчика получателя - своё окружение, в которое мы добавляем
-    -- обработчики ответов на запросы по requestID
-    requestResponseEnv <- newRequestResponseEnv
-
-    let withClientQuery' :: ClientQuery m p
-        withClientQuery' = \pid xs handleStream -> do
-            requestID <- atomically $ stateTVar requestIDtvar (id &&& succ)
-
-            ch <- newTQueueIO
-            let useResponse = RequestResponseHandler @m do
-                    atomically . writeTQueue ch
-            let
-                -- flow :: Stream (Of Frames) m RequestResult
-                flow = S.repeatM (atomically (readTQueue ch))
-
-            bracket_
-                (setupRepHandler requestResponseEnv requestID useResponse)
-                (clearRepHandler requestResponseEnv requestID)
-                (do
-
-                    clientSendProtoRequest dclient pid do
-                        xs & addEnvelope
-                            [ (BSL.toStrict . serialise) callerID
-                            , (BSL.toStrict . serialise) requestID
-                            ]
-
-                    handleStream flow
-                )
-
-    -- Установить в окружении обработчик получателя с callerID
-    let callerHandler = CallerHandler $ unFrames >>> \case
-
-            requestIDRaw:xs -> do
-                case deserialiseOrFail (BSL.fromStrict requestIDRaw) of
-                    Left _ ->
-                        -- Если не нашли, ничего не предпринимать
-                        -- На этот вопрос уже не ждут ответа
-                        pure ()
-                    Right requestID -> do
-                        mh <- findRepHandler requestResponseEnv requestID
-                        forM_ mh \(RequestResponseHandler h) -> h (Frames xs)
-
-            _ -> pure ()
-
-    bracket_
-        (setupCallerEnv (clientCallerEnv dclient) callerID callerHandler)
-        (clearCallerEnv (clientCallerEnv dclient) callerID)
-        (go (DialogClient {withClientQuery = withClientQuery'}))
-

hbs2-core/lib/HBS2/Net/Dialog/Core.hs

@@ -1,831 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE InstanceSigs          #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE StrictData #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- {-# LANGUAGE ConstraintKinds       #-}
--- {-# LANGUAGE OverloadedLists #-}
-
--- {-# LANGUAGE CPP                   #-}
--- {-# LANGUAGE DataKinds             #-}
--- {-# LANGUAGE FlexibleContexts      #-}
--- {-# LANGUAGE FlexibleInstances     #-}
--- {-# LANGUAGE MultiParamTypeClasses #-}
--- {-# LANGUAGE OverloadedStrings     #-}
--- {-# LANGUAGE RankNTypes            #-}
--- {-# LANGUAGE ScopedTypeVariables   #-}
--- {-# LANGUAGE TupleSections         #-}
--- {-# LANGUAGE TypeApplications      #-}
--- {-# LANGUAGE TypeFamilies          #-}
-
-
-module HBS2.Net.Dialog.Core where
-
-import Codec.Serialise
-import Control.Arrow
-import Control.Monad
-import Control.Monad.Error.Class
-import Control.Monad.Except (Except, ExceptT(..), runExcept, runExceptT)
-import Control.Monad.IO.Class
-import Control.Monad.State.Class as State
-import Control.Monad.State.Strict as StateStrict (evalState, evalStateT, runStateT, StateT(..))
-import Control.Monad.Trans.Class
-import Data.Binary.Get as Get
-import Data.Binary.Put as Put
-import Data.Bits
-import Data.Bool
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import Data.ByteString.Base16 qualified as B16
-import Data.ByteString.Char8 qualified as BS8
-import Data.ByteString.Lazy qualified as BSL
-import Data.Constraint (Dict(..))
-import Data.Foldable as F
-import Data.Function
-import Data.Functor
-import Data.Generics.Labels ()
-import Data.Generics.Product.Fields ()
-import Data.Generics.Sum.Constructors
-import Data.Kind
-import Data.List qualified as List
-import Data.List.NonEmpty qualified as NE
-import Data.Map.Strict as Map
-import Data.Maybe
-import Data.Proxy
-import Data.String.Conversions as X (cs)
-import Data.Text (Text)
-import Data.Typeable
-import Data.Word
-import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..))
-import GHC.Generics qualified as Generics
-import GHC.TypeLits
-import Lens.Micro.Platform
-import Streaming
-import System.Random.MWC
-import UnliftIO.STM
-
-import HBS2.Net.Dialog.Helpers.List
-
-type Frames = Frames' ByteString
-newtype Frames' a = Frames { unFrames :: [a] }
-  deriving stock (Generic,Eq)
-  deriving newtype (Functor, Foldable, Semigroup, Monoid
-      -- , IsList
-      )
-
-
-instance Show Frames where
-  show (Frames xs) = "Frames " <> show (BS.length <$> xs)
-      -- <> " " <> show (fmap B16.encode xs)
-      <> " " <> (show . fmap (limitSize 42)) xs
-
-    where
-      limitSize n as = bool as (BS.take (n-3) as <> "...") (BS.length as > n)
-
-framesBodyPart :: Traversal' Frames [ByteString]
-framesBodyPart = #unFrames . tailAfterP (== "")
-
-tailAfterP :: forall a . (a -> Bool) -> Traversal' [a] [a]
-tailAfterP p focus = fix \go -> \case
-    x:xs -> (x :) <$> bool go focus (p x) xs
-    xs -> pure xs
-
----
-
-encodeFrames :: Frames -> ByteString
--- encodeFrames :: Foldable t => t ByteString -> ByteString
-encodeFrames = F.toList >>> BSL.toStrict . runPut . \case
-
-    []   -> pure ()
-
-    xss -> flip fix xss \go -> \case
-        [] -> pure ()
-        bs:xs -> do
-            let (flip shiftR 1 -> n1, ns) = unfoldSizeBytes @Word64 . flip shiftL 1 . fromIntegral . BS.length $ bs
-
-            putWord8 $ n1
-                & bool (sbit 7) id (List.null xs)
-                & bool (sbit 6) id (List.null ns)
-
-            forM_ (markMore ns) \(n, isMoreBytesInSize) -> do
-                putWord8 $ n & bool (zbit 7) (sbit 7) isMoreBytesInSize
-
-            putByteString bs
-
-            go xs
-
-  where
-
-    markMore as = zip as ((True <$ List.drop 1 as) <> [False])
-
-    unfoldSizeBytes :: (Bits n, Integral n) => n -> (Word8, [Word8])
-    unfoldSizeBytes = (\(a NE.:| as) -> (a, as)) . NE.unfoldr \w ->
-        ( (flip shiftR 1 . flip shiftL 1 . fromIntegral) w
-        , let w' = shiftR w 7
-           in bool Nothing (Just w') (w' > 0)
-        )
-
-decodeFrames :: MonadError String m => ByteString -> m Frames
-decodeFrames = \case
-    "" -> pure mempty
-
-    bs' -> (bs' &) $ BSL.fromStrict >>> either (throwError . view _3) (pure . Frames . view _3)
-        <$> runGetOrFail do
-
-          fix \go -> do
-
-              j <- getWord8
-
-              bsize <-
-                  flip fix (6, j) \fu (b, j') -> do
-                      let n = (fromIntegral . clearLeftBits (8-b)) j'
-                      if tbit b j'
-                            then (n +) . flip shiftL b <$> (fu . (7, ) =<< getWord8)
-                            else pure n
-
-              bs <- getByteString bsize
-
-              let moreFrames = tbit 7 j
-
-              if moreFrames
-                then (bs :) <$> go
-                else pure [bs]
-
-  where
-    clearLeftBits n = flip shiftR n . flip shiftL n
-    tbit = flip testBit
-
-
-devDialogCore :: IO ()
-devDialogCore = do
-    display (Frames [])
-    display (Frames [""])
-    display (Frames [BS.replicate 32 0x55])
-    display (Frames [BS.replicate 32 0x55, ""])
-    display (Frames [BS.replicate 32 0x55, "\3\3"])
-    display (Frames [BS.replicate 33 0x55, "\3\3"])
-    display (Frames [BS.replicate 63 0x55])
-    display (Frames [BS.replicate 64 0x55])
-    -- display (Frames [BS.replicate 65 0x55])
-    display (Frames ["\8\8\8","\4\4\4"])
-    display (Frames ["","\1"])
-  where
-    display a = do
-        putStrLn . cs . show . B16.encode . encodeFrames $ a
-        putStrLn ""
-
-
-
-
-sbit :: (Bits n) => Int -> n -> n
-sbit = flip setBit
-
-zbit :: (Bits n) => Int -> n -> n
-zbit = flip clearBit
-
----
-
-decodeFramesFail :: (MonadFail m) => ByteString -> m Frames
-decodeFramesFail = errorToFail . decodeFrames
-
----
-
-errorToFailT :: (MonadFail m) => ExceptT String m a -> m a
-errorToFailT = either fail pure <=< runExceptT
-
-errorToFail :: MonadFail m => Except String a -> m a
-errorToFail = either fail pure . runExcept
-
-errorShowToFail :: (MonadFail m, Show s) => Except s a -> m a
-errorShowToFail = either (fail . show) pure . runExcept
-
---
-
-data CallerID = CallerID
-  { unCallerIDV :: Word8
-  , unCallerID :: Word32
-  }
-  deriving stock (Generic, Eq, Ord)
-
-instance Serialise CallerID
-
-newCallerID :: forall m. MonadIO m => m CallerID
-newCallerID = liftIO $ withSystemRandomST \g ->
-    CallerID <$> uniformM g <*> uniformM g
-
----
-
-newtype CallerHandler m = CallerHandler
-  { unCallerHandler :: Frames -> m ()
-  }
-
-newtype CallerEnv m = CallerEnv
-  { unCallerEnv :: TVar (Map CallerID (CallerHandler m)) }
-
-newCallerEnv :: MonadIO m => m (CallerEnv m')
-newCallerEnv = CallerEnv <$> newTVarIO mempty
-
----
-
-newtype RequestResponseHandler m = RequestResponseHandler
-  { unRequestResponseHandler :: Frames -> m ()
-  }
-
-newtype RequestResponseEnv m = RequestResponseEnv
-  { unRequestResponseEnv :: TVar (Map RequestID (RequestResponseHandler m))
-  }
-
-newRequestResponseEnv :: MonadIO m => m (RequestResponseEnv m')
-newRequestResponseEnv =
-    RequestResponseEnv <$> newTVarIO mempty
-
----
-
-data DClient m p i = DClient
-  { clientCallerEnv :: CallerEnv m
-  , clientSendProtoRequest :: p -> Frames -> m ()
-  , clientGetKnownPeers :: m [(p, i)]
-  }
-
----
-
-newtype RequestID = RequestID { unRequestID :: Word32 }
-  deriving stock (Generic, Eq, Ord)
-  deriving newtype (Serialise, Num, Enum)
-  -- deriving  via TODO_GenericVLQ Put Get
-
-data RequestResult
-  = RequestDone
-  -- | RequestSuccessIncomplete
-  | RequestTimeout
-  | RequestFailure ResponseStatus Frames
-  | RequestErrorBadResponse BadResponse Frames
-  deriving stock (Generic, Eq, Show)
-
-data BadResponse
-  = ResponseErrorNoResponseHeader
-  | ResponseInsufficientFrames
-  | ResponseParseError DeserialiseFailure
-  deriving stock (Generic, Eq, Show)
-
----
-
-setupCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> CallerHandler m' -> m ()
-setupCallerEnv env callerID repHandleEnv =
-    (atomically . modifyTVar' (unCallerEnv env))
-        (at callerID ?~ repHandleEnv)
-
-clearCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> m ()
-clearCallerEnv env callerID =
-    (atomically . modifyTVar' (unCallerEnv env))
-        (at callerID .~ Nothing)
-
-findCallerHandler :: MonadIO m => CallerEnv m' -> CallerID -> m (Maybe (CallerHandler m'))
-findCallerHandler CallerEnv{..} callerID =
-    readTVarIO unCallerEnv <&> preview (ix callerID)
-
----
-
-setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m ()
-setupRepHandler RequestResponseEnv{..} requestID useResponse =
-    (atomically . modifyTVar' unRequestResponseEnv)
-        (at requestID ?~ useResponse)
-
-clearRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m ()
-clearRepHandler RequestResponseEnv{..} requestID =
-    (atomically . modifyTVar' unRequestResponseEnv)
-        (at requestID .~ Nothing)
-
-findRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m (Maybe (RequestResponseHandler m'))
-findRepHandler RequestResponseEnv{..} requestID =
-    readTVarIO unRequestResponseEnv <&> preview (ix requestID)
-
----
-
-data DialogRequestEnv m p pd = DialogRequestEnv
-    { dreqEnvPeer :: p
-    , dreqEnvGetPeerData :: m pd
-    }
-
--- data DialogRequestError
---   = DialogRequestFailure String
---   deriving stock (Show)
--- instance Exception DialogRequestError
-
----
-
--- type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
-type DApp m = Frames -> (Frames -> m ()) -> m ()
-
-mkDApp ::
-    forall spec ctx m io.
-    ( Monad m
-    , Monad io
-    , HasHandler m (NamedSpec spec) ctx
-    , HasHandler io (NamedSpec spec) ctx
-    )
-    => Proxy (NamedSpec spec)
-    -> Ctx ctx
-    -> (forall x. m x -> DialHandlerT io x)
-    -> spec (ModeServerT m)
-    -> DApp io
-mkDApp p ctx ntToDialHandlerTn hd = routeDialogRequest rr
-  where
-    rr :: DialogRequestRouter io
-    rr = route p ctx
-        $ hoistDialogWithContext p (Proxy @ctx) ntToDialHandlerTn
-          hd
-
-type DialogReplyHandler m = (Frames -> m ()) -> m ()
-
-type DialogRequestRouter (m :: Type -> Type) =
-     DialogRequestRoutes (DialogReplyHandler m)
-
-data DialogRequestRoutes (h :: Type)
-  = DialogRequestPaths (Map ByteString (DialogRequestRoutes h))
-  | DialogRequestPreparse (Frames -> Either Text (DialogRequestRoutes h, Frames))
-  | DialogRequestEndpoint h
-  deriving (Generic, Functor)
-
-instance Semigroup (DialogRequestRoutes h) where
-  (<>) a b = case (a, b) of
-      (DialogRequestPaths p1, DialogRequestPaths p2) ->
-          DialogRequestPaths (p1 <> p2)
-      _ -> b
-
--- instance Monoid (DialogRequestRoutes h) where
---   mempty = DialogRequestPaths mempty
-
-dialogRequestRoutes
-    :: ListBuilder
-          ([ByteString], Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
-    -> DialogRequestRouter m
-dialogRequestRoutes = List.foldl1' (<>)
-      . fmap toPaths
-      . over (traverse . _2) (DialogRequestPreparse . (fmap . fmap) (over _1 DialogRequestEndpoint))
-      . buildList
-  where
-    toPaths :: ([ByteString], DialogRequestRoutes ((Frames -> m ()) -> m ()))
-       -> DialogRequestRoutes (DialogReplyHandler m)
-    toPaths = fix \go (ps, rr) -> case ps of
-        [] -> rr
-        [p] -> DialogRequestPaths (Map.singleton p rr)
-        p:px' -> DialogRequestPaths (Map.singleton p (go (px', rr)))
-
-hand :: Monad m => a -> b -> ListBuilderT m (a, b)
-hand = curry li
-
-handconv :: (Monad m, Monad m', Serialise req, Serialise resp)
-    => a
-    -> Text
-    -> (req -> ExceptT ResponseStatus m resp)
-    -> ListBuilderT m' (a, Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
-handconv path msg h =
-    hand path $ processReply msg h
-
----
-
-processReply :: forall m m' req resp .
-    ( Monad m
-    , Serialise req
-    , Serialise resp
-    , m' ~ ExceptT ResponseStatus m
-    )
-    => Text
-    -> (req -> m' resp)
-    -> Frames
-    -> Either Text ((Frames -> m ()) -> m (), Frames)
-processReply msg h = runExcept . runStateT do
-    flip runReply . h <$> cutFrameDecode msg
-
-runReply ::
-    ( Monad m
-    , Serialise a
-    )
-    => (Frames -> m r)
-    -> ExceptT ResponseStatus m a
-    -> m r
-runReply reply =
-        either
-            (\e -> reply (Frames [serialiseS (ResponseHeader e 0)]))
-            (\a -> reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
-                                  , serialiseS a
-                                  ])
-            )
-    <=< runExceptT
-
----
-
-dpath :: Text -> [ByteString] -> Frames
-dpath path = Frames . (cs path :)
-
----
-
-addEnvelope :: Monoid a => [a] -> Frames' a -> Frames' a
-addEnvelope en = over #unFrames ((en <> [mempty]) <>)
-
-splitEnvelope :: (Monoid a, Eq a) => Frames' a -> ([a], Frames' a)
-splitEnvelope = fmap (Frames . List.drop 1) . List.break (== mempty) . unFrames
-
-data ResponseHeader = ResponseHeader
-  { respStatus :: ResponseStatus
-  , respSeqNumber :: Int
-  }
-  deriving (Generic, Show, Eq)
-
-instance Serialise ResponseHeader
-
-data ResponseStatus = ResponseStatus
-  { responseStatusCode :: ResponseStatusCode
-  , responseStatusMessage :: Text
-  }
-  deriving (Generic, Show, Eq)
-
-instance Serialise ResponseStatus
-
-data ResponseStatusCode
-  = Success200
-  | SuccessNoContent204
-  | SuccessMore
-  | BadRequest400
-  | Forbidden403
-  | NotFound404
-  deriving (Generic, Show, Eq)
-
-instance Serialise ResponseStatusCode
-
-routerSignature :: Word8
-routerSignature = 1
-
-routeDialogRequest :: forall m .
-       Monad m
-    => DialogRequestRouter m
-    -> Frames
-    -> (Frames -> m ())
-    -> m ()
-routeDialogRequest router frames rawReplyToPeer = do
-    -- error $ show router
-    erun <- pure $ runExcept $ flip evalStateT req do
-
-        signature <- cutFrameDecode
-            (ResponseStatus BadRequest400 "No signature in request")
-
-        when (signature /= routerSignature) $ throwError
-            (ResponseStatus BadRequest400 "Wrong signature in request")
-
-        path <- cutFrameOr
-            (ResponseStatus BadRequest400 "No path in request")
-
-        lift . ExceptT . pure
-              -- Если не может разобрать параметры запроса,
-              -- то самим ответить этому пиру '404'
-              -- . left (ResponseStatus BadRequest400)
-              . travel (BS8.split '/' path) router
-              -- передать оставшуюся часть запроса в хэндлер
-            =<< get
-
-    case erun of
-        Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)])
-        Right go ->
-            -- передать хэндлеру продолжение чтобы ответить этому пиру
-            go replyToPeer
-
-  where
-    (backPath, req) = splitEnvelope frames
-
-    replyToPeer :: Frames -> m ()
-    replyToPeer = rawReplyToPeer . over #unFrames (backPath <>)
-
-travel :: ()
-    => [ByteString]
-    -> DialogRequestRouter m
-    -> Frames
-    -> Either ResponseStatus ((Frames -> m ()) -> m ())
-travel path'' router'' = evalStateT $ flipfix2 path'' router''
-    \go path -> \case
-        DialogRequestPaths kv -> case path of
-            step:path' ->
-                maybe
-                    (throwError (ResponseStatus BadRequest400 "Path not found"))
-                    (go path')
-                    (Map.lookup step kv)
-            _ -> throwError (ResponseStatus BadRequest400 "Path not found (too long)")
-        DialogRequestPreparse hfx ->
-            go path =<< StateT (left (ResponseStatus BadRequest400) . hfx)
-        DialogRequestEndpoint ep -> pure ep
-
-flipfix2 :: a -> b -> ((a -> b -> c) -> (a -> b -> c)) -> c
-flipfix2 a b f = fix f a b
-
-cutFrameDecode :: (Serialise b, MonadState Frames m, MonadError e m) => e -> m b
-cutFrameDecode e =
-    State.gets unFrames >>= \case
-        x:xs ->
-            (either (const (throwError e)) pure . deserialiseOrFailS) x
-                <* State.put (Frames xs)
-        _ -> throwError e
-
-cutFrameDecode'
-    :: (Serialise b, MonadState Frames m, MonadError (Maybe DeserialiseFailure) m)
-    => m b
-cutFrameDecode' =
-    State.gets unFrames >>= \case
-        x:xs ->
-            (either (throwError . Just) pure . deserialiseOrFailS) x
-                <* State.put (Frames xs)
-        _ -> throwError Nothing
-
-cutFrameOr :: (MonadState (Frames' b) m, MonadError e m) => e -> m b
-cutFrameOr e =
-    State.gets unFrames >>= \case
-        x:xs -> x <$ State.put (Frames xs)
-        _ -> throwError e
-
-serialiseS :: Serialise a => a -> ByteString
-serialiseS = BSL.toStrict . serialise
-
-deserialiseOrFailS :: Serialise a => ByteString -> Either DeserialiseFailure a
-deserialiseOrFailS = deserialiseOrFail . BSL.fromStrict
-
-fromMaybeM :: Applicative m => m a -> Maybe a -> m a
-fromMaybeM ma = maybe ma pure
-
-fromJustThrowError :: MonadError e m => e -> Maybe a -> m a
-fromJustThrowError = fromMaybeM . throwError
-
-
-
-------------------------------------------
---- Type-level specification -------------
-------------------------------------------
-
-
-data ReqCBOR (a :: Type)
-data SingleAck
-data SingleRespCBOR (a :: Type)
-data StreamingRespCBOR (a :: Type)
-
-data NamedSpec (spec :: Type -> Type)
-
-class DialMode mode where
-    type mode &- spec :: Type
-infixl 0 &-
-
-data (path :: k) &/ (a :: Type)
-    deriving (Typeable)
-infixr 4 &/
-
-type path &// a = path &/ NamedSpec a
-infixr 4 &//
-
----
-
-data ModePlain
-instance DialMode ModePlain where
-    type ModePlain &- spec = spec
-
----
-
-data ModeServerT (m :: Type -> Type)
-
-instance DialMode (ModeServerT m) where
-    type ModeServerT m &- spec = HandlerD spec m
-
-class HasHandler m spec ctx where
-  type HandlerD spec (m' :: Type -> Type) :: Type
-
-  route ::
-       Proxy spec
-    -> Ctx ctx
-    -> HandlerD spec (DialHandlerT m)
-    -> DialogRequestRouter m
-
-  hoistDialogWithContext
-      :: Proxy spec
-      -> Proxy ctx
-      -> (forall x. m x -> n x)
-      -> HandlerD spec m
-      -> HandlerD spec n
-
-data EmptyCX -- '[]
-data Ctx ctx where
-    EmptyCtx :: Ctx EmptyCX
-    -- (:&.) :: x -> Ctx xs -> Ctx (x ': xs)
--- infixr 5 :&.
-
--- hoistTRouter :: forall t m n .
---       (MonadTrans t, Monad m, Monad n, m ~ t n)
---       => (forall a . m a -> n a)
---       -> DialogRequestRouter m
---       -> DialogRequestRouter n
--- hoistTRouter nt = fmap nt'
---   where
---     nt' :: ((x -> m y) -> m y)
---         -> ((x -> n y) -> n y)
---     nt' xtmy_tmy =  nt . xtmy_tmy . fmap lift
-
-hoistTRouter :: forall m n .
-      (Monad m, Monad n)
-      => (forall a . m a -> n a)
-      -> (forall a . n a -> m a)
-      -> DialogRequestRouter m
-      -> DialogRequestRouter n
-hoistTRouter ntf ntb = fmap nt'
-  where
-    nt' :: ((x -> m y) -> m y)
-        -> ((x -> n y) -> n y)
-    nt' xtmy_tmy =  ntf . xtmy_tmy . fmap ntb
-
-
-type DialHandlerIO a = DialHandlerT IO a
-newtype DialHandlerT m a = DialHandlerT { runDialHandlerT :: ExceptT ResponseStatus m a }
-  deriving
-    ( Generic, Functor, Applicative, Monad
-    , MonadIO
-    , MonadTrans
-    , MonadError ResponseStatus
-    -- , MonadUnliftIO
-    -- , MonadThrow, MonadCatch, MonadMask
-    )
-
----
-
-instance (KnownSymbol path, HasHandler m spec ctx) => HasHandler m (path &/ spec) ctx where
-    type HandlerD (path &/ spec) m = HandlerD spec m
-
-    route _ ctx h = DialogRequestPaths $
-        Map.singleton (cs (symbolVal (Proxy @path))) (route (Proxy @spec) ctx h)
-
-    hoistDialogWithContext _ = hoistDialogWithContext (Proxy @spec)
-
----
-
-instance
-  ( Serialise a
-  , Typeable a
-  , HasHandler m spec ctx
-  ) =>
-  HasHandler m (ReqCBOR a &/ spec) ctx where
-    type HandlerD (ReqCBOR a &/ spec) m = a -> HandlerD spec m
-
-    route _ ctx (ha :: a -> HandlerD spec (DialHandlerT m)) =
-        DialogRequestPreparse \fx -> do
-            (a, fx')
-                <- runExcept
-                  $ flip runStateT fx
-                  $ cutFrameDecode ((cs . show . typeRep) (Proxy @a))
-            pure (route (Proxy @spec) ctx (ha a), fx')
-
-    hoistDialogWithContext _ pc nt s = hoistDialogWithContext (Proxy @spec) pc nt . s
-
----
-
-instance
-  ( Applicative m
-  ) =>
-  HasHandler m SingleAck ctx where
-    type HandlerD SingleAck m = m ()
-
-    route _ _ctx _mx =
-        DialogRequestEndpoint \reply -> do
-            reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessNoContent204 "") 0)])
-
-    hoistDialogWithContext _ _ nt hdlM = nt hdlM
-
----
-
-instance
-  ( Monad m
-  , Serialise a
-  ) =>
-  HasHandler m (SingleRespCBOR a) ctx where
-    type HandlerD (SingleRespCBOR a) m = m a
-
-    route _ _ctx ma =
-        DialogRequestEndpoint \reply -> do
-
-            ea <- runExceptT $ runDialHandlerT ma
-
-            case ea of
-                Left e -> reply $ Frames [ serialiseS e ]
-                Right a -> reply $ Frames
-                    [ serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
-                    , serialiseS (a :: a)
-                    ]
-
-    hoistDialogWithContext _ _ nt hdlM = nt hdlM
-
----
-
-instance
-  ( Serialise a
-  ) =>
-  HasHandler m (StreamingRespCBOR a) ctx where
-    type HandlerD (StreamingRespCBOR a) m = Stream (Of a) m ()
-
-    route = undefined
-
-    -- hoistDialogWithContext = undefined
-
----
-
-type GServerConstraints spec m =
-  ( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
-  , GProduct (Rep (spec (ModeServerT m)))
-  )
-
-class GServer (spec :: Type -> Type) (m :: Type -> Type) where
-  gServerProof :: Dict (GServerConstraints spec m)
-
-instance
-  ( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
-  , GProduct (Rep (spec (ModeServerT m)))
-  ) => GServer spec m where
-  gServerProof = Dict
-
-
-instance
-  ( HasHandler m (GToProduct (Rep (spec ModePlain))) ctx
-  -- , HasHandler m (GToProduct (Rep (spec (ModeServerT m)))) ctx
-  -- , GProduct (Rep (spec ModePlain))
-  , forall q . Generic (spec (ModeServerT q))
-  , forall q . GServer spec q
-  ) =>
-  HasHandler m (NamedSpec spec) ctx where
-    type HandlerD (NamedSpec spec) m = spec (ModeServerT m)
-
-    route ::
-           Proxy (NamedSpec spec)
-        -> Ctx ctx
-        -> spec (ModeServerT (DialHandlerT m))
-        -> DialogRequestRouter m
-    route _ ctx spec =
-      case gServerProof @spec @(DialHandlerT m) of
-          Dict -> route (Proxy @(GToProduct (Rep (spec ModePlain)))) ctx (toProduct spec)
-
-    hoistDialogWithContext
-      :: forall n. Proxy (NamedSpec spec)
-      -> Proxy ctx
-      -> (forall x. m x -> n x)
-      -> spec (ModeServerT m)
-      -> spec (ModeServerT n)
-    hoistDialogWithContext _ pctx nat dl =
-      case (gServerProof @spec @m, gServerProof @spec @n) of
-        (Dict, Dict) ->
-            fromProduct dlN
-          where
-            dlM :: HandlerD (GToProduct (Rep (spec ModePlain))) m =
-              toProduct dl
-            dlN :: HandlerD (GToProduct (Rep (spec ModePlain))) n =
-              hoistDialogWithContext (Proxy @(GToProduct (Rep (spec ModePlain)))) pctx nat dlM
-
-
-toProduct :: (Generic (spec mode), GProduct (Rep (spec mode)))
-    => spec mode -> GToProduct (Rep (spec mode))
-toProduct = gtoProduct . Generics.from
-
-fromProduct
-    :: (Generic (spec mode), GProduct (Rep (spec mode)))
-    => GToProduct (Rep (spec mode)) -> spec mode
-fromProduct = Generics.to . gfromProduct
-
-instance
-  ( HasHandler m speca ctx
-  , HasHandler m specb ctx
-  ) =>
-  HasHandler m (GP speca specb) ctx where
-    type HandlerD (GP speca specb) m = GP (HandlerD speca m) (HandlerD specb m)
-    route _ ctx (GP speca specb) =
-            route (Proxy @speca) ctx speca
-        <>  route (Proxy @specb) ctx specb
-
-    hoistDialogWithContext _ pc nt (GP speca specb) =
-      GP
-        (hoistDialogWithContext (Proxy @speca) pc nt speca)
-        (hoistDialogWithContext (Proxy @specb) pc nt specb)
-
-data GP a b = GP a b
-
-class GProduct f where
-    type GToProduct (f :: Type -> Type)
-    gtoProduct   :: f p -> GToProduct f
-    gfromProduct :: GToProduct f -> f p
-
-instance (GProduct l, GProduct r) => GProduct (l :*: r) where
-    type GToProduct (l :*: r) = GP (GToProduct l) (GToProduct r)
-    gtoProduct   (l :*: r)  = GP (gtoProduct l) (gtoProduct r)
-    gfromProduct (GP l r) = gfromProduct l :*: gfromProduct r
-
-instance GProduct f => GProduct (M1 i c f) where
-    type GToProduct (M1 i c f) = GToProduct f
-    gtoProduct   = gtoProduct . unM1
-    gfromProduct = M1 . gfromProduct
-
-instance GProduct (K1 i c) where
-    type GToProduct (K1 i c) = c
-    gtoProduct = unK1
-    gfromProduct = K1

hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs

@@ -1,19 +0,0 @@
-module HBS2.Net.Dialog.Helpers.List where
-
-import Control.Monad.Trans.Writer.CPS qualified as W
-import Data.Functor.Identity
-import Data.Monoid
-
-type ListBuilder a = ListBuilderT Identity a
-
-type ListBuilderT m a = W.WriterT (Endo [a]) m ()
-
-buildList :: ListBuilder a -> [a]
-buildList = runIdentity . buildListT
-
-buildListT :: Monad m => ListBuilderT m a -> m [a]
-buildListT = fmap (flip appEndo []) . W.execWriterT
-
-li :: Monad m => a -> ListBuilderT m a
-li = W.tell . Endo . (:)
-

hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs

@@ -1,88 +0,0 @@
-module HBS2.Net.Dialog.Helpers.Streaming where
-
-import Control.Monad.Fix
-import Data.ByteString qualified as BS
-import Data.Int
-import Data.Map.Strict qualified as Map
-import Data.Maybe
-import Data.Set qualified as Set
-import Streaming as S
-import Streaming.Internal
-import Streaming.Prelude (cons)
-import Streaming.Prelude qualified as S
-import UnliftIO.Async
-import UnliftIO.STM
-import Prelude hiding (cons)
-
-withEffects
-    :: (Functor m, Functor f, s ~ Stream f m r)
-    => (forall a. m a -> m a)
-    -> s
-    -> s
-withEffects trans = fix \go -> \case
-    Return r -> Return r
-    Effect m -> Effect (trans (fmap go m))
-    Step f -> Step (fmap go f)
-{-# INLINEABLE withEffects #-}
-
-withEffectsMay
-    :: (Monad m, Functor f, s ~ Stream f m r)
-    => r
-    -> (forall a. m a -> m (Maybe a))
-    -> s
-    -> s
-withEffectsMay d trans = fix \go -> \case
-    Return r -> Return r
-    Effect m -> Effect (fromMaybe (Return d) <$> trans (fmap go m))
-    Step f -> Step (fmap go f)
-{-# INLINEABLE withEffectsMay #-}
-
-stopOnLeft
-    :: (Monad m)
-    => (a -> Either r b)
-    -> Stream (Of a) m r
-    -> Stream (Of b) m r
-stopOnLeft f = fix \go -> \case
-    Return r -> Return r
-    Effect m -> Effect (go <$> m)
-    Step (a :> s) -> either Return (\b -> Step (b :> go s)) (f a)
-{-# INLINEABLE stopOnLeft #-}
-
-stopAfterLeftMay
-    :: (Monad m)
-    => (a -> Either (Maybe b, r) b)
-    -> Stream (Of a) m r
-    -> Stream (Of b) m r
-stopAfterLeftMay f = fix \go -> \case
-    Return r -> Return r
-    Effect m -> Effect (go <$> m)
-    Step (a :> s) -> either
-          (\(mb, r) -> maybe
-                  (Return r)
-                  (\b -> Step (b :> Return r))
-                  mb)
-          (\b -> Step (b :> go s))
-          (f a)
-{-# INLINEABLE stopAfterLeftMay #-}
-
-stopAfter
-    :: (Monad m)
-    => (a -> Maybe r)
-    -> Stream (Of a) m r
-    -> Stream (Of a) m r
-stopAfter f = fix \go -> \case
-    Return r -> Return r
-    Effect m -> Effect (go <$> m)
-    Step (a :> s) -> Step (a :> (maybe (go s) Return (f a)))
-{-# INLINEABLE stopAfter #-}
-
-headEither
-    :: (Monad m)
-    => Stream (Of a) m r
-    -> m (Either r a)
-headEither = fix \go -> \case
-    Return r -> pure (Left r)
-    Effect ms -> go =<< ms
-    Step (a :> _) -> pure (Right a)
-{-# INLINEABLE headEither #-}
-

hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs

@@ -76,10 +76,10 @@ mySipHash s = BA.sipHash (SipKey a b) s
 --
 
 
-data ByPassOpts e =
+data ByPassOpts s =
   ByPassOpts
   { byPassEnabled    :: Bool
-  , byPassKeyAllowed :: PubKey 'Sign (Encryption e) -> IO Bool
+  , byPassKeyAllowed :: PubKey 'Sign s -> IO Bool
   , byPassTimeRange  :: Maybe (Int, Int)
   }
 
@@ -101,7 +101,7 @@ instance Serialise ByPassStat
 
 data ByPass e them =
   ByPass
-  { opts         :: ByPassOpts e
+  { opts         :: ByPassOpts (Encryption e)
   , self         :: Peer e
   , pks          :: PubKey 'Sign (Encryption e)
   , sks          :: PrivKey 'Sign (Encryption e)
@@ -128,7 +128,7 @@ type ForByPass e   = ( Hashable (Peer e)
                      , Serialise (PubKey 'Sign (Encryption e))
                      , PrivKey 'Encrypt (Encryption e) ~ PKE.SecretKey
                      , PubKey 'Encrypt (Encryption e) ~ PKE.PublicKey
-                     , ForSignedBox e
+                     , ForSignedBox (Encryption e)
                      )
 
 
@@ -136,12 +136,12 @@ data HEYBox e =
   HEYBox Int (PubKey 'Encrypt (Encryption e))
   deriving stock Generic
 
-instance ForByPass e => Serialise (HEYBox e)
+instance ForByPass s => Serialise (HEYBox s)
 
 data EncryptHandshake e =
     HEY
     { heyNonceA :: NonceA
-    , heyBox    :: SignedBox (HEYBox e) e
+    , heyBox    :: SignedBox (HEYBox e) (Encryption e)
     }
   deriving stock (Generic)
 
@@ -210,7 +210,7 @@ newByPassMessaging :: forall e w m . ( ForByPass e
                                      , MonadIO m
                                      , Messaging w e ByteString
                                      )
-                   => ByPassOpts e
+                   => ByPassOpts (Encryption e)
                    -> w
                    -> Peer e
                    -> PubKey 'Sign (Encryption e)
@@ -370,10 +370,11 @@ makeKey a b = runIdentity do
   pure $ (f0 `shiftL` 16) .|. f1
 
 
-sendHey :: forall e w m . ( ForByPass e
+sendHey :: forall e w m s . ( ForByPass e
-                          , Messaging w e ByteString
+                            , Messaging w e ByteString
-                          , MonadIO m
+                            , MonadIO m
-                          )
+                            , s ~ Encryption e
+                            )
         => ByPass e w
         -> Peer e
         -> m ()
@@ -387,7 +388,7 @@ sendHey bus whom = do
   ts <- liftIO getPOSIXTime <&> round
 
   let hbox = HEYBox @e ts (pke bus)
-  let box = makeSignedBox @e (pks bus) (sks bus) hbox
+  let box = makeSignedBox @s (pks bus) (sks bus) hbox
   let hey = HEY @e (nonceA bus) box
   let msg = pref <> serialise hey
 

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

@@ -0,0 +1,100 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE NumericUnderscores #-}
+module HBS2.Net.Messaging.Pipe where
+
+import HBS2.Prelude.Plated
+import HBS2.Net.Proto.Types
+import HBS2.Actors.Peer.Types
+import HBS2.Net.Messaging
+
+import Control.Concurrent.STM qualified as STM
+import Control.Monad.Reader
+import Data.ByteString.Builder qualified as B
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+import Data.Hashable
+import Network.ByteOrder hiding (ByteString)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Posix.IO
+import UnliftIO
+
+-- define new transport protocol type
+data PIPE = PIPE
+            deriving (Eq,Ord,Show,Generic)
+
+
+-- address for the new protocol
+newtype PipeAddr = PipeAddr Handle
+                   deriving newtype (Eq,Show)
+
+-- the protocol work data
+data MessagingPipe =
+  MessagingPipe
+  { pipeIn  :: Handle
+  , pipeOut :: Handle
+  , inQ     :: TQueue ByteString
+  }
+
+remotePeer :: MessagingPipe -> Peer PIPE
+remotePeer = PeerPIPE . PipeAddr . pipeOut
+
+localPeer :: MessagingPipe -> Peer PIPE
+localPeer = PeerPIPE . PipeAddr . pipeIn
+
+newMessagingPipe :: MonadIO m => (Handle, Handle) -> m MessagingPipe
+newMessagingPipe (pIn,pOut) = do
+  MessagingPipe pIn pOut
+    <$> newTQueueIO
+
+instance Hashable PipeAddr where
+  hashWithSalt salt (PipeAddr pip) = hashWithSalt salt ("pipe-addr", fd)
+    where
+      fd = unsafePerformIO (handleToFd pip <&> fromIntegral @_ @Word)
+
+instance HasPeer PIPE where
+  newtype instance Peer PIPE = PeerPIPE { _fromPeerPipe :: PipeAddr }
+    deriving stock (Eq,Show,Generic)
+    deriving newtype (Hashable)
+
+instance Pretty (Peer PIPE) where
+  pretty (PeerPIPE p) = parens ("pipe" <+> viaShow p)
+
+-- Messaging definition for protocol
+instance Messaging MessagingPipe PIPE ByteString where
+
+  sendTo bus _ _ msg = liftIO do
+    LBS.hPutStr (pipeOut bus) (B.toLazyByteString frame <> msg)
+    hFlush (pipeOut bus)
+
+    where
+      frame = B.word32BE (fromIntegral $ LBS.length msg)
+
+  receive bus _ = do
+    msg <- liftIO $ atomically $ peekTQueue q >> STM.flushTQueue q
+    for msg $ \m -> pure (From (PeerPIPE (PipeAddr who)), m)
+
+    where
+      q = inQ bus
+      who = pipeIn bus
+
+runMessagingPipe :: MonadIO m => MessagingPipe -> m ()
+runMessagingPipe bus = liftIO do
+  fix \next -> do
+    frame <- LBS.hGet who 4 <&> word32 . LBS.toStrict
+    piece <- LBS.hGet who (fromIntegral frame)
+    atomically (writeTQueue (inQ bus) piece)
+    next
+
+  where
+    who = pipeIn bus
+
+instance (MonadIO m, Messaging MessagingPipe PIPE (Encoded PIPE))
+  => HasFabriq PIPE (ReaderT MessagingPipe m) where
+  getFabriq = asks Fabriq
+
+instance MonadIO m => HasOwnPeer PIPE (ReaderT MessagingPipe m) where
+  ownPeer = asks localPeer
+
+

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

@@ -4,6 +4,7 @@ module HBS2.Net.Messaging.Unix
   ( module HBS2.Net.Messaging.Unix
   , module HBS2.Net.Messaging
   , module HBS2.Net.Proto.Types
+  , SocketClosedException
   ) where
 
 import HBS2.Prelude.Plated
@@ -220,12 +221,23 @@ runMessagingUnix env = do
             atomically $ writeTVar seen now
             next
 
+
+    clientLoop m = fix \next -> do
+      m
+      if not (MUDontRetry `elem` msgUnixOpts env) then do
+        debug "LOOP!"
+        next
+      else do
+        debug "LOOP EXIT"
+
     handleClient | MUDontRetry `elem` msgUnixOpts env  = \_ w -> handleAny throwStopped w
-                 | otherwise = handleAny
+                 | otherwise =  handleAny
 
     throwStopped _ = throwIO UnixMessagingStopped
 
-    runClient = liftIO $ forever $ handleClient logAndRetry $ flip runContT pure $ do
+    runClient = liftIO $ clientLoop $ handleClient logAndRetry $ flip runContT pure $ do
+
+      debug "HERE WE GO AGAIN!"
 
       let sa   = SockAddrUnix (msgUnixSockPath env)
       let p  = msgUnixSockPath env
@@ -335,6 +347,7 @@ runMessagingUnix env = do
 
       pause (msgUnixRetryTime env)
 
+
     logAndRetry :: SomeException -> IO ()
     logAndRetry e = do
       warn $ "MessagingUnix. runClient failed, probably server is gone. Retrying:" <+> pretty (msgUnixSelf env)

hbs2-core/lib/HBS2/Net/Proto/Types.hs

@@ -9,7 +9,6 @@ module HBS2.Net.Proto.Types
   ) where
 
 import HBS2.Prelude.Plated
-import HBS2.Clock
 import HBS2.Net.IP.Addr
 
 import Control.Applicative
@@ -37,14 +36,19 @@ data CryptoAction = Sign | Encrypt
 data GroupKeyScheme = Symm | Asymm
   deriving stock (Eq,Ord,Show,Data,Generic)
 
-type family PubKey  (a :: CryptoAction) e  :: Type
+data CryptoScheme = HBS2Basic
-type family PrivKey (a :: CryptoAction) e  :: Type
 
-type family Encryption e :: Type
+type family PubKey  (a :: CryptoAction) (s :: CryptoScheme) :: Type
+
+type family PrivKey (a :: CryptoAction) (s :: CryptoScheme) :: Type
+
+type family Encryption e :: CryptoScheme
+
+type instance Encryption L4Proto = 'HBS2Basic
 
 type family KeyActionOf k :: CryptoAction
 
-data family GroupKey (scheme :: GroupKeyScheme) s
+data family GroupKey (scheme :: GroupKeyScheme) (s :: CryptoScheme)
 
 -- NOTE: throws-error
 class  MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where
@@ -53,9 +57,9 @@ class  MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where
 -- TODO: move-to-an-appropriate-place
 newtype AsGroupKeyFile a = AsGroupKeyFile a
 
-data family ToEncrypt (scheme :: GroupKeyScheme) s a -- = ToEncrypt a
+data family ToEncrypt (scheme :: GroupKeyScheme) (s :: CryptoScheme) a -- = ToEncrypt a
 
-data family ToDecrypt (scheme :: GroupKeyScheme) s a
+data family ToDecrypt (scheme :: GroupKeyScheme) (s :: CryptoScheme) a
 
 -- FIXME: move-to-a-crypto-definition-modules
 
@@ -168,7 +172,6 @@ instance HasPeer L4Proto where
     }
     deriving stock (Eq,Ord,Show,Generic)
 
-
 instance AddrPriority (Peer L4Proto) where
   addrPriority (PeerL4 _ sa) = addrPriority sa
 

hbs2-core/lib/HBS2/OrDie.hs

@@ -74,4 +74,9 @@ orThrowUser :: (OrThrow a1, MonadIO m)
 
 orThrowUser p = orThrow (userError (show p))
 
+orThrowPassIO :: (MonadIO m, Exception e) => Either e a -> m a
+orThrowPassIO = \case
+  Left e -> throwIO e
+  Right x -> pure x
+
 

hbs2-core/lib/HBS2/Prelude.hs

@@ -24,6 +24,7 @@ module HBS2.Prelude
   , (&), (<&>), for_, for
   , HasErrorStatus(..), ErrorStatus(..), SomeError(..), WithSomeError(..), mayE, someE
   , ByFirst(..)
+  , whenTrue, whenFalse
   ) where
 
 import HBS2.Clock
@@ -95,6 +96,11 @@ instance Monad m => ToMPlus (MaybeT m) (Either x a) where
   toMPlus (Left{}) = mzero
   toMPlus (Right x) = MaybeT $ pure (Just x)
 
+whenTrue :: forall m b a . (Monad m) => b -> Bool -> m a -> (b -> m a) -> m a
+whenTrue b f fallback continue = if f then continue b else fallback
+
+whenFalse :: forall m b a . (Monad m) => b -> Bool -> m a -> (b -> m a) -> m a
+whenFalse b f fallback continue = if not f then continue b else fallback
 
 data ErrorStatus = Complete
                  | HasIssuesButOkay

hbs2-core/lib/HBS2/Storage/Operations/Class.hs

@@ -11,6 +11,7 @@ import Data.Kind
 data OperationError =
     StorageError
   | CryptoError
+  | SignCheckError
   | DecryptError
   | DecryptionError
   | MissedBlockError

hbs2-core/lib/HBS2/System/Dir.hs

@@ -47,9 +47,7 @@ touch what = do
 
   when (not here || hard) do
     mkdir (takeDirectory fn)
-    liftIO $ print (takeDirectory fn)
     unless dir do
-      liftIO $ print fn
       liftIO $ LBS.appendFile fn mempty
 
   where
@@ -71,4 +69,16 @@ expandPath = liftIO . D.canonicalizePath
 doesDirectoryExist :: MonadIO m => FilePath -> m Bool
 doesDirectoryExist = liftIO . D.doesDirectoryExist
 
+fileSize :: MonadIO m => FilePath -> m Integer
+fileSize = liftIO . D.getFileSize
+
+mv :: MonadIO m => FilePath -> FilePath -> m ()
+mv a b = liftIO $ D.renamePath a b
+
+rm :: MonadIO m => FilePath -> m ()
+rm fn = liftIO $ D.removePathForcibly fn
+
+home :: MonadIO m => m FilePath
+home = liftIO D.getHomeDirectory
+
 

hbs2-core/test/DialogSpec.hs

@@ -1,63 +0,0 @@
-module DialogSpec where
-
-import Test.QuickCheck
-import Test.Tasty
-import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck as TastyQ
-
-import Control.Concurrent.Async
-import Control.Monad
-import Control.Monad
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import GHC.Generics (Generic)
-import Lens.Micro.Platform
-import System.IO
-
-import HBS2.Net.Dialog.Core
-import HBS2.Net.Dialog.Helpers.List
-
-newtype BSA = BSA { unBSA :: ByteString }
-  deriving (Generic, Show)
-
-instance Arbitrary BSA where
-  arbitrary = BSA <$> randomSizedByteString
-
-  -- shrink = \case
-  --     BSA bs | BS.length bs > 1 ->
-  --                 let (bs1, bs2) = BS.splitAt (BS.length bs `div` 2) bs
-  --                  in [BSA bs1, BSA bs2]
-  --     _ -> []
-
-  shrink = \case
-      BSA (BS.uncons -> Just (x, xs)) -> [BSA xs]
-      _ -> []
-
-deriving via [BSA] instance Arbitrary Frames
-
-randomByteString :: Int -> Gen ByteString
-randomByteString n =
-    vectorOf n arbitrary <&> BS.pack
-{-# NOINLINE randomByteString #-}
-
-randomSizedByteString :: Gen ByteString
-randomSizedByteString =  do
-    let low = 0
-    let high = 2^13
-    size <- choose (low, high)
-    randomByteString size
-{-# NOINLINE randomSizedByteString #-}
-
-property' name = li . (name, ) . property
-
-testDialog :: TestTree
-testDialog = testGroup "dialog" $ buildList do
-    li . TastyQ.testProperties "props" $ buildList do
-
-        property' "roundtrip encode Frames" \ xs ->
-            (decodeFrames . encodeFrames) xs == Right xs
-
-        property' "encodeFrames is quasidistributive over mappend" \ (xs, ys) ->
-            BS.drop (BS.length (encodeFrames xs)) (encodeFrames (xs <> ys))
-                == encodeFrames ys
-

hbs2-core/test/Main.hs

@@ -2,7 +2,6 @@ module Main where
 
 import TestFakeMessaging
 import TestActors
-import DialogSpec
 import TestFileLogger
 import TestScheduled
 import TestDerivedKey
@@ -20,9 +19,6 @@ main =
       , testCase "testFileLogger" testFileLogger
       , testCase "testScheduledActions" testScheduled
       , testCase "testDerivedKeys1" testDerivedKeys1
-
-      -- FIXME does-not-finish
-      -- , testDialog
       ]
 
 

hbs2-core/test/TestDerivedKey.hs

@@ -15,15 +15,15 @@ import Data.Word
 testDerivedKeys1 :: IO ()
 testDerivedKeys1 = do
 
-  cred <- newCredentials @HBS2Basic
+  cred <- newCredentials @'HBS2Basic
 
   let _ = view peerSignPk cred
   let sk = view peerSignSk cred
 
   let nonce = 0x123456780928934 :: Word64
-  (pk1,sk1) <- derivedKey @HBS2Basic @'Sign nonce sk
+  (pk1,sk1) <- derivedKey @'HBS2Basic @'Sign nonce sk
 
-  let box = makeSignedBox @L4Proto pk1 sk1 (42 :: Word32)
+  let box = makeSignedBox @'HBS2Basic pk1 sk1 (42 :: Word32)
 
   (pk, n) <- pure (unboxSignedBox0 box)
               `orDie` "can not unbox"

hbs2-fixer/app/Main.hs

@@ -56,14 +56,16 @@ import System.Exit qualified as Exit
 import Data.Cache qualified as Cache
 import Data.Cache (Cache)
 
+import System.Exit
+
 {- HLINT ignore "Functor law" -}
 
 
 type Config = [Syntax C]
 
 
-type RLWW = LWWRefKey HBS2Basic
+type RLWW = LWWRefKey 'HBS2Basic
-type RRefLog = RefLogKey HBS2Basic
+type RRefLog = RefLogKey 'HBS2Basic
 
 newtype Watcher =
   Watcher [Syntax C]
@@ -79,7 +81,7 @@ instance Pretty Ref where
   pretty (RefLWW r)    = parens $ "lwwref" <+> dquotes (pretty r)
 
 newtype AnyPolledRef =
-  AnyPolledRef (PubKey 'Sign HBS2Basic)
+  AnyPolledRef (PubKey 'Sign 'HBS2Basic)
   deriving (Eq,Generic)
 
 instance Hashable AnyPolledRef
@@ -89,7 +91,7 @@ deriving newtype instance Hashable Id
 
 instance Pretty AnyPolledRef where
   pretty (AnyPolledRef r) = pretty (AsBase58 r)
--- deriving newtype instance Pretty (PubKey 'Sign HBS2Basic) => Pretty AnyPolledRef
+-- deriving newtype instance Pretty (PubKey 'Sign 'HBS2Basic) => Pretty AnyPolledRef
 
 instance FromStringMaybe AnyPolledRef where
   fromStringMay = fmap AnyPolledRef . fromStringMay
@@ -133,7 +135,7 @@ instance MonadIO m => HasConf (FixerM m) where
 
 debugPrefix  = toStdout . logPrefix "[debug] "
 
-readConf :: MonadIO m => FilePath -> m [Syntax MegaParsec]
+readConf :: MonadIO m => FilePath -> m [Syntax C]
 readConf  fn = liftIO (readFile fn) <&> parseTop <&> fromRight mempty
 
 withConfig :: MonadUnliftIO m => Maybe FilePath -> FixerM m () -> FixerM m ()
@@ -158,67 +160,80 @@ withApp cfgPath action = do
   setLogging @WARN  warnPrefix
   setLogging @NOTICE noticePrefix
 
-  soname <- detectRPC
+  fix \next -> do
-              `orDie` "can't detect RPC"
 
-  flip runContT pure do
+    flip runContT pure do
 
-    client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+      soname' <- lift detectRPC
-                >>= orThrowUser ("can't connect to" <+> pretty soname)
 
-    void $ ContT $ withAsync $ runMessagingUnix client
+      soname <- ContT $ maybe1 soname' (pure ())
 
-    peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+      client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
-    refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+                  >>= orThrowUser ("can't connect to" <+> pretty soname)
-    storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
-    lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
 
-    let endpoints = [ Endpoint @UNIX  peerAPI
+      mess <-  ContT $ withAsync $ runMessagingUnix client
-                    , Endpoint @UNIX  refLogAPI
-                    , Endpoint @UNIX  lwwAPI
-                    , Endpoint @UNIX  storageAPI
-                    ]
 
-    void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+      peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+      refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+      storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+      lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
 
-    let o = [MUWatchdog 20, MUDontRetry]
+      let endpoints = [ Endpoint @UNIX  peerAPI
-    clientN <- newMessagingUnixOpts o False 1.0 soname
+                      , Endpoint @UNIX  refLogAPI
+                      , Endpoint @UNIX  lwwAPI
+                      , Endpoint @UNIX  storageAPI
+                      ]
 
-    void $ ContT $ withAsync $ runMessagingUnix clientN
+      mn <- ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
 
-    sink <- newNotifySink
+      let o = [MUWatchdog 20,MUDontRetry]
+      clientN <- newMessagingUnixOpts o False 1.0 soname
 
-    void $ ContT $ withAsync $ flip runReaderT clientN $ do
+      notif <- ContT $ withAsync (runMessagingUnix clientN)
-              debug $ red "notify restarted!"
-              runNotifyWorkerClient sink
 
-    void  $ ContT $ withAsync $ flip runReaderT clientN $ do
-        runProto @UNIX
-          [ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink)
-          ]
 
-    env <- FixerEnv Nothing
+      sink <- newNotifySink
-                    lwwAPI
-                    refLogAPI
-                    sink
-                    peerAPI
-                    (AnyStorage (StorageClient storageAPI))
-             <$> newTVarIO mempty
-             <*> newTVarIO 30
-             <*> newTVarIO mempty
-             <*> newTVarIO mempty
-             <*> newTVarIO mempty
-             <*> newTVarIO 0
-             <*> newTVarIO mempty
-             <*> newTQueueIO
 
-    lift $ runReaderT (runFixerM $ withConfig cfgPath action) env
+      void $ ContT $ withAsync $ flip runReaderT clientN $ do
-      `finally` do
+                debug $ red "notify restarted!"
-         setLoggingOff @DEBUG
+                runNotifyWorkerClient sink
-         setLoggingOff @INFO
+
-         setLoggingOff @ERROR
+      p1 <- ContT $ withAsync $ flip runReaderT clientN $ do
-         setLoggingOff @WARN
+          runProto @UNIX
-         setLoggingOff @NOTICE
+            [ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink)
+            ]
+
+      env <- FixerEnv Nothing
+                      lwwAPI
+                      refLogAPI
+                      sink
+                      peerAPI
+                      (AnyStorage (StorageClient storageAPI))
+               <$> newTVarIO mempty
+               <*> newTVarIO 30
+               <*> newTVarIO mempty
+               <*> newTVarIO mempty
+               <*> newTVarIO mempty
+               <*> newTVarIO 0
+               <*> newTVarIO mempty
+               <*> newTQueueIO
+
+      void $ ContT $ bracket (pure ()) $ \_ -> do
+               readTVarIO (_listeners env) <&> HM.elems >>= mapM_ cancel
+
+      p3 <- ContT $ withAsync $ runReaderT (runFixerM $ withConfig cfgPath action) env
+
+      void $ waitAnyCatchCancel [mess,mn,notif,p1,p3]
+
+    debug $ red "respawning..."
+    pause @'Seconds 5
+    next
+
+  setLoggingOff @DEBUG
+  setLoggingOff @INFO
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
 
   where
     errorPrefix  = toStdout . logPrefix "[error] "
@@ -232,16 +247,18 @@ data ConfWatch =
   | ConfUpdate [Syntax C]
 
 mainLoop :: FixerM IO ()
-mainLoop = forever $ do
+mainLoop = do
   debug "hbs2-fixer. do stuff since 2024"
   conf <- getConf
   -- debug $ line <> vcat (fmap pretty conf)
 
   flip runContT pure do
 
+    debug $ red "Reloading..."
+
     lift $ updateFromConfig conf
 
-    void $ ContT $ withAsync $ do
+    p1 <- ContT $ withAsync $ do
             cfg <- asks _configFile `orDie` "config file not specified"
 
             flip fix ConfRead $ \next -> \case
@@ -271,7 +288,7 @@ mainLoop = forever $ do
                 next  ConfRead
 
     -- poll reflogs
-    void $ ContT $ withAsync do
+    p2 <- ContT $ withAsync do
 
       let w = asks _watchers
                >>= readTVarIO
@@ -292,15 +309,20 @@ mainLoop = forever $ do
 
       pure ()
 
-
     jobs <- asks _pipeline
-    void $ ContT $ withAsync $ forever do
+    p3 <-  ContT $ withAsync $ fix \next -> do
-      liftIO $ E.try @SomeException (join $ atomically $ readTQueue jobs)
+      r <- liftIO $ E.try @SomeException (join $ atomically $ readTQueue jobs)
-        >>= \case
+      case r of
-          Left e -> err (viaShow e)
+        Left e -> do
-          _ -> pure ()
+          err (viaShow e)
+          let ee = fromException @AsyncCancelled e
 
-    forever $ pause @'Seconds 60
+          unless (isJust ee) do
+            next
+
+        _ -> next
+
+    void $ waitAnyCatchCancel [p1,p2,p3]
 
 oneSec :: MonadUnliftIO m => m b -> m (Either () b)
 oneSec = race (pause @'Seconds 1)

hbs2-fixer/hbs2-fixer.cabal

@@ -68,7 +68,6 @@ common shared-properties
                , streaming
                , streaming-bytestring
                , streaming-commons
-               , streaming-utils
                , cryptonite
                , directory
                , exceptions

hbs2-git/git-hbs2-subscribe/Main.hs

@@ -28,7 +28,7 @@ main = do
 
 
   where
-    pLww :: ReadM (LWWRefKey HBS2Basic)
+    pLww :: ReadM (LWWRefKey 'HBS2Basic)
     pLww = maybeReader fromStringMay
 
 
@@ -66,7 +66,7 @@ instance Monad m => HasAPI LWWRefAPI UNIX (MyApp m) where
 instance Monad m => HasAPI RefLogAPI UNIX (MyApp m) where
   getAPI = asks _refLogAPI
 
-subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey HBS2Basic  -> m ()
+subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey 'HBS2Basic  -> m ()
 subscribe soname' ref = do
 
   soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc"

hbs2-git/git-hbs2/Main.hs

@@ -7,17 +7,32 @@ import HBS2.Git.Client.Export
 import HBS2.Git.Client.Import
 import HBS2.Git.Client.State
 
+import HBS2.Data.Types.SignedBox
+import HBS2.Git.Data.RepoHead
 import HBS2.Git.Data.RefLog
 import HBS2.Git.Local.CLI qualified as Git
-import HBS2.Git.Data.Tx qualified as TX
+import HBS2.Git.Data.Tx.Git qualified as TX
-import HBS2.Git.Data.Tx (RepoHead(..))
+import HBS2.Git.Data.Tx.Git (RepoHead(..))
+import HBS2.Git.Data.Tx.Index
 import HBS2.Git.Data.LWWBlock
+import HBS2.Peer.Proto.RefChan.Types
 import HBS2.Git.Data.GK
 
+import HBS2.KeyMan.Keys.Direct
 import HBS2.Storage.Operations.ByteString
 
+import Data.Text qualified as Text
+import Data.Text.IO qualified as Text
+import Data.HashSet qualified as HS
+import Data.Maybe
+import Data.Coerce
 import Options.Applicative as O
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString (ByteString)
+-- import Data.ByteString.Lazy (ByteString)
+import Text.InterpolatedString.Perl6 (qc)
+
+import Streaming.Prelude qualified as S
 
 import System.Exit
 
@@ -36,18 +51,22 @@ globalOptions = do
 
 commands :: GitPerks m => Parser (GitCLI m ())
 commands =
-  hsubparser (  command "export"  (info pExport  (progDesc "export repo to hbs2-git"))
+  hsubparser (  command "export"   (info pExport  (progDesc "export repo to hbs2-git"))
-             <> command "import" (info pImport  (progDesc "import repo from reflog"))
+             <> command "import"   (info pImport  (progDesc "import repo from reflog"))
-             <> command "key"    (info pKey     (progDesc "key management"))
+             <> command "key"      (info pKey     (progDesc "key management"))
-             <> command "tools"  (info pTools   (progDesc "misc tools"))
+             <> command "manifest" (info pManifest (progDesc "manifest commands"))
+             <> command "track"    (info pTrack   (progDesc "track tools"))
+             <> command "tools"    (info pTools   (progDesc "misc tools"))
              )
 
 
 pRefLogId :: ReadM RefLogId
 pRefLogId = maybeReader (fromStringMay @RefLogId)
 
+pRefChanId :: ReadM GitRefChanId
+pRefChanId = maybeReader (fromStringMay @GitRefChanId)
 
-pLwwKey :: ReadM (LWWRefKey HBS2Basic)
+pLwwKey :: ReadM (LWWRefKey 'HBS2Basic)
 pLwwKey = maybeReader fromStringMay
 
 pHashRef :: ReadM HashRef
@@ -150,9 +169,48 @@ pShowRef = do
       tx  <- withState do
                selectMaxAppliedTx >>= lift  . toMPlus <&> fst
 
-      rh <- TX.readRepoHeadFromTx sto tx >>= toMPlus
+      (_,rh) <- TX.readRepoHeadFromTx sto tx >>= toMPlus
 
-      liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh))
+      liftIO $ print $ vcat (fmap formatRef (view repoHeadRefs rh))
+
+
+pManifest :: GitPerks m => Parser (GitCLI m ())
+pManifest = hsubparser (   command "list" (info pManifestList (progDesc "list all manifest"))
+                        <> command "show" (info pManifestShow (progDesc "show manifest"))
+                       )
+
+pManifestList :: GitPerks m => Parser (GitCLI m ())
+pManifestList = do
+  what <- argument pLwwKey (metavar "LWWREF")
+  pure do
+    heads <- withState $ selectRepoHeadsFor ASC what
+    sto   <- getStorage
+    for_ heads $ \h -> runMaybeT do
+
+      rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce h)))
+                 >>= toMPlus
+                 <&> deserialiseOrFail @RepoHead
+                 >>= toMPlus
+
+      let mfsize = maybe 0 Text.length (_repoManifest rhead)
+      let mf = parens ( "manifest" <+> pretty mfsize)
+
+      liftIO $ print $ pretty (_repoHeadTime rhead)
+                         <+> pretty h
+                         <+> mf
+
+pManifestShow :: GitPerks m => Parser (GitCLI m ())
+pManifestShow = do
+  what <- argument pHashRef (metavar "HASH")
+  pure do
+
+      sto <- getStorage
+      rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce what)))
+                 >>= orThrowUser "repo head not found"
+                 <&> deserialiseOrFail @RepoHead
+                 >>= orThrowUser "repo head format not supported"
+
+      liftIO $ for_ (_repoManifest rhead) Text.putStrLn
 
 
 pKey :: GitPerks m => Parser (GitCLI m ())
@@ -171,8 +229,8 @@ pKeyShow = do
       tx  <- withState do
                selectMaxAppliedTx >>= lift  . toMPlus <&> fst
 
-      rh <- TX.readRepoHeadFromTx sto tx
+      (_,rh) <- TX.readRepoHeadFromTx sto tx
-               >>= toMPlus
+                  >>= toMPlus
 
       gkh <- toMPlus (_repoHeadGK0 rh)
 
@@ -205,6 +263,90 @@ pKeyUpdate = do
       Nothing -> liftIO $ putStrLn "not added" >> exitFailure
       Just x  -> liftIO $ print $ pretty x
 
+
+pTrack :: GitPerks m => Parser (GitCLI m ())
+pTrack = hsubparser (   command "send-repo-notify" (info pSendRepoNotify (progDesc "sends repository notification"))
+                     <> command "show-repo-notify" (info pShowRepoNotify (progDesc "shows repository notification"))
+                     <> command "gen-repo-index"   (info pGenRepoIndex (progDesc "generates repo index tx"))
+                    )
+
+pSendRepoNotify :: GitPerks m => Parser (GitCLI m ())
+pSendRepoNotify = do
+  dry <- flag False True (short 'n' <> long "dry" <> help "don't post anything")
+  notifyChan <- argument pRefChanId (metavar "CHANNEL-KEY")
+  pure do
+    notice $ "test send-repo-notify" <+> pretty (AsBase58 notifyChan)
+    -- откуда мы берём ссылку, которую постим? их много.
+
+    lwws <- withState selectAllLww
+
+    -- берём те, для которых у нас есть приватный ключ (наши)
+    creds <- catMaybes <$> runKeymanClient do
+                for lwws $ \(lwref,_,_) -> do
+                  loadCredentials (coerce @_ @(PubKey 'Sign 'HBS2Basic) lwref)
+
+    sto <- getStorage
+    rchanAPI <- asks _refChanAPI
+
+    hd <- getRefChanHead @L4Proto sto (RefChanHeadKey notifyChan)
+             `orDie` "refchan head not found"
+
+    let notifiers = view refChanHeadNotifiers hd & HS.toList
+
+    -- откуда мы берём ключ, которым подписываем?
+    -- ищем тоже в кеймане, берём тот, у которого выше weight
+    foundKey <- runKeymanClient (
+                  S.head_ do
+                     for notifiers $ \n -> do
+                      lift (loadCredentials n) >>= maybe none S.yield
+                      ) `orDie` "signing key not found"
+
+    for_ creds $ \c -> do
+      let lww = LWWRefKey @'HBS2Basic (view peerSignPk c)
+      let lwwSk = view peerSignSk c
+      let tx = makeNotificationTx @'HBS2Basic (NotifyCredentials foundKey) lww lwwSk Nothing
+
+      notice $ "about to publish lwwref index entry:"
+        <+> pretty (AsBase58 $ view peerSignPk c)
+
+      -- как мы постим ссылку
+      unless dry do
+        void $ callService @RpcRefChanNotify rchanAPI (notifyChan, tx)
+
+    -- кто парсит ссылку и помещает в рефчан
+
+
+pShowRepoNotify :: GitPerks m => Parser (GitCLI m ())
+pShowRepoNotify = do
+  href <- argument pHashRef (metavar "HASH")
+  pure do
+    sto <- asks _storage
+
+    box <- getBlock sto (coerce href)
+            `orDie` "tx not found"
+           <&> deserialiseOrFail @(RefChanNotify L4Proto)
+           >>= orThrowUser "malformed announce tx 1"
+           >>= \case
+                  Notify _ box -> pure box
+                  _            -> throwIO (userError "malformed announce tx 2")
+
+    ann <- runExceptT (unpackNotificationTx box)
+            >>= either (error . show) pure
+
+    liftIO $ print $ pretty ann
+
+
+pGenRepoIndex :: GitPerks m => Parser (GitCLI m ())
+pGenRepoIndex = do
+  what <- argument pLwwKey (metavar "LWWREF")
+  pure do
+    hd <- withState $ selectRepoIndexEntryFor what
+            >>= orThrowUser "no decent repo head data found"
+
+    seq <- getEpoch
+    let tx = GitIndexTx what seq (GitIndexRepoDefine hd)
+    liftIO $ LBS.putStr (serialise tx)
+
 main :: IO ()
 main = do
   (o, action) <- customExecParser (prefs showHelpOnError) $

hbs2-git/git-remote-hbs2/Main.hs

@@ -9,9 +9,10 @@ import HBS2.Git.Client.Export
 import HBS2.Git.Client.State
 import HBS2.Git.Client.Progress
 import HBS2.Git.Client.Config
+import HBS2.Git.Data.RepoHead
 import HBS2.Git.Data.RefLog
-import HBS2.Git.Data.Tx qualified as TX
+import HBS2.Git.Data.Tx.Git qualified as TX
-import HBS2.Git.Data.Tx (RepoHead(..))
+import HBS2.Git.Data.Tx.Git (RepoHead(..))
 import HBS2.Git.Data.LWWBlock
 
 import HBS2.System.Dir
@@ -48,7 +49,7 @@ sendLine = liftIO . IO.putStrLn
 die :: (MonadIO m, Pretty a) => a -> m b
 die s = liftIO $ Exit.die (show $ pretty s)
 
-parseURL :: String -> Maybe (LWWRefKey HBS2Basic)
+parseURL :: String -> Maybe (LWWRefKey 'HBS2Basic)
 parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
   where
     p = do
@@ -56,7 +57,7 @@ parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
 
       Atto.takeWhile1 (`elem` getAlphabet)
        <&> BS8.unpack
-       <&> fromStringMay @(LWWRefKey HBS2Basic)
+       <&> fromStringMay @(LWWRefKey 'HBS2Basic)
        >>= maybe (fail "invalid reflog key") pure
 
 parsePush :: String -> Maybe (Maybe GitRef, GitRef)
@@ -177,8 +178,8 @@ main = do
                     r'  <- runMaybeT $ withState do
                             tx <- selectMaxAppliedTx >>= lift  . toMPlus <&> fst
 
-                            rh <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
+                            (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
-                            pure (_repoHeadRefs rh)
+                            pure (view repoHeadRefs rh)
 
                     let r = fromMaybe mempty r'
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs

@@ -9,7 +9,7 @@ import HBS2.Git.Client.Config
 import HBS2.Git.Client.Progress
 import HBS2.Git.Client.State
 
-import HBS2.Git.Data.Tx
+import HBS2.Git.Data.Tx.Git
 
 import HBS2.Git.Local.CLI
 
@@ -136,11 +136,13 @@ runGitCLI o m = do
 
     peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
     refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+    refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
     storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
     lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
 
     let endpoints = [ Endpoint @UNIX  peerAPI
                     , Endpoint @UNIX  refLogAPI
+                    , Endpoint @UNIX  refChanAPI
                     , Endpoint @UNIX  lwwAPI
                     , Endpoint @UNIX  storageAPI
                     ]
@@ -160,7 +162,7 @@ runGitCLI o m = do
 
     progress <- ContT $ withAsync (drawProgress q)
 
-    env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI lwwAPI storageAPI
+    env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI refChanAPI lwwAPI storageAPI
     lift $ runReaderT setupLogging env
     lift $ withGitEnv env (evolveDB >> m)
       `finally` do

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs

@@ -13,7 +13,7 @@ import HBS2.Git.Client.Progress
 import HBS2.Git.Local
 import HBS2.Git.Client.App.Types.GitEnv
 
-import HBS2.Git.Data.Tx
+import HBS2.Git.Data.Tx.Git
 import HBS2.Git.Data.GK
 
 import HBS2.KeyMan.Keys.Direct
@@ -85,11 +85,12 @@ newGitEnv :: GitPerks m
           -> Config
           -> ServiceCaller PeerAPI UNIX
           -> ServiceCaller RefLogAPI UNIX
+          -> ServiceCaller RefChanAPI UNIX
           -> ServiceCaller LWWRefAPI UNIX
           -> ServiceCaller StorageAPI UNIX
           -> m GitEnv
 
-newGitEnv p opts path cpath conf peer reflog lww sto = do
+newGitEnv p opts path cpath conf peer reflog rchan lww sto = do
   let dbfile  = cpath </> "state.db"
   let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
   db <- newDBPipeEnv dOpt dbfile
@@ -105,6 +106,7 @@ newGitEnv p opts path cpath conf peer reflog lww sto = do
            conf
            peer
            reflog
+           rchan
            lww
            (AnyStorage (StorageClient sto))
            db

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs

@@ -42,11 +42,12 @@ data GitEnv =
   , _config          :: Config
   , _peerAPI         :: ServiceCaller PeerAPI UNIX
   , _refLogAPI       :: ServiceCaller RefLogAPI UNIX
+  , _refChanAPI      :: ServiceCaller RefChanAPI UNIX
   , _lwwRefAPI       :: ServiceCaller LWWRefAPI UNIX
   , _storage         :: AnyStorage -- ServiceCaller StorageAPI UNIX
   , _db              :: DBPipeEnv
   , _progress        :: AnyProgress
-  , _keyringCache    :: TVar (HashMap HashRef [KeyringEntry HBS2Basic])
+  , _keyringCache    :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic])
   }
 
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs

@@ -9,7 +9,7 @@ import HBS2.Git.Client.State
 import HBS2.Git.Client.Progress
 
 import HBS2.Git.Data.RefLog
-import HBS2.Git.Data.Tx
+import HBS2.Git.Data.Tx.Git
 import HBS2.Git.Data.LWWBlock
 import HBS2.Git.Data.GK
 
@@ -109,9 +109,8 @@ refsForExport forPushL = do
     <&> mapMaybe \case
          [val,name] -> (GitRef (LBS8.toStrict name),) <$> fromStringMay @GitHash (LBS8.unpack val)
          _          -> Nothing
-    <&> filterPat incl excl
     <&> HashMap.fromList
-    <&> HashMap.filterWithKey (\k _ -> not (HashSet.member k deleted))
+    <&> HashMap.mapWithKey (\k v -> if k `HashSet.member` deleted then gitHashTomb else v)
     <&> mappend forPush
     <&> mappend (HashMap.singleton currentBranch currentVal)
     <&> HashMap.toList
@@ -153,7 +152,7 @@ export :: ( GitPerks m
           , GroupKeyOperations m
           , HasAPI PeerAPI UNIX m
           )
-       => LWWRefKey HBS2Basic
+       => LWWRefKey 'HBS2Basic
        -> [(GitRef,Maybe GitHash)]
        -> m ()
 export key refs  = do
@@ -177,7 +176,7 @@ export key refs  = do
                              >>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0))
                 pure ( view peerSignSk  creds, view peerSignPk creds )
 
-  (puk,sk) <- derivedKey @HBS2Basic @'Sign lwwRefSeed sk0
+  (puk,sk) <- derivedKey @'HBS2Basic @'Sign lwwRefSeed sk0
 
   subscribeRefLog puk
 
@@ -191,7 +190,9 @@ export key refs  = do
 
       tx0 <- getLastAppliedTx
 
-      rh0 <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus )
+      rh <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus )
+
+      let rh0 = snd <$> rh
 
       (name,brief,mf) <- lift getManifest
 
@@ -216,7 +217,7 @@ export key refs  = do
 
       repohead <- makeRepoHeadSimple name brief mf gk0 myrefs
 
-      let oldRefs = maybe mempty _repoHeadRefs rh0
+      let oldRefs = maybe mempty repoHeadRefs' rh0
 
       trace $ "TX0" <+> pretty  tx0
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs

@@ -7,8 +7,9 @@ import HBS2.Git.Client.RefLog
 import HBS2.Git.Client.Progress
 
 import HBS2.Git.Data.RefLog
-import HBS2.Git.Data.Tx
+import HBS2.Git.Data.Tx.Git
 import HBS2.Git.Data.LWWBlock
+import HBS2.Git.Data.RepoHead
 
 import Data.ByteString.Lazy qualified as LBS
 
@@ -66,7 +67,7 @@ merelySubscribeRepo :: forall e s m . ( GitPerks m
                                       , e ~ L4Proto
                                       , s ~ Encryption e
                                       )
-                    => LWWRefKey HBS2Basic
+                    => LWWRefKey 'HBS2Basic
                     -> m (Maybe (PubKey 'Sign s))
 merelySubscribeRepo lwwKey = do
 
@@ -108,7 +109,7 @@ importRepoWait :: ( GitPerks m
                   , HasAPI LWWRefAPI UNIX m
                   , HasAPI RefLogAPI UNIX m
                   )
-               => LWWRefKey HBS2Basic
+               => LWWRefKey 'HBS2Basic
                -> m ()
 
 importRepoWait lwwKey = do
@@ -291,7 +292,7 @@ applyTx h = do
 
     applyHeads rh = do
 
-      let refs = _repoHeadRefs rh
+      let refs = view repoHeadRefs rh
 
       withGitFastImport $ \ps -> do
         let psin = getStdin ps

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs

@@ -17,6 +17,7 @@ module HBS2.Git.Client.Prelude
   , module HBS2.Peer.Proto.LWWRef
   , module HBS2.Peer.RPC.API.Peer
   , module HBS2.Peer.RPC.API.RefLog
+  , module HBS2.Peer.RPC.API.RefChan
   , module HBS2.Peer.RPC.API.LWWRef
   , module HBS2.Peer.RPC.API.Storage
   , module HBS2.Peer.RPC.Client.StorageClient
@@ -33,6 +34,7 @@ module HBS2.Git.Client.Prelude
   , getSocketName
   , formatRef
   , deserialiseOrFail
+  , GitRefChanId
   ) where
 
 import HBS2.Prelude.Plated hiding (at)
@@ -56,6 +58,7 @@ import HBS2.Net.Proto.Service
 import HBS2.Peer.Proto.LWWRef
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.RefChan
 import HBS2.Peer.RPC.API.LWWRef
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.StorageClient
@@ -73,6 +76,9 @@ import System.Process.Typed
 import Lens.Micro.Platform
 import Codec.Serialise
 
+-- FIXME: subject-to-change-signature
+type GitRefChanId = RefChanId L4Proto
+
 data RPCNotFoundError = RPCNotFoundError
                         deriving stock (Show,Typeable)
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs

@@ -6,7 +6,7 @@ import HBS2.Git.Client.Prelude
 import HBS2.Git.Data.RefLog
 import HBS2.Git.Data.LWWBlock
 
-import HBS2.Git.Data.Tx
+import HBS2.Git.Data.Tx.Git
 
 data Progress a =
   Progress
@@ -22,7 +22,7 @@ class HasProgress a where
 
 data ProgressEvent =
     ImportIdle
-  | ImportWaitLWW Int (LWWRefKey HBS2Basic)
+  | ImportWaitLWW Int (LWWRefKey 'HBS2Basic)
   | ImportRefLogStart RefLogId
   | ImportRefLogDone  RefLogId (Maybe HashRef)
   | ImportWaitTx HashRef

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs

@@ -27,12 +27,12 @@ subscribeRefLog puk = do
   api <- getAPI @PeerAPI @UNIX
   void $ callService @RpcPollAdd api (puk, "reflog", 13)
 
-subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
+subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey 'HBS2Basic -> m ()
 subscribeLWWRef puk = do
   api <- getAPI @PeerAPI @UNIX
   void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17)
 
-fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
+fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey 'HBS2Basic -> m ()
 fetchLWWRef key = do
   api <- getAPI @LWWRefAPI @UNIX
   void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)

hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs

@@ -11,15 +11,32 @@ import HBS2.Git.Client.App.Types
 import HBS2.Git.Client.Config
 
 import HBS2.Peer.Proto.RefLog
+import HBS2.Storage.Operations.ByteString
 
+import HBS2.Git.Data.RepoHead
 import HBS2.Git.Data.RefLog
 import HBS2.Git.Data.LWWBlock
+import HBS2.Git.Data.Tx.Index
 
 import DBPipe.SQLite
 import Data.Maybe
 import Data.List qualified as List
 import Text.InterpolatedString.Perl6 (qc)
+import Data.Text qualified as Text
 import Data.Word
+import Data.Coerce
+
+import Streaming.Prelude qualified as S
+
+data Limit = Limit Integer
+
+data SortOrder = ASC | DESC
+
+newtype SQL a = SQL a
+
+instance Pretty (SQL SortOrder) where
+  pretty (SQL ASC) = "ASC"
+  pretty (SQL DESC) = "DESC"
 
 newtype Base58Field a = Base58Field { fromBase58Field :: a }
                         deriving stock (Eq,Ord,Generic)
@@ -30,7 +47,7 @@ instance Pretty (AsBase58 a) => ToField (Base58Field a) where
 instance IsString a => FromField (Base58Field a) where
   fromField = fmap (Base58Field . fromString) . fromField @String
 
-instance FromField (RefLogKey HBS2Basic) where
+instance FromField (RefLogKey 'HBS2Basic) where
   fromField = fmap fromString . fromField @String
 
 instance ToField HashRef where
@@ -39,6 +56,8 @@ instance ToField HashRef where
 instance FromField HashRef where
   fromField = fmap fromString . fromField @String
 
+deriving newtype instance FromField (TaggedHashRef t)
+
 instance ToField GitHash where
   toField h = toField (show $ pretty h)
 
@@ -51,7 +70,7 @@ instance FromField GitRef where
 instance FromField GitHash where
   fromField = fmap fromString . fromField @String
 
-instance FromField (LWWRefKey HBS2Basic) where
+instance FromField (LWWRefKey 'HBS2Basic) where
   fromField = fmap fromString . fromField @String
 
 createStateDir :: (GitPerks m, MonadReader GitEnv m)  => m ()
@@ -367,16 +386,73 @@ limit 1
   |] (Only (Base58Field reflog)) <&> listToMaybe
 
 
-insertLww :: MonadIO m => LWWRefKey HBS2Basic -> Word64 -> RefLogId -> DBPipeM m ()
+insertLww :: MonadIO m => LWWRefKey 'HBS2Basic -> Word64 -> RefLogId -> DBPipeM m ()
 insertLww lww snum reflog = do
   insert [qc|
 INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?)
 ON CONFLICT (hash,seq,reflog) DO NOTHING
   |] (Base58Field lww, snum, Base58Field reflog)
 
-selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey HBS2Basic, Word64, RefLogId)]
+selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey 'HBS2Basic, Word64, RefLogId)]
 selectAllLww = do
   select_  [qc|
 SELECT hash, seq, reflog FROM lww
-  |] <&> fmap (over _3 (fromRefLogKey @HBS2Basic))
+  |] <&> fmap (over _3 (fromRefLogKey @'HBS2Basic))
+
+
+
+selectRepoHeadsFor :: (MonadIO m, HasStorage m)
+                    => SortOrder
+                    -> LWWRefKey 'HBS2Basic
+                    -> DBPipeM m [TaggedHashRef RepoHead]
+
+selectRepoHeadsFor order what = do
+  let q = [qc|
+SELECT t.head
+FROM lww l join tx t on l.reflog = t.reflog
+WHERE l.hash = ?
+ORDER BY t.seq {pretty (SQL order)}
+|]
+
+  select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what)
+   <&> fmap fromOnly
+
+
+instance (Monad m, HasStorage m) => HasStorage (DBPipeM m) where
+  getStorage = lift getStorage
+
+selectRepoIndexEntryFor :: (MonadIO m, HasStorage m)
+                        => LWWRefKey 'HBS2Basic
+                        -> DBPipeM m (Maybe GitIndexRepoDefineData)
+
+selectRepoIndexEntryFor what = runMaybeT do
+
+  headz <- lift $ selectRepoHeadsFor DESC what
+
+  rhh <- S.head_ do
+            for_ headz $ \ha -> do
+              rh' <- lift $ loadRepoHead ha
+              for_ rh' $ \rh -> do
+                when (notEmpty $ _repoManifest  rh) do
+                  S.yield rh
+
+
+  repohead <- toMPlus rhh
+
+  pure $ GitIndexRepoDefineData (GitIndexRepoName $ _repoHeadName repohead)
+                                (GitIndexRepoBrief $ _repoHeadBrief repohead)
+
+
+  where
+    notEmpty s = maybe 0 Text.length s > 0
+
+loadRepoHead :: (HasStorage m, MonadIO m) => TaggedHashRef RepoHead -> m (Maybe RepoHead)
+loadRepoHead rh = do
+  sto <- getStorage
+  runMaybeT do
+    runExceptT (readFromMerkle sto (SimpleKey (coerce rh)))
+       >>= toMPlus
+       <&> deserialiseOrFail @RepoHead
+       >>= toMPlus
+
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs

@@ -7,7 +7,7 @@ import HBS2.Storage.Operations.ByteString
 
 import Data.ByteString.Lazy qualified as LBS
 
-type GK0 = GroupKey 'Symm HBS2Basic
+type GK0 = GroupKey 'Symm 'HBS2Basic
 
 readGK0 :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m GK0
 readGK0 sto h = do
@@ -22,5 +22,5 @@ loadGK0FromFile fp = runMaybeT do
   content <- liftIO (try @_ @IOError (LBS.readFile fp))
                >>= toMPlus
 
-  toMPlus $ parseGroupKey @HBS2Basic (AsGroupKeyFile  content)
+  toMPlus $ parseGroupKey @'HBS2Basic (AsGroupKeyFile  content)
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs

@@ -3,7 +3,6 @@
 module HBS2.Git.Data.LWWBlock
   ( module HBS2.Git.Data.LWWBlock
   , module HBS2.Peer.Proto.LWWRef
-  , HBS2Basic
   ) where
 
 import HBS2.Prelude.Plated
@@ -42,19 +41,19 @@ import Control.Monad.Trans.Maybe
 --   (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX])
 --
 
-data LWWBlockData e =
+data LWWBlockData s =
   LWWBlockData
   { lwwRefSeed       :: Word64
-  , lwwRefLogPubKey  :: PubKey 'Sign (Encryption e)
+  , lwwRefLogPubKey  :: PubKey 'Sign s
   }
   deriving stock Generic
 
-data LWWBlock e =
+data LWWBlock s =
-  LWWBlock1 { lwwBlockData :: LWWBlockData e }
+  LWWBlock1 { lwwBlockData :: LWWBlockData s }
   deriving stock Generic
 
-instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e)
+instance Serialise (PubKey 'Sign s) => Serialise (LWWBlockData s)
-instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e)
+instance Serialise (PubKey 'Sign s) => Serialise (LWWBlock s)
 
 
 data LWWBlockOpError =
@@ -67,38 +66,34 @@ instance Exception LWWBlockOpError
 
 {- HLINT ignore "Functor law" -}
 
-readLWWBlock :: forall e s m . ( MonadIO m
+readLWWBlock :: forall  s m . ( MonadIO m
-                               , Signatures s
+                              , Signatures s
-                               , s ~ Encryption e
+                              , ForLWWRefProto s
-                               , ForLWWRefProto e
+                              , IsRefPubKey s
-                               , IsRefPubKey s
+                              )
-                               , e ~ L4Proto
-                               )
              => AnyStorage
              -> LWWRefKey s
-             -> m (Maybe (LWWRef e, LWWBlockData e))
+             -> m (Maybe (LWWRef s, LWWBlockData s))
 
 readLWWBlock sto k = runMaybeT do
 
-  w@LWWRef{..} <- runExceptT (readLWWRef @e sto k)
+  w@LWWRef{..} <- runExceptT (readLWWRef @s sto k)
                   >>= toMPlus
                   >>= toMPlus
 
   getBlock sto (fromHashRef lwwValue)
     >>= toMPlus
-    <&> deserialiseOrFail @(LWWBlock e)
+    <&> deserialiseOrFail @(LWWBlock s)
     >>= toMPlus
     <&> lwwBlockData
     <&> (w,)
 
-initLWWRef :: forall e s m . ( MonadIO m
+initLWWRef :: forall  s m . ( MonadIO m
                              , MonadError LWWBlockOpError m
                              , IsRefPubKey s
-                             , ForSignedBox e
+                             , ForSignedBox s
                              , HasDerivedKey s 'Sign Word64 m
-                             , s ~ Encryption e
                              , Signatures s
-                             , e ~ L4Proto
                              )
            => AnyStorage
            -> Maybe Word64
@@ -116,7 +111,7 @@ initLWWRef sto seed' findSk lwwKey  = do
   lww0 <- runMaybeT do
             getRef sto lwwKey >>= toMPlus
               >>= getBlock sto >>= toMPlus
-              <&> deserialiseOrFail @(SignedBox (LWWRef e) e)
+              <&> deserialiseOrFail @(SignedBox (LWWRef s) s)
               >>= toMPlus
               <&> unboxSignedBox0
               >>= toMPlus
@@ -124,7 +119,7 @@ initLWWRef sto seed' findSk lwwKey  = do
 
   (pk1, _) <- derivedKey @s @'Sign seed sk0
 
-  let newLwwData = LWWBlock1 (LWWBlockData @e seed pk1)
+  let newLwwData = LWWBlock1 @s (LWWBlockData seed pk1)
 
   hx <- putBlock sto (serialise newLwwData)
           >>= orThrowError LWWBlockOpStorageError

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs

@@ -2,6 +2,6 @@ module HBS2.Git.Data.RefLog where
 
 import HBS2.Git.Client.Prelude
 
-type RefLogId = PubKey 'Sign HBS2Basic
+type RefLogId = PubKey 'Sign 'HBS2Basic
 
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs

@@ -0,0 +1,68 @@
+{-# Language TemplateHaskell #-}
+module HBS2.Git.Data.RepoHead where
+
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs
+
+import HBS2.Git.Local
+
+import Data.Text qualified as Text
+import Data.ByteString.Char8 qualified as B8
+import Data.Word
+import Codec.Serialise
+import Lens.Micro.Platform
+import Data.Coerce
+import Safe
+import Data.Maybe
+import Data.Set qualified as Set
+
+data RepoHeadType = RepoHeadType1
+                    deriving stock (Enum,Generic)
+
+data RepoHeadExt = RepoHeadExt
+                   deriving stock Generic
+
+data RepoHead =
+  RepoHeadSimple
+  { _repoHeadType   :: RepoHeadType
+  , _repoHeadTime   :: Word64
+  , _repoHeadGK0    :: Maybe HashRef
+  , _repoHeadName   :: Text
+  , _repoHeadBrief  :: Text
+  , _repoManifest   :: Maybe Text
+  ,  repoHeadRefs'  :: [(GitRef, GitHash)]
+  , _repoHeadExt    :: [RepoHeadExt]
+  }
+  deriving stock (Generic)
+
+makeLenses ''RepoHead
+
+repoHeadTags :: SimpleGetter RepoHead [(GitRef,GitHash)]
+repoHeadTags =
+  to \h@RepoHeadSimple{} -> do
+    catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef)
+                      | (GitRef s, v)  <- view repoHeadRefs h, B8.isPrefixOf "refs/tags" s
+                      ] & Set.fromList & Set.toList
+
+
+repoHeadHeads :: SimpleGetter RepoHead [(GitRef,GitHash)]
+repoHeadHeads =
+  to \h@RepoHeadSimple{} -> do
+    catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef)
+              | (GitRef s, v)  <- view repoHeadRefs h, B8.isPrefixOf "refs/heads" s
+              ] & Set.fromList & Set.toList
+
+
+repoHeadRefs :: Lens RepoHead
+                     RepoHead
+                     [(GitRef, GitHash)]
+                     [(GitRef, GitHash)]
+
+repoHeadRefs = lens g s
+  where
+   s rh r = rh { repoHeadRefs' = r }
+   g rh = [ (r,v) | (r,v) <- repoHeadRefs' rh, v /= gitHashTomb ]
+
+instance Serialise RepoHeadType
+instance Serialise RepoHeadExt
+instance Serialise RepoHead

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs

@@ -1,6 +1,7 @@
-module HBS2.Git.Data.Tx
+module HBS2.Git.Data.Tx.Git
-  ( module HBS2.Git.Data.Tx
+  ( module HBS2.Git.Data.Tx.Git
   , OperationError(..)
+  , RepoHead(..)
   ) where
 
 import HBS2.Git.Client.Prelude
@@ -16,6 +17,7 @@ import HBS2.Storage.Operations.ByteString
 import HBS2.Storage.Operations.Missed
 
 import HBS2.Git.Data.GK
+import HBS2.Git.Data.RepoHead
 
 import HBS2.Git.Local
 
@@ -38,29 +40,6 @@ type LBS = LBS.ByteString
 
 type RepoTx = RefLogUpdate L4Proto
 
-data RepoHeadType = RepoHeadType1
-                    deriving stock (Enum,Generic)
-
-data RepoHeadExt = RepoHeadExt
-                   deriving stock Generic
-
-data RepoHead =
-  RepoHeadSimple
-  { _repoHeadType   :: RepoHeadType
-  , _repoHeadTime   :: Word64
-  , _repoHeadGK0    :: Maybe HashRef
-  , _repoHeadName   :: Text
-  , _repoHeadBrief  :: Text
-  , _repoManifest   :: Maybe Text
-  , _repoHeadRefs   :: [(GitRef, GitHash)]
-  , _repoHeadExt    :: [RepoHeadExt]
-  }
-  deriving stock (Generic)
-
-
-instance Serialise RepoHeadType
-instance Serialise RepoHeadExt
-instance Serialise RepoHead
 
 data TxKeyringNotFound = TxKeyringNotFound
                          deriving stock (Show, Typeable, Generic)
@@ -69,7 +48,7 @@ instance Exception TxKeyringNotFound
 
 class GroupKeyOperations m where
   openGroupKey :: GK0 -> m (Maybe GroupSecret)
-  loadKeyrings :: HashRef -> m [KeyringEntry HBS2Basic]
+  loadKeyrings :: HashRef -> m [KeyringEntry 'HBS2Basic]
 
 makeRepoHeadSimple :: MonadIO m
                    => Text
@@ -85,7 +64,7 @@ makeRepoHeadSimple name brief manifest gk refs = do
 writeRepoHead :: MonadUnliftIO  m => AnyStorage -> RepoHead -> m HashRef
 writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef
 
-makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic)
+makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ 'HBS2Basic)
        => AnyStorage
        -> Bool   -- ^ rewrite bundle merkle tree with new gk0
        -> Rank   -- ^ tx rank
@@ -98,7 +77,7 @@ makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic)
 
 makeTx sto rewrite r puk findSk rh prev lbss = do
 
-  let rfk = RefLogKey @HBS2Basic puk
+  let rfk = RefLogKey @'HBS2Basic puk
 
   privk <- findSk puk
              >>= orThrow TxKeyringNotFound
@@ -140,7 +119,7 @@ makeTx sto rewrite r puk findSk rh prev lbss = do
 
             debug $ "update GK0 for existed block" <+> pretty bh
             let rcpt = HM.keys (recipients (wbeGk0 writeEnv))
-            gk1 <- generateGroupKey @HBS2Basic (Just gks) rcpt
+            gk1 <- generateGroupKey @'HBS2Basic (Just gks) rcpt
 
             gk1h <- writeAsMerkle sto (serialise gk1)
 
@@ -161,12 +140,21 @@ makeTx sto rewrite r puk findSk rh prev lbss = do
 
   let meRef = HashRef me
 
+  -- FIXME: ASAP-race-condition-on-seq-ref
+  --   При разборе транзакции, если по какой-то причине
+  --   голова сразу не подъезжает, то не подъедет уже никогда,
+  --   и бранчи не приедут (Import).
+  --
+  --   Возможные решения: запатчить процедуру импорта (1)
+  --   Добавить ссылкун а RepoHead в блок, где приезжают
+  --   пулы
+
   -- TODO: post-real-rank-for-tx
   let tx = SequentialRef r (AnnotatedHashRef (Just headRef) meRef)
             & serialise
             & LBS.toStrict
 
-  makeRefLogUpdate @L4Proto @HBS2Basic puk privk tx
+  makeRefLogUpdate @L4Proto @'HBS2Basic puk privk tx
 
 
 unpackTx :: MonadIO m
@@ -209,10 +197,11 @@ readTx sto href = do
   pure (n, rhh, rh, blkh)
 
 
+
 readRepoHeadFromTx :: MonadIO m
        => AnyStorage
        -> HashRef
-       -> m (Maybe RepoHead)
+       -> m (Maybe (HashRef, RepoHead))
 
 readRepoHeadFromTx sto href = runMaybeT do
 
@@ -226,6 +215,7 @@ readRepoHeadFromTx sto href = runMaybeT do
     >>= toMPlus
     <&> deserialiseOrFail @RepoHead
     >>= toMPlus
+    <&> (rhh,)
 
 
 data BundleMeta =

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs

@@ -0,0 +1,128 @@
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Git.Data.Tx.Index where
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Data.RepoHead
+
+import HBS2.Data.Types.SignedBox
+import HBS2.Storage.Operations.Class
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+import Data.Coerce
+
+import Data.Word
+
+-- |
+-- Module      : HBS2.Git.Data.Tx.Index
+-- Description : hbs2-git index data structures
+--
+
+-- FIXME: fix-all-this-constraint-absurde
+type ForGitIndex s = ( ForSignedBox s
+                     , IsRefPubKey s
+                     )
+
+data RepoForkInfo e =
+  RepoForkInfoNone
+  deriving stock (Generic)
+
+data GitRepoAnnounce s =
+  GitRepoAnnounce
+  { repoLwwRef   :: LWWRefKey s
+  , repoForkInfo :: Maybe (RepoForkInfo s)
+  }
+  deriving stock (Generic)
+
+
+instance ForGitIndex s => Serialise (RepoForkInfo s)
+instance ForGitIndex s => Serialise (GitRepoAnnounce s)
+
+instance ForGitIndex s => Pretty (GitRepoAnnounce s) where
+  pretty GitRepoAnnounce{..} = parens $ "git-repo-announce" <+> pretty repoLwwRef
+
+newtype NotifyCredentials s = NotifyCredentials (PeerCredentials s)
+
+newtype GitIndexRepoName = GitIndexRepoName Text
+                           deriving stock (Data,Generic,Show)
+                           deriving newtype (Serialise)
+
+newtype GitIndexRepoBrief = GitIndexRepoBrief Text
+                            deriving stock (Data,Generic,Show)
+                            deriving newtype (Serialise)
+
+newtype GitIndexRepoManifest = GitIndexRepoManifest (Maybe Text)
+                               deriving stock (Generic,Show)
+                               deriving newtype (Serialise)
+
+data GitIndexRepoDefineData =
+  GitIndexRepoDefineData
+  { gitIndexRepoName     :: GitIndexRepoName
+  , gitIndexRepoBrief    :: GitIndexRepoBrief
+  }
+  deriving stock (Data,Generic,Show)
+
+data GitIndexEntry =
+    GitIndexRepoDefine GitIndexRepoDefineData
+  | GitIndexRepoTombEntry
+  | GitIndexRepoLikes Integer
+  deriving stock (Data,Generic)
+
+data GitIndexTx s =
+  GitIndexTx
+  { gitIndexTxRef      :: LWWRefKey s    -- ^ primary key
+  , gitIndexTxSeq      :: Word64         -- ^ sequence ( set tomb / bring from tomb )
+  , gitIndexTxPayload  :: GitIndexEntry  -- ^ statement
+  }
+  deriving stock (Generic)
+
+instance ForGitIndex s => Serialise (GitIndexTx s)
+instance Serialise GitIndexRepoDefineData
+instance Serialise GitIndexEntry
+
+instance ForGitIndex s => Pretty (GitIndexTx s) where
+  pretty GitIndexTx{..} = case gitIndexTxPayload of
+    GitIndexRepoDefine{}  -> "git-repo-define" <+> pretty gitIndexTxRef
+    GitIndexRepoTombEntry -> "git-repo-tomb"   <+> pretty gitIndexTxRef
+    GitIndexRepoLikes n   -> "git-repo-likes"  <+> pretty gitIndexTxRef <+> pretty n
+
+-- | makes notification tx
+-- | it is signed by lwwref private key in order to proove authorship
+-- | and signed with published notification private key in order
+-- | to publish tx via rpc
+makeNotificationTx :: forall  s . (ForGitIndex s)
+                   => NotifyCredentials s
+                   -> LWWRefKey s
+                   -> PrivKey 'Sign s
+                   -> Maybe (RepoForkInfo s)
+                   -> SignedBox ByteString s
+makeNotificationTx ncred lww lwsk forkInfo = do
+  let creds = coerce ncred :: PeerCredentials s
+  let annData = GitRepoAnnounce @s lww forkInfo
+  let lwpk = coerce lww :: PubKey 'Sign s
+  let repoAnn = makeSignedBox @s lwpk lwsk (LBS.toStrict $ serialise annData)
+  makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict $ serialise repoAnn)
+
+
+
+
+
+unpackNotificationTx :: forall s m . (ForGitIndex s, MonadError OperationError m)
+                     => SignedBox ByteString s
+                     -> m (GitRepoAnnounce s)
+unpackNotificationTx box = do
+  (_, bs1) <- unboxSignedBox0 @_ @s box
+                & orThrowError SignCheckError
+
+  bs2 <- deserialiseOrFail @(SignedBox ByteString s) (LBS.fromStrict bs1)
+            & orThrowError UnsupportedFormat
+
+  (_, bs3) <- unboxSignedBox0 bs2
+                & orThrowError SignCheckError
+
+  deserialiseOrFail @(GitRepoAnnounce s) (LBS.fromStrict bs3)
+    & orThrowError UnsupportedFormat
+
+
+

hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs

@@ -16,6 +16,9 @@ newtype GitHash = GitHash ByteString
                   deriving stock (Eq,Ord,Data,Generic,Show)
                   deriving newtype Hashable
 
+gitHashTomb :: GitHash
+gitHashTomb = fromString "0000000000000000000000000000000000"
+
 instance Serialise GitHash
 
 instance IsString GitHash where

hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs

@@ -0,0 +1,179 @@
+{-# Language TemplateHaskell #-}
+module HBS2.Git.Web.Assets where
+
+import Data.FileEmbed
+import Data.ByteString
+import Data.Text (Text)
+import Text.InterpolatedString.Perl6 (qc)
+import Lucid.Base
+
+version :: Int
+version = 3
+
+assetsDir :: [(FilePath, ByteString)]
+assetsDir = $(embedDir "hbs2-git-dashboard-assets/assets")
+
+data IconType
+  = IconCopy
+  | IconCopyDone
+  | IconLockClosed
+  | IconGitCommit
+  | IconGitFork
+  | IconGitBranch
+  | IconTag
+  | IconFolderFilled
+  | IconHaskell
+  | IconMarkdown
+  | IconNix
+  | IconBash
+  | IconPython
+  | IconJavaScript
+  | IconSql
+  | IconSettingsFilled
+  | IconFileFilled
+  | IconRefresh
+  | IconArrowUturnLeft
+  | IconLicense
+  | IconPinned
+
+svgIcon :: Monad m => IconType -> HtmlT m ()
+svgIcon = toHtmlRaw . svgIconText
+
+svgIconText :: IconType -> Text
+
+svgIconText IconCopy = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M7 7m0 2.667a2.667 2.667 0 0 1 2.667 -2.667h8.666a2.667 2.667 0 0 1 2.667 2.667v8.666a2.667 2.667 0 0 1 -2.667 2.667h-8.666a2.667 2.667 0 0 1 -2.667 -2.667z" />
+  <path d="M4.012 16.737a2.005 2.005 0 0 1 -1.012 -1.737v-10c0 -1.1 .9 -2 2 -2h10c.75 0 1.158 .385 1.5 1" />
+</svg>|]
+
+svgIconText IconCopyDone = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy-check" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M7 7m0 2.667a2.667 2.667 0 0 1 2.667 -2.667h8.666a2.667 2.667 0 0 1 2.667 2.667v8.666a2.667 2.667 0 0 1 -2.667 2.667h-8.666a2.667 2.667 0 0 1 -2.667 -2.667z" />
+  <path d="M4.012 16.737a2.005 2.005 0 0 1 -1.012 -1.737v-10c0 -1.1 .9 -2 2 -2h10c.75 0 1.158 .385 1.5 1" />
+  <path d="M11 14l2 2l4 -4" />
+</svg>|]
+
+svgIconText IconLockClosed = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-lock" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M5 13a2 2 0 0 1 2 -2h10a2 2 0 0 1 2 2v6a2 2 0 0 1 -2 2h-10a2 2 0 0 1 -2 -2v-6z" />
+  <path d="M11 16a1 1 0 1 0 2 0a1 1 0 0 0 -2 0" />
+  <path d="M8 11v-4a4 4 0 1 1 8 0v4" />
+</svg>|]
+
+svgIconText IconGitCommit = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-commit" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M12 12m-3 0a3 3 0 1 0 6 0a3 3 0 1 0 -6 0" />
+  <path d="M12 3l0 6" />
+  <path d="M12 15l0 6" />
+</svg>|]
+
+svgIconText IconGitFork = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-fork" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M12 18m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M7 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M17 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M7 8v2a2 2 0 0 0 2 2h6a2 2 0 0 0 2 -2v-2" />
+  <path d="M12 12l0 4" />
+</svg>|]
+
+svgIconText IconGitBranch = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-branch" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M7 18m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M7 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M17 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
+  <path d="M7 8l0 8" />
+  <path d="M9 18h6a2 2 0 0 0 2 -2v-5" />
+  <path d="M14 14l3 -3l3 3" />
+</svg>|]
+
+svgIconText IconTag = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-tag" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M7.5 7.5m-1 0a1 1 0 1 0 2 0a1 1 0 1 0 -2 0" />
+  <path d="M3 6v5.172a2 2 0 0 0 .586 1.414l7.71 7.71a2.41 2.41 0 0 0 3.408 0l5.592 -5.592a2.41 2.41 0 0 0 0 -3.408l-7.71 -7.71a2 2 0 0 0 -1.414 -.586h-5.172a3 3 0 0 0 -3 3z" />
+</svg>|]
+
+svgIconText IconFolderFilled = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-folder-filled" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="#currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M9 3a1 1 0 0 1 .608 .206l.1 .087l2.706 2.707h6.586a3 3 0 0 1 2.995 2.824l.005 .176v8a3 3 0 0 1 -2.824 2.995l-.176 .005h-14a3 3 0 0 1 -2.995 -2.824l-.005 -.176v-11a3 3 0 0 1 2.824 -2.995l.176 -.005h4z" stroke-width="0" fill="currentColor" />
+</svg>|]
+
+svgIconText IconHaskell = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
+  <title>Haskell</title>
+  <path d="M0 3.535L5.647 12 0 20.465h4.235L9.883 12 4.235 3.535zm5.647 0L11.294 12l-5.647 8.465h4.235l3.53-5.29 3.53 5.29h4.234L9.883 3.535zm8.941 4.938l1.883 2.822H24V8.473zm2.824 4.232l1.882 2.822H24v-2.822z"/>
+  </svg>|]
+
+svgIconText IconMarkdown = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
+  <title>Markdown</title>
+  <path d="M22.27 19.385H1.73A1.73 1.73 0 010 17.655V6.345a1.73 1.73 0 011.73-1.73h20.54A1.73 1.73 0 0124 6.345v11.308a1.73 1.73 0 01-1.73 1.731zM5.769 15.923v-4.5l2.308 2.885 2.307-2.885v4.5h2.308V8.078h-2.308l-2.307 2.885-2.308-2.885H3.46v7.847zM21.232 12h-2.309V8.077h-2.307V12h-2.308l3.461 4.039z"/>
+  </svg>|]
+
+svgIconText IconNix = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
+  <title>Nix</title>
+  <path d="M7.352 1.592l-1.364.002L5.32 2.75l1.557 2.713-3.137-.008-1.32 2.34H14.11l-1.353-2.332-3.192-.006-2.214-3.865zm6.175 0l-2.687.025 5.846 10.127 1.341-2.34-1.59-2.765 2.24-3.85-.683-1.182h-1.336l-1.57 2.705-1.56-2.72zm6.887 4.195l-5.846 10.125 2.696-.008 1.601-2.76 4.453.016.682-1.183-.666-1.157-3.13-.008L21.778 8.1l-1.365-2.313zM9.432 8.086l-2.696.008-1.601 2.76-4.453-.016L0 12.02l.666 1.157 3.13.008-1.575 2.71 1.365 2.315L9.432 8.086zM7.33 12.25l-.006.01-.002-.004-1.342 2.34 1.59 2.765-2.24 3.85.684 1.182H7.35l.004-.006h.001l1.567-2.698 1.558 2.72 2.688-.026-.004-.006h.01L7.33 12.25zm2.55 3.93l1.354 2.332 3.192.006 2.215 3.865 1.363-.002.668-1.156-1.557-2.713 3.137.008 1.32-2.34H9.881Z"/>
+  </svg>|]
+
+svgIconText IconBash = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-terminal-2" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M8 9l3 3l-3 3" />
+  <path d="M13 15l3 0" />
+  <path d="M3 4m0 2a2 2 0 0 1 2 -2h14a2 2 0 0 1 2 2v12a2 2 0 0 1 -2 2h-14a2 2 0 0 1 -2 -2z" />
+</svg>|]
+
+svgIconText IconPython = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
+  <title>Python</title>
+  <path d="M14.25.18l.9.2.73.26.59.3.45.32.34.34.25.34.16.33.1.3.04.26.02.2-.01.13V8.5l-.05.63-.13.55-.21.46-.26.38-.3.31-.33.25-.35.19-.35.14-.33.1-.3.07-.26.04-.21.02H8.77l-.69.05-.59.14-.5.22-.41.27-.33.32-.27.35-.2.36-.15.37-.1.35-.07.32-.04.27-.02.21v3.06H3.17l-.21-.03-.28-.07-.32-.12-.35-.18-.36-.26-.36-.36-.35-.46-.32-.59-.28-.73-.21-.88-.14-1.05-.05-1.23.06-1.22.16-1.04.24-.87.32-.71.36-.57.4-.44.42-.33.42-.24.4-.16.36-.1.32-.05.24-.01h.16l.06.01h8.16v-.83H6.18l-.01-2.75-.02-.37.05-.34.11-.31.17-.28.25-.26.31-.23.38-.2.44-.18.51-.15.58-.12.64-.1.71-.06.77-.04.84-.02 1.27.05zm-6.3 1.98l-.23.33-.08.41.08.41.23.34.33.22.41.09.41-.09.33-.22.23-.34.08-.41-.08-.41-.23-.33-.33-.22-.41-.09-.41.09zm13.09 3.95l.28.06.32.12.35.18.36.27.36.35.35.47.32.59.28.73.21.88.14 1.04.05 1.23-.06 1.23-.16 1.04-.24.86-.32.71-.36.57-.4.45-.42.33-.42.24-.4.16-.36.09-.32.05-.24.02-.16-.01h-8.22v.82h5.84l.01 2.76.02.36-.05.34-.11.31-.17.29-.25.25-.31.24-.38.2-.44.17-.51.15-.58.13-.64.09-.71.07-.77.04-.84.01-1.27-.04-1.07-.14-.9-.2-.73-.25-.59-.3-.45-.33-.34-.34-.25-.34-.16-.33-.1-.3-.04-.25-.02-.2.01-.13v-5.34l.05-.64.13-.54.21-.46.26-.38.3-.32.33-.24.35-.2.35-.14.33-.1.3-.06.26-.04.21-.02.13-.01h5.84l.69-.05.59-.14.5-.21.41-.28.33-.32.27-.35.2-.36.15-.36.1-.35.07-.32.04-.28.02-.21V6.07h2.09l.14.01zm-6.47 14.25l-.23.33-.08.41.08.41.23.33.33.23.41.08.41-.08.33-.23.23-.33.08-.41-.08-.41-.23-.33-.33-.23-.41-.08-.41.08z"/>
+</svg>|]
+
+svgIconText IconJavaScript = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
+  <title>JavaScript</title>
+  <path d="M0 0h24v24H0V0zm22.034 18.276c-.175-1.095-.888-2.015-3.003-2.873-.736-.345-1.554-.585-1.797-1.14-.091-.33-.105-.51-.046-.705.15-.646.915-.84 1.515-.66.39.12.75.42.976.9 1.034-.676 1.034-.676 1.755-1.125-.27-.42-.404-.601-.586-.78-.63-.705-1.469-1.065-2.834-1.034l-.705.089c-.676.165-1.32.525-1.71 1.005-1.14 1.291-.811 3.541.569 4.471 1.365 1.02 3.361 1.244 3.616 2.205.24 1.17-.87 1.545-1.966 1.41-.811-.18-1.26-.586-1.755-1.336l-1.83 1.051c.21.48.45.689.81 1.109 1.74 1.756 6.09 1.666 6.871-1.004.029-.09.24-.705.074-1.65l.046.067zm-8.983-7.245h-2.248c0 1.938-.009 3.864-.009 5.805 0 1.232.063 2.363-.138 2.711-.33.689-1.18.601-1.566.48-.396-.196-.597-.466-.83-.855-.063-.105-.11-.196-.127-.196l-1.825 1.125c.305.63.75 1.172 1.324 1.517.855.51 2.004.675 3.207.405.783-.226 1.458-.691 1.811-1.411.51-.93.402-2.07.397-3.346.012-2.054 0-4.109 0-6.179l.004-.056z"/>
+</svg>|]
+
+svgIconText IconSql = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-file-type-sql" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M14 3v4a1 1 0 0 0 1 1h4" />
+  <path d="M14 3v4a1 1 0 0 0 1 1h4" />
+  <path d="M5 20.25c0 .414 .336 .75 .75 .75h1.25a1 1 0 0 0 1 -1v-1a1 1 0 0 0 -1 -1h-1a1 1 0 0 1 -1 -1v-1a1 1 0 0 1 1 -1h1.25a.75 .75 0 0 1 .75 .75" />
+  <path d="M5 12v-7a2 2 0 0 1 2 -2h7l5 5v4" />
+  <path d="M18 15v6h2" />
+  <path d="M13 15a2 2 0 0 1 2 2v2a2 2 0 1 1 -4 0v-2a2 2 0 0 1 2 -2z" />
+  <path d="M14 20l1.5 1.5" />
+</svg>|]
+
+svgIconText IconSettingsFilled = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-settings-filled" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M14.647 4.081a.724 .724 0 0 0 1.08 .448c2.439 -1.485 5.23 1.305 3.745 3.744a.724 .724 0 0 0 .447 1.08c2.775 .673 2.775 4.62 0 5.294a.724 .724 0 0 0 -.448 1.08c1.485 2.439 -1.305 5.23 -3.744 3.745a.724 .724 0 0 0 -1.08 .447c-.673 2.775 -4.62 2.775 -5.294 0a.724 .724 0 0 0 -1.08 -.448c-2.439 1.485 -5.23 -1.305 -3.745 -3.744a.724 .724 0 0 0 -.447 -1.08c-2.775 -.673 -2.775 -4.62 0 -5.294a.724 .724 0 0 0 .448 -1.08c-1.485 -2.439 1.305 -5.23 3.744 -3.745a.722 .722 0 0 0 1.08 -.447c.673 -2.775 4.62 -2.775 5.294 0zm-2.647 4.919a3 3 0 1 0 0 6a3 3 0 0 0 0 -6z" stroke-width="0" fill="currentColor" />
+</svg>|]
+
+svgIconText IconFileFilled = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-file-filled" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M12 2l.117 .007a1 1 0 0 1 .876 .876l.007 .117v4l.005 .15a2 2 0 0 0 1.838 1.844l.157 .006h4l.117 .007a1 1 0 0 1 .876 .876l.007 .117v9a3 3 0 0 1 -2.824 2.995l-.176 .005h-10a3 3 0 0 1 -2.995 -2.824l-.005 -.176v-14a3 3 0 0 1 2.824 -2.995l.176 -.005h5z" stroke-width="0" fill="currentColor" />
+  <path d="M19 7h-4l-.001 -4.001z" stroke-width="0" fill="currentColor" />
+</svg>|]
+
+svgIconText IconRefresh = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-refresh" width="24" height="24" viewBox="0 0 24 24" stroke-width="2" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M20 11a8.1 8.1 0 0 0 -15.5 -2m-.5 -4v4h4" />
+  <path d="M4 13a8.1 8.1 0 0 0 15.5 2m.5 4v-4h-4" />
+</svg>|]
+
+svgIconText IconArrowUturnLeft = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-arrow-uturn-left" width="24" height="24" viewBox="0 0 24 24" stroke-width="2" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M9 14l-4 -4l4 -4" />
+  <path d="M5 10h11a4 4 0 1 1 0 8h-1" />
+</svg>|]
+
+svgIconText IconLicense = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-license" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M15 21h-9a3 3 0 0 1 -3 -3v-1h10v2a2 2 0 0 0 4 0v-14a2 2 0 1 1 2 2h-2m2 -4h-11a3 3 0 0 0 -3 3v11" />
+  <path d="M9 7l4 0" />
+  <path d="M9 11l4 0" />
+</svg>|]
+
+svgIconText IconPinned = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-pinned" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
+  <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+  <path d="M9 4v6l-2 4v2h10v-2l-2 -4v-6" />
+  <path d="M12 16l0 5" />
+  <path d="M8 4l8 0" />
+</svg>|]

hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css

@@ -0,0 +1,269 @@
+/* fastpok CSS start */
+
+:root {
+  --pico-form-element-spacing-vertical: .5rem;
+  --pico-form-element-spacing-horizontal: .625rem;
+}
+
+[type=search] {
+  --pico-border-radius: inherit;
+}
+
+[role=search] {
+  --pico-border-radius: inherit;
+}
+
+[role=search]>:first-child {
+  border-top-left-radius: var(--pico-border-radius);
+  border-bottom-left-radius: var(--pico-border-radius);
+}
+
+[role=search]>:last-child {
+  border-top-right-radius: var(--pico-border-radius);
+  border-bottom-right-radius: var(--pico-border-radius);
+}
+
+body>footer, body>header, body>main {
+  padding-block: 0;
+} 
+
+header>nav {
+  border-bottom: var(--pico-border-width) solid var(--pico-muted-border-color);
+} 
+
+.wrapper {
+  display: flex;
+}
+
+.sidebar {
+  width: 20rem;
+  flex-shrink: 0;
+  padding-top: var(--pico-block-spacing-vertical);
+  padding-right: var(--pico-block-spacing-horizontal);
+  padding-bottom: var(--pico-block-spacing-vertical);
+  border-right: var(--pico-border-width) solid var(--pico-muted-border-color);
+  display: flex;
+  flex-direction: column;
+}
+
+.content {
+  padding-top: var(--pico-block-spacing-vertical);
+  padding-bottom: var(--pico-block-spacing-vertical);
+  padding-left: var(--pico-block-spacing-horizontal);
+}
+
+article {
+  border: var(--pico-border-width) solid var(--pico-card-border-color);
+  box-shadow: none;
+}
+
+.repo-list-item {
+  display: flex;
+  justify-content: space-between;
+  gap: var(--pico-block-spacing-horizontal);
+}
+
+.repo-list-item-link-wrapper {
+  display: flex;
+  align-items: center;
+  margin-bottom: var(--pico-typography-spacing-vertical);
+}
+
+.copy-button {
+  margin-left: calc(var(--pico-spacing) * .5);
+  background-color: transparent;
+  border: none;
+  padding: 0;
+  border-radius: 0;
+  box-shadow: none;
+  color: var(--pico-secondary);
+  transition: color var(--pico-transition);
+}
+
+.copy-button:hover {
+  color: var(--pico-secondary-hover);
+}
+
+.copy-button .icon {
+  width: 1.125rem;
+  height: 1.125rem;
+}
+
+.inline-icon-wrapper {
+  display: inline-block;
+}
+
+.inline-icon-wrapper .icon {
+  margin-right: calc(var(--pico-spacing) * .25);
+  vertical-align: middle;
+}
+
+.info-block {
+  margin-bottom: var(--pico-block-spacing-vertical);
+}
+
+.mb-0 {
+  margin-bottom: 0;
+}
+
+.py-0 {
+  padding-top: 0;
+  padding-bottom: 0;
+}
+
+.text-nowrap {
+  text-wrap: nowrap;
+}
+
+.repo-menu {
+  --pico-nav-breadcrumb-divider: '|';
+}
+
+.repo-menu li.active {
+  color: var(--pico-primary);
+}
+
+aside li {
+  padding: 0;
+}
+
+aside ul {
+  padding: 0;
+}
+
+aside li :where(a,[role=link]):not(:hover) {
+  text-decoration: none;
+}
+
+.sidebar-title {
+  margin-bottom: calc(var(--pico-typography-spacing-vertical) * .25);
+}
+
+/* fastpok CSS end */
+
+
+ul.misc-menu  {
+  margin: 0 0 0 0;
+  padding: 0 0 0 0;
+}
+
+ul.misc-menu li {
+  padding: 0 0 0 0;
+  margin-right: 1em;
+  display: inline;
+}
+
+.mono {
+    font-family: 'Courier New', Courier, monospace;
+}
+
+.tree {
+  font-weight: 600;
+}
+
+td.tree-locator {
+  border-bottom: none;
+}
+
+td.tree-locator span {
+  margin-right: .5rem;
+}
+
+tr.commit-brief-title td,
+tr.commit-brief-title th {
+  border-bottom: none;
+  vertical-align: top;
+}
+
+tr.commit-brief-details td,
+tr.commit-brief-details th {
+  border-top: none;
+}
+
+td.commit-brief-title {
+  text-align: left;
+}
+
+tr.commit-brief-last  td {
+  border: none;
+}
+
+tr.commit-brief-last  th {
+  border: none;
+}
+
+td.commit-icon {
+  width: 4rem;
+  /* width: px; */
+}
+
+td.commit-hash {
+  width: 10rem;
+  text-align: left;
+}
+
+
+pre > code.sourceCode { white-space: pre; position: relative; }
+pre > code.sourceCode > span { line-height: 1.25; }
+pre > code.sourceCode > span:empty { height: 1.2em; }
+.sourceCode { overflow: auto; }
+code.sourceCode > span { color: inherit; text-decoration: inherit; overflow: auto; }
+div.sourceCode { margin: 1em 0; overflow: auto; }
+pre.sourceCode { margin: 0; }
+@media screen {
+div.sourceCode { overflow: auto; max-width: 120rem; }
+}
+@media print {
+pre > code.sourceCode { white-space: pre-wrap; }
+pre > code.sourceCode > span { display: inline-block; text-indent: -5em; padding-left: 5em; }
+}
+pre.numberSource code
+  { counter-reset: source-line 0; }
+pre.numberSource code > span
+  { position: relative; left: -4em; counter-increment: source-line; }
+pre.numberSource code > span > a:first-child::before
+  { content: counter(source-line);
+    position: relative; left: -1em; text-align: right; vertical-align: baseline;
+    border: none; display: inline-block;
+    -webkit-touch-callout: none; -webkit-user-select: none;
+    -khtml-user-select: none; -moz-user-select: none;
+    -ms-user-select: none; user-select: none;
+    padding: 0 4px; width: 4em;
+    color: #aaaaaa;
+  }
+pre.numberSource { margin-left: 3em; border-left: 1px solid #aaaaaa;  padding-left: 4px; }
+@media screen {
+pre > code.sourceCode > span > a:first-child::before { text-decoration: underline; }
+}
+code span.al { color: #ef2929; } /* Alert */
+code span.an { color: #8f5902; font-weight: bold; font-style: italic; } /* Annotation */
+code span.at { color: #204a87; } /* Attribute */
+code span.bn { color: #0000cf; } /* BaseN */
+code span.cf { color: #204a87; font-weight: bold; } /* ControlFlow */
+code span.ch { color: #4e9a06; } /* Char */
+code span.cn { color: #8f5902; } /* Constant */
+code span.co { color: #8f5902; font-style: italic; } /* Comment */
+code span.cv { color: #8f5902; font-weight: bold; font-style: italic; } /* CommentVar */
+code span.do { color: #8f5902; font-weight: bold; font-style: italic; } /* Documentation */
+code span.dt { color: #204a87; } /* DataType */
+code span.dv { color: #0000cf; } /* DecVal */
+code span.er { color: #a40000; font-weight: bold; } /* Error */
+code span.ex { } /* Extension */
+code span.fl { color: #0000cf; } /* Float */
+code span.fu { color: #204a87; font-weight: bold; } /* Function */
+code span.im { } /* Import */
+code span.in { color: #8f5902; font-weight: bold; font-style: italic; } /* Information */
+code span.kw { color: #204a87; font-weight: bold; } /* Keyword */
+code span.op { color: #ce5c00; font-weight: bold; } /* Operator */
+code span.ot { color: #8f5902; } /* Other */
+code span.pp { color: #8f5902; font-style: italic; } /* Preprocessor */
+code span.sc { color: #ce5c00; font-weight: bold; } /* SpecialChar */
+code span.ss { color: #4e9a06; } /* SpecialString */
+code span.st { color: #4e9a06; } /* String */
+code span.va { color: #000000; } /* Variable */
+code span.vs { color: #4e9a06; } /* VerbatimString */
+code span.wa { color: #8f5902; font-weight: bold; font-style: italic; } /* Warning */
+
+
+
+