diff --git a/.fixme-new/config b/.fixme-new/config index 36db9d12..22f25f9a 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -13,7 +13,7 @@ fixme-attribs assigned workflow :class fixme-attribs class -fixme-value-set workflow new backlog wip test fixed done +fixme-value-set :workflow :new :backlog :wip :test :fixed :done fixme-value-set class hardcode performance boilerplate @@ -67,4 +67,3 @@ fixme-comments ";" "--" ;; refchan settings source ./config.local - diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 80ecec30..31563fc4 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -196,10 +196,6 @@ runCLI = do runTop forms -notEmpty :: [a] -> Maybe [a] -notEmpty = \case - [] -> Nothing - x -> Just x runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m () runTop forms = do @@ -491,147 +487,8 @@ runTop forms = do ) $ args [] $ returns "string" "refchan-key" $ do - entry $ bindMatch "fixme:refchan:init" $ nil_ $ const $ do - - let rch0 = refChanHeadDefault @L4Proto - sto <- lift getStorage - peer <- lift $ getClientAPI @PeerAPI @UNIX - rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX - - dir <- localConfigDir - confFile <- localConfig - - -- conf <- liftIO (readFile confFile) - -- <&> parseTop - -- <&> either (error.show) (fmap (fixContext @_ @C)) - - -- let already = headMay [ x - -- | ListVal [StringLike "refchan", SignPubKeyLike x] <- conf - -- ] - - rchan <- lift $ asks fixmeEnvRefChan - >>= readTVarIO - - flip runContT pure $ callCC \done -> do - - when (isJust rchan) do - warn $ red "refchan is already set" <+> pretty (fmap AsBase58 rchan) - warn $ "done" <+> pretty (fmap AsBase58 rchan) - done () - - poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () - >>= orThrowUser "hbs2-peer not connected" - <&> parseTop - <&> fromRight mempty - - pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x - | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked - ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set" - - - notice $ green "default peer" <+> pretty (AsBase58 pkey) - - - signK' <- lift $ runKeymanClientRO $ listCredentials - <&> headMay - - signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman") - - notice $ green "default author" <+> pretty (AsBase58 signK) - - -- TODO: use-hbs2-git-api? - (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|]) - <&> over _2 ( (fromStringMay @HashRef) <=< (notEmpty . headDef "" . lines . LBS8.unpack) ) - <&> \x -> case view _1 x of - ExitFailure _ -> set _2 Nothing x - ExitSuccess -> x - - notice $ green "group key" <+> maybe "none" pretty gkh' - - readers <- fromMaybe mempty <$> runMaybeT do - gh <- toMPlus gkh' - gk <- loadGroupKeyMaybe @'HBS2Basic sto gh - >>= toMPlus - pure $ HM.keys (recipients gk) - - notice $ green "readers" <+> pretty (length readers) - - rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers - <&> fmap snd . headMay - - - let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers) - & set refChanHeadAuthors (HS.singleton signK) - & set refChanHeadPeers (HM.singleton pkey 1) - - - let unlucky = HM.null (view refChanHeadPeers rch1) - || HS.null (view refChanHeadAuthors rch1) - - - liftIO $ print $ pretty rch1 - - if unlucky then do - warn $ red $ "refchan definition is not complete;" <+> - "you may add missed keys, edit the" <+> - "defition and add if manually or repeat init attempt" - <> line - else do - notice "refchan definition seems okay, adding new refchan" - - refchan <- lift $ keymanNewCredentials (Just "refchan") 0 - - creds <- lift $ runKeymanClientRO $ loadCredentials refchan - >>= orThrowUser "can't load credentials" - - let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1 - - href <- writeAsMerkle sto (serialise box) - - callService @RpcPollAdd peer (refchan, "refchan", 17) - >>= orThrowUser "can't subscribe to refchan" - - callService @RpcRefChanHeadPost rchanApi (HashRef href) - >>= orThrowUser "can't post refchan head" - - - let nonce = take 6 $ show $ pretty (AsBase58 refchan) - let rchanFile = "refchan-" <> nonce <> ".local" - let rchanFilePath = dir rchanFile - - let note = ";; author and reader are inferred automatically" <> line - <> ";; from hbs2-keyman data" <> line - <> ";; edit them if needed" <> line - <> ";; reader is *your* reading public key." <> line - <> ";; author is *your* signing public key." <> line - - let refChanClause = mkList @C [ mkSym "refchan" - , mkSym (show $ pretty (AsBase58 refchan)) - ] - - let theirReaderKeyClause = maybe1 rk nil $ \(KeyringEntry pk _ _) -> do - mkList @C [ mkSym "reader", mkSym (show $ pretty (AsBase58 pk) ) ] - - let theirAuthorClause = mkList @C [ mkSym "author", mkSym (show $ pretty (AsBase58 signK) ) ] - - let content = (vcat $ [ pretty refChanClause ]) - <> line - <> line - <> note - <> line - <> vcat [ pretty theirReaderKeyClause - , pretty theirAuthorClause - ] - - liftIO do - writeFile rchanFilePath $ - show content - - appendFile confFile $ show $ pretty $ - mkList @C [ mkSym "source", mkSym ( "." rchanFile ) ] - - - notice $ green "refchan added" <+> pretty (AsBase58 refchan) + entry $ bindMatch "fixme:refchan:init" $ nil_ $ const $ lift do + fixmeRefChanInit entry $ bindMatch "set-template" $ nil_ \case [SymbolVal who, SymbolVal w] -> do diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index f459cde7..dfbcc327 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -15,6 +15,7 @@ import HBS2.Git.Local.CLI import HBS2.Polling import HBS2.OrDie import HBS2.Base58 +import HBS2.Net.Auth.GroupKeySymm import HBS2.Data.Types.SignedBox import HBS2.Peer.Proto.RefChan import HBS2.Peer.RPC.Client.RefChan @@ -23,7 +24,7 @@ import HBS2.System.Dir import HBS2.Net.Auth.Credentials import DBPipe.SQLite hiding (field) - +import HBS2.CLI.Run.KeyMan (keymanNewCredentials) import HBS2.KeyMan.Keys.Direct import Data.Config.Suckless.Script.File @@ -60,6 +61,11 @@ pattern IsSimpleTemplate xs <- ListVal (SymbolVal "simple" : xs) {- HLINT ignore "Functor law" -} +notEmpty :: [a] -> Maybe [a] +notEmpty = \case + [] -> Nothing + x -> Just x + defaultTemplate :: HashMap Id FixmeTemplate defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ] where @@ -72,6 +78,37 @@ defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ] |] +templateExample :: String +templateExample = [qc| + +; this is an optional template example +; for nicer fixme list +;(define-template short +; (quot +; (simple +; (trim 10 $fixme-key) " " +; +; (if (~ FIXME $fixme-tag) +; (then (fgd red (align 6 $fixme-tag)) ) +; (else (if (~ TODO $fixme-tag) +; (then (fgd green (align 6 $fixme-tag))) +; (else (align 6 $fixme-tag)) ) ) +; ) +; +; +; (align 10 ("[" $workflow "]")) " " +; (align 8 $class) " " +; (align 12 $assigned) " " +; (align 20 (trim 20 $committer-name)) " " +; (trim 50 ($fixme-title)) " " +; (nl)) +; ) +;) +; (set-template default short) + +|] + + init :: FixmePerks m => FixmeM m () init = do @@ -85,14 +122,62 @@ init = do let gitignore = lo ".gitignore" here <- doesPathExist gitignore + confPath <- localConfig + + unless here do + + liftIO $ appendFile confPath $ show $ vcat + [ mempty + , ";; this is a default fixme config" + , ";;" + , "fixme-prefix" <+> "FIXME:" + , "fixme-prefix" <+> "TODO:" + , "fixme-value-set" <+> hsep [":workflow", ":new",":wip",":backlog",":done"] + , "fixme-file-comments" <+> dquotes "*.scm" <+> dquotes ";" + , "fixme-comments" <+> dquotes ";" <+> dquotes "--" <+> dquotes "#" + , mempty + ] + + exts <- listBlobs Nothing + <&> fmap (takeExtension . fst) + <&> HS.toList . HS.fromList + + for_ exts $ \e -> do + unless (e `elem` [".gitignore",".local"] ) do + liftIO $ appendFile confPath $ + show $ ( "fixme-files" <+> dquotes ("**/*" <> pretty e) <> line ) + + liftIO $ appendFile confPath $ show $ vcat + [ "fixme-exclude" <+> dquotes "**/.**" + ] + + liftIO $ appendFile confPath $ show $ vcat + [ mempty + , pretty templateExample + , ";; uncomment to source any other local settings file" + , ";; source ./my.local" + , mempty + ] + unless here do liftIO $ writeFile gitignore $ show $ vcat [ pretty ("." localDBName) ] - notice $ yellow "run" <> line <> vcat [ - "git add" <+> pretty (lo0 ".gitignore") + notice $ green "default config created:" <+> ".fixme-new/config" <> line + <> "edit it for your project" <> line + <> "typically you need to add it to git" + <> line + <> "use (source ./some.local) form to add your personal settings" <> line + <> "which should not be shared amongst the whole project" <> line + <> "and add " <> yellow ".fixme-new/some.local" <+> "file to .gitignore" + <> line + + notice $ "run" <> line <> vcat [ + mempty + , "git add" <+> pretty (lo0 ".gitignore") , "git add" <+> pretty (lo0 "config") + , mempty ] @@ -312,7 +397,11 @@ cat_ hash = do let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String let start = fromMaybe 0 fixmeStart & fromIntegral & (\x -> x - before) & max 0 - let bbefore = if start > before then before + 1 else 1 + + debug $ red "start" <+> pretty start + debug $ red "before" <+> pretty before + + let bbefore = if start == 0 then before else before + 1 let origLen = maybe 0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1 let lno = max 1 $ origLen + after + before @@ -538,3 +627,139 @@ refchanImport = do insertScanned href for_ atx insertScanned + +fixmeRefChanInit :: FixmePerks m => FixmeM m () +fixmeRefChanInit = do + let rch0 = refChanHeadDefault @L4Proto + sto <- getStorage + peer <- getClientAPI @PeerAPI @UNIX + rchanApi <- getClientAPI @RefChanAPI @UNIX + + dir <- localConfigDir + confFile <- localConfig + + rchan <- asks fixmeEnvRefChan + >>= readTVarIO + + flip runContT pure $ callCC \done -> do + + when (isJust rchan) do + warn $ red "refchan is already set" <+> pretty (fmap AsBase58 rchan) + warn $ "done" <+> pretty (fmap AsBase58 rchan) + done () + + poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () + >>= orThrowUser "hbs2-peer not connected" + <&> parseTop + <&> fromRight mempty + + pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x + | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked + ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set" + + + notice $ green "default peer" <+> pretty (AsBase58 pkey) + + + signK' <- lift $ runKeymanClientRO $ listCredentials + <&> headMay + + signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman") + + notice $ green "default author" <+> pretty (AsBase58 signK) + + -- TODO: use-hbs2-git-api? + (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|]) + <&> over _2 ( (fromStringMay @HashRef) <=< (notEmpty . headDef "" . lines . LBS8.unpack) ) + <&> \x -> case view _1 x of + ExitFailure _ -> set _2 Nothing x + ExitSuccess -> x + + notice $ green "group key" <+> maybe "none" pretty gkh' + + readers <- fromMaybe mempty <$> runMaybeT do + gh <- toMPlus gkh' + gk <- loadGroupKeyMaybe @'HBS2Basic sto gh + >>= toMPlus + pure $ HM.keys (recipients gk) + + notice $ green "readers" <+> pretty (length readers) + + rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers + <&> fmap snd . headMay + + + let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers) + & set refChanHeadAuthors (HS.singleton signK) + & set refChanHeadPeers (HM.singleton pkey 1) + + + let unlucky = HM.null (view refChanHeadPeers rch1) + || HS.null (view refChanHeadAuthors rch1) + + + liftIO $ print $ pretty rch1 + + if unlucky then do + warn $ red $ "refchan definition is not complete;" <+> + "you may add missed keys, edit the" <+> + "defition and add if manually or repeat init attempt" + <> line + else do + notice "refchan definition seems okay, adding new refchan" + + refchan <- lift $ keymanNewCredentials (Just "refchan") 0 + + creds <- lift $ runKeymanClientRO $ loadCredentials refchan + >>= orThrowUser "can't load credentials" + + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1 + + href <- writeAsMerkle sto (serialise box) + + callService @RpcPollAdd peer (refchan, "refchan", 17) + >>= orThrowUser "can't subscribe to refchan" + + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" + + + let nonce = take 6 $ show $ pretty (AsBase58 refchan) + let rchanFile = "refchan-" <> nonce <> ".local" + let rchanFilePath = dir rchanFile + + let note = ";; author and reader are inferred automatically" <> line + <> ";; from hbs2-keyman data" <> line + <> ";; edit them if needed" <> line + <> ";; reader is *your* reading public key." <> line + <> ";; author is *your* signing public key." <> line + + let refChanClause = mkList @C [ mkSym "refchan" + , mkSym (show $ pretty (AsBase58 refchan)) + ] + + let theirReaderKeyClause = maybe1 rk nil $ \(KeyringEntry pk _ _) -> do + mkList @C [ mkSym "reader", mkSym (show $ pretty (AsBase58 pk) ) ] + + let theirAuthorClause = mkList @C [ mkSym "author", mkSym (show $ pretty (AsBase58 signK) ) ] + + let content = line + <> vcat [ pretty refChanClause ] + <> line + <> line + <> note + <> line + <> vcat [ pretty theirReaderKeyClause + , pretty theirAuthorClause + ] + + liftIO do + writeFile rchanFilePath $ + show content + + appendFile confFile $ show $ + line <> + pretty (mkList @C [ mkSym "source", mkSym ( "." rchanFile ) ]) + + notice $ green "refchan added" <+> pretty (AsBase58 refchan) + diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 5d2910d5..2741d462 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -365,3 +365,5 @@ startGitCatFile = do -- ssin <- getStdin config startProcess config + +