From ff9ef2ddec599c6c747413cca8b3ba8a4d4745a5 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 15 Sep 2024 10:20:14 +0300 Subject: [PATCH] merged refchan notifications and fixme-new (wip) --- .fixme-new/config | 109 +- docs/todo/hbs2-sync.txt | 37 + fixme-new/app/FixmeMain.hs | 3 +- fixme-new/examples/config | 61 + fixme-new/examples/config-fixme-new-config | 6 + fixme-new/fixme.cabal | 5 +- fixme-new/lib/Fixme/Config.hs | 5 +- fixme-new/lib/Fixme/Log.hs | 31 - fixme-new/lib/Fixme/Prelude.hs | 4 + fixme-new/lib/Fixme/Run.hs | 1043 +++++++---------- fixme-new/lib/Fixme/Run/Internal.hs | 540 +++++++++ fixme-new/lib/Fixme/RunOld.hs | 791 +++++++++++++ fixme-new/lib/Fixme/Scan.hs | 17 +- fixme-new/lib/Fixme/Scan/Git/Local.hs | 330 +----- fixme-new/lib/Fixme/State.hs | 757 +++++------- fixme-new/lib/Fixme/Types.hs | 251 ++-- hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs | 4 +- hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs | 5 +- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs | 8 +- hbs2-core/lib/HBS2/System/Dir.hs | 1 + .../HBS2/KeyMan/Keys/Direct.hs | 16 + hbs2-peer/app/PeerMain.hs | 16 +- hbs2-peer/app/RefChan.hs | 74 +- hbs2-peer/hbs2-peer.cabal | 1 + hbs2-peer/lib/HBS2/Peer/Notify.hs | 14 +- .../lib/HBS2/Peer/Proto/RefChan/Adapter.hs | 18 + .../HBS2/Peer/Proto/RefChan/RefChanHead.hs | 1 + .../HBS2/Peer/Proto/RefChan/RefChanNotify.hs | 1 + .../HBS2/Peer/Proto/RefChan/RefChanUpdate.hs | 1 + .../lib/HBS2/Peer/Proto/RefChan/Types.hs | 12 - hbs2-tests/hbs2-tests.cabal | 49 +- hbs2-tests/test/TestRefChanNotify.hs | 156 +++ 32 files changed, 2719 insertions(+), 1648 deletions(-) create mode 100644 docs/todo/hbs2-sync.txt create mode 100644 fixme-new/examples/config create mode 100644 fixme-new/examples/config-fixme-new-config delete mode 100644 fixme-new/lib/Fixme/Log.hs create mode 100644 fixme-new/lib/Fixme/Run/Internal.hs create mode 100644 fixme-new/lib/Fixme/RunOld.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Adapter.hs create mode 100644 hbs2-tests/test/TestRefChanNotify.hs diff --git a/.fixme-new/config b/.fixme-new/config index 6842955e..7e94c4a5 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -9,98 +9,65 @@ fixme-prefix TODO: fixme-prefix PR: fixme-prefix REVIEW: -fixme-git-scan-filter-days 30 +fixme-attribs assigned workflow :class -fixme-attribs assigned workflow type - -fixme-attribs resolution cat scope +fixme-attribs class fixme-value-set workflow new backlog wip test fixed done -fixme-value-set cat bug feat refactor +fixme-value-set class hardcode performance boilerplate + +; 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-exclude **/.** +fixme-exclude dist-newstyle 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) " " + (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)) ) ) - ) + (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) - ) + (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 +(define (ls) (report)) + +(define (lss s) (report workflow ~ s)) + +(define (done s) (modify s workflow :done)) +(define (wip s) (modify s workflow :wip)) +(define (test s) (modify s workflow :test)) +(define (new s) (modify s workflow :new)) +(define (backlog s) (modify s workflow :backlog)) + +;; refchan settings +(refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42) +(reader DTKxNwYCux7zHFLSvmEm5P3Ex21iQrrVdzJpR3giLh1D) +(author 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV) + diff --git a/docs/todo/hbs2-sync.txt b/docs/todo/hbs2-sync.txt new file mode 100644 index 00000000..776f74d9 --- /dev/null +++ b/docs/todo/hbs2-sync.txt @@ -0,0 +1,37 @@ +FIXME: race-on-large-files + добавляем большой файл ( ~4GB ) + делаем hbs2-sync run на хосте A + делаем hbs2-sync run на хосте B + результат: файл удалён (tomb transaction) + вероятно, гонка по какой-то причине. + + кажется, это backup-mode гадит + +TODO: hbs2-sync-recovery + сделать команды для получения всех + меркл-деревьев (игнорировать tomb-ы) + + сделать команду для постинга транзакции с + новым таймстемпом (восстановить файл из tomb-а не копируя его) + + +TODO: hbs2-sync-group-key-policy + сейчас на каждый файл генерируется новый групповой + ключ. + + это хорошо, но если добавить большой файл + удалить большой файл + добавить большой файл обратно --- получится + адовое дублирование данных. + + Возможное решение --- держать групповой ключ в кэше, + и устраивать его ротацию время от времени. + + +TODO: hbs2-sync-whole-state + сейчас будет выкачан весь рефчан, включая удалённые данные (tombs) + там, где они не нужны. + + это плохо для файлопомойки. + + нужно найти решения для проблемы diff --git a/fixme-new/app/FixmeMain.hs b/fixme-new/app/FixmeMain.hs index 90090cd8..cdcce401 100644 --- a/fixme-new/app/FixmeMain.hs +++ b/fixme-new/app/FixmeMain.hs @@ -1,6 +1,7 @@ module Main where import Fixme +-- import Fixme.Run import Fixme.Run import System.Environment @@ -62,7 +63,7 @@ main = do -- TODO: scan-all-sources -- for-source-from-con - runFixmeCLI (run =<< liftIO getArgs) + runFixmeCLI runCLI -- FIXME: test-fixme -- $workflow: wip diff --git a/fixme-new/examples/config b/fixme-new/examples/config new file mode 100644 index 00000000..7a82f9c0 --- /dev/null +++ b/fixme-new/examples/config @@ -0,0 +1,61 @@ + +; 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-files **/*.txt docs/devlog.md +fixme-files **/*.hs + +fixme-file-comments "*.scm" ";" + +fixme-comments ";" "--" + +(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 $type) " " + (align 12 $assigned) " " + (align 20 (trim 20 $committer-name)) " " + (trim 50 ($fixme-title)) " " + (nl)) + ) +) + +(set-template default short) + +(define (ls) (report)) + +(define (ls:wip) (report workflow ~ wip)) + +(define (stage) (fixme:stage:show)) + + diff --git a/fixme-new/examples/config-fixme-new-config b/fixme-new/examples/config-fixme-new-config new file mode 100644 index 00000000..d144b83d --- /dev/null +++ b/fixme-new/examples/config-fixme-new-config @@ -0,0 +1,6 @@ + +fixme-pager (quot (bat "--file-name" $file "-H" $before)) + +fixme-def-context 2 5 + + diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index b13aa4b6..66e23c71 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -57,6 +57,7 @@ common shared-properties , hbs2-storage-simple , hbs2-keyman-direct-lib , hbs2-git + , hbs2-cli , db-pipe , suckless-conf , fuzzy-parse @@ -104,11 +105,13 @@ common shared-properties library import: shared-properties + other-modules: + Fixme.Run.Internal + exposed-modules: Fixme Fixme.Config Fixme.Run - Fixme.Log Fixme.Types Fixme.Prelude Fixme.State diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs index db93590a..bbae5f67 100644 --- a/fixme-new/lib/Fixme/Config.hs +++ b/fixme-new/lib/Fixme/Config.hs @@ -5,7 +5,7 @@ import Fixme.Types import HBS2.System.Dir import System.Environment -import System.Directory +import System.Directory (getXdgDirectory, XdgDirectory(..)) binName :: FixmePerks m => m FilePath binName = liftIO getProgName @@ -16,6 +16,9 @@ localConfigDir = do b <- binName pure (p ("." <> b)) +fixmeWorkDir :: FixmePerks m => m FilePath +fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath + localConfig:: FixmePerks m => m FilePath localConfig = localConfigDir <&> ( "config") diff --git a/fixme-new/lib/Fixme/Log.hs b/fixme-new/lib/Fixme/Log.hs deleted file mode 100644 index 47b6f1cd..00000000 --- a/fixme-new/lib/Fixme/Log.hs +++ /dev/null @@ -1,31 +0,0 @@ -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 - diff --git a/fixme-new/lib/Fixme/Prelude.hs b/fixme-new/lib/Fixme/Prelude.hs index 3f69c708..1576e307 100644 --- a/fixme-new/lib/Fixme/Prelude.hs +++ b/fixme-new/lib/Fixme/Prelude.hs @@ -4,6 +4,7 @@ module Fixme.Prelude , GitRef(..) , Serialise(..) , serialise, deserialiseOrFail, deserialise + , module Exported ) where import HBS2.Prelude.Plated as All @@ -18,3 +19,6 @@ import Data.Function as All import UnliftIO as All import System.FilePattern as All import Control.Monad.Reader as All + +import Data.Config.Suckless.Script as Exported + diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 072c1cc3..09a7b457 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -1,6 +1,3 @@ -{-# Language MultiWayIf #-} -{-# Language PatternSynonyms #-} -{-# Language ViewPatterns #-} module Fixme.Run where import Prelude hiding (init) @@ -8,13 +5,26 @@ import Fixme.Prelude hiding (indent) import Fixme.Types import Fixme.Config import Fixme.State +import Fixme.Run.Internal import Fixme.Scan.Git.Local as Git import Fixme.Scan as Scan -import Fixme.Log + +import Data.Config.Suckless.Script.File + +import HBS2.KeyMan.Keys.Direct import HBS2.Git.Local.CLI +import HBS2.Peer.Proto.RefChan.Types +import HBS2.CLI.Run.KeyMan (keymanNewCredentials) + +import HBS2.OrDie +import HBS2.Peer.CLI.Detect +import HBS2.Net.Auth.GroupKeySymm +import HBS2.Data.Types.SignedBox import HBS2.Base58 +import HBS2.Storage.Operations.ByteString +import HBS2.Net.Auth.Credentials import HBS2.Merkle import HBS2.Data.Types.Refs import HBS2.Storage @@ -42,70 +52,64 @@ import Text.InterpolatedString.Perl6 (qc) import Data.Coerce import Control.Monad.Identity import Lens.Micro.Platform +import System.Environment import System.Process.Typed +import Control.Monad 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)) +recover :: (FixmePerks m) => FixmeEnv -> m a -> m a +recover env m = flip fix 0 $ \next attempt + -> do m + `catch` (\PeerNotConnected -> do + if attempt < 1 then do + runWithRPC env $ next (succ attempt) + else do + throwIO PeerNotConnected + ) -pattern Update :: forall {c}. [ScanGitArgs] -> Syntax c -pattern Update e <- ListVal (SymbolVal "update" : (scanGitArgs -> e)) +withFixmeCLI :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeEnv -> FixmeM m a -> m a +withFixmeCLI env m = do + recover env do + withFixmeEnv env m -pattern ReadFixmeStdin :: forall {c}. Syntax c -pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"] +runWithRPC :: (FixmePerks m) => FixmeEnv -> m a -> m a +runWithRPC FixmeEnv{..} m = do -pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c -pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e)) + 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) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client -pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c -pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s] + let newEnv = Just (MyPeerClientEndpoints soname peerAPI refChanAPI storageAPI) + liftIO $ atomically $ writeTVar fixmeEnvMyEndpoints newEnv + lift m -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 :: forall a m . FixmePerks m => FixmeM m a -> m a runFixmeCLI m = do dbPath <- localDBPath git <- findGitDir @@ -118,23 +122,31 @@ runFixmeCLI m = do <*> newTVarIO mempty <*> newTVarIO mempty <*> newTVarIO mempty - <*> newTVarIO mempty + <*> newTVarIO builtinAttribs + <*> newTVarIO builtinAttribVals <*> newTVarIO mempty <*> newTVarIO defCommentMap <*> newTVarIO Nothing + <*> newTVarIO mzero <*> newTVarIO mempty <*> newTVarIO mempty <*> newTVarIO defaultCatAction <*> newTVarIO defaultTemplate <*> newTVarIO mempty <*> newTVarIO (1,3) + <*> newTVarIO mzero + <*> newTVarIO mzero + <*> newTVarIO mzero + <*> newTVarIO mzero -- FIXME: defer-evolve -- не все действия требуют БД, -- хорошо бы, что бы она не создавалась, -- если не требуется - runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env - `finally` flushLoggers + mkdir (takeDirectory dbPath) + recover env do + runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env + `finally` flushLoggers where setupLogger = do setLogging @ERROR $ toStderr . logPrefix "[error] " @@ -156,10 +168,10 @@ silence = do setLoggingOff @ERROR setLoggingOff @WARN setLoggingOff @NOTICE + setLoggingOff @TRACE - -readConfig :: FixmePerks m => FixmeM m [Syntax C] +readConfig :: (FixmePerks m) => FixmeM m [Syntax C] readConfig = do user <- userConfigs @@ -169,659 +181,430 @@ readConfig = do try @_ @IOException (liftIO $ readFile conf) <&> fromRight mempty <&> parseTop - <&> fromRight mempty + >>= either (error.show) pure + + updateScanMagic pure $ mconcat w -init :: FixmePerks m => FixmeM m () -init = do - lo <- localConfigDir +runCLI :: FixmePerks m => FixmeM m () +runCLI = do + argz <- liftIO getArgs + forms <- parseTop (unlines $ unwords <$> splitForms argz) + & either (error.show) pure - let lo0 = takeFileName lo + runTop forms - mkdir lo - touch (lo "config") +notEmpty :: [a] -> Maybe [a] +notEmpty = \case + [] -> Nothing + x -> Just x - let gitignore = lo ".gitignore" - here <- doesPathExist gitignore +runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m () +runTop forms = do - unless here do - liftIO $ writeFile gitignore $ show $ - vcat [ pretty ("." localDBName) - ] + tvd <- newTVarIO mempty - notice $ yellow "run" <> line <> vcat [ - "git add" <+> pretty (lo0 ".gitignore") - , "git add" <+> pretty (lo0 "config") - ] + let dict = makeDict @C do + + internalEntries + + entry $ bindMatch "--help" $ nil_ \case + HelpEntryBound what -> helpEntry what + [StringLike s] -> helpList False (Just s) + _ -> helpList False Nothing + + entry $ bindMatch "fixme-prefix" $ nil_ \case + [StringLike pref] -> do + + t <- lift $ asks fixmeEnvTags + atomically (modifyTVar t (HS.insert (FixmeTag $ fromString pref))) + + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "fixme-attribs" $ nil_ \case + StringLikeList xs -> do + ta <- lift $ asks fixmeEnvAttribs + atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) -readFixmeStdin :: FixmePerks m => FixmeM m () -readFixmeStdin = do - what <- liftIO LBS8.getContents - fixmies <- Scan.scanBlob Nothing what - liftIO $ print $ vcat (fmap pretty fixmies) + _ -> throwIO $ BadFormException @C nil -list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m () -list_ tpl a = do - tpl <- asks fixmeEnvTemplates >>= readTVarIO - <&> HM.lookup (fromMaybe "default" tpl) + entry $ bindMatch "fixme-files" $ nil_ \case + StringLikeList xs -> do + w <- fixmeWorkDir + t <- lift $ asks fixmeEnvFileMask + atomically (modifyTVar t (<> fmap (w ) xs)) - fixmies <- selectFixmeThin a + _ -> throwIO $ BadFormException @C nil - case tpl of - Nothing-> do - liftIO $ LBS.putStr $ Aeson.encodePretty fixmies + entry $ bindMatch "fixme-exclude" $ nil_ \case + StringLikeList xs -> do + w <- fixmeWorkDir + t <- lift $ asks fixmeEnvFileExclude + atomically (modifyTVar t (<> fmap (w ) xs)) - 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" + _ -> throwIO $ BadFormException @C nil - liftIO $ hPutDoc stdout what + entry $ bindMatch "fixme-file-comments" $ nil_ $ \case + [StringLike ft, StringLike b] -> do + let co = Text.pack b & HS.singleton + t <- lift $ asks fixmeEnvFileComments + atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co)) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "fixme-comments" $ nil_ \case + (StringLikeList xs) -> do + t <- lift $ asks fixmeEnvDefComments + let co = fmap Text.pack xs & HS.fromList + atomically $ modifyTVar t (<> co) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "fixme-value-set" $ nil_ \case + (StringLike n : StringLikeList xs) -> do + t <- lift $ asks fixmeEnvAttribValues + let name = fromString n + let vals = fmap fromString xs & HS.fromList + atomically $ modifyTVar t (HM.insertWith (<>) name vals) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "fixme-pager" $ nil_ \case + [ListVal cmd0] -> do + t <- lift $ asks fixmeEnvCatAction + let action = CatAction $ \dict lbs -> do + + let ccmd = case inject dict cmd0 of + (StringLike p : StringLikeList xs) -> Just (p, xs) + _ -> Nothing -catFixmeMetadata :: FixmePerks m => Text -> FixmeM m () -catFixmeMetadata = cat_ True + debug $ pretty ccmd -catFixme :: FixmePerks m => Text -> FixmeM m () -catFixme = cat_ False + maybe1 ccmd none $ \(p, args) -> do -cat_ :: FixmePerks m => Bool -> Text -> FixmeM m () -cat_ metaOnly hash = do + let input = byteStringInput lbs + let cmd = setStdin input $ setStderr closed + $ proc p args + void $ runProcess cmd - (before,after) <- asks fixmeEnvCatContext >>= readTVarIO - gd <- fixmeGetGitDirCLIOpt + atomically $ writeTVar t action - CatAction action <- asks fixmeEnvCatAction >>= readTVarIO + _ -> throwIO $ BadFormException @C nil - void $ flip runContT pure do - callCC \exit -> do + entry $ bindMatch "fixme-def-context" $ nil_ \case + [LitIntVal a, LitIntVal b] -> do + t <- lift $ asks fixmeEnvCatContext + atomically $ writeTVar t (fromIntegral a, fromIntegral b) - mha <- lift $ selectFixmeHash hash + _ -> throwIO $ BadFormException @C nil - ha <- ContT $ maybe1 mha (pure ()) - fme' <- lift $ selectFixme ha + entry $ bindMatch "modify" $ nil_ \case + [ FixmeHashLike w, StringLike k, StringLike v ] -> lift do + void $ runMaybeT do + key <- lift (selectFixmeKey w) >>= toMPlus + lift $ modifyFixme key [(fromString k, fromString v)] - Fixme{..} <- ContT $ maybe1 fme' (pure ()) + _ -> throwIO $ BadFormException @C nil - when metaOnly do - for_ (HM.toList fixmeAttr) $ \(k,v) -> do - liftIO $ print $ (pretty k <+> pretty v) - exit () - let gh' = HM.lookup "blob" fixmeAttr + entry $ bindMatch "delete" $ nil_ \case + [ FixmeHashLike w ] -> lift do + void $ runMaybeT do + key <- lift (selectFixmeKey w) >>= toMPlus + lift $ modifyFixme key [("deleted", "true")] - -- FIXME: define-fallback-action - gh <- ContT $ maybe1 gh' none + _ -> throwIO $ BadFormException @C nil - 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 + entry $ bindMatch "cat" $ nil_ $ \case + [ FixmeHashLike w ] -> lift do + cat_ w - let dict = [ (mkId k, mkstr @C v) | (k,v) <- HM.toList fixmeAttr ] - <> - [ (mkId (FixmeAttrName "before"), mkstr @C (FixmeAttrVal $ Text.pack $ show bbefore)) + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "dump" $ nil_ $ \case + [ FixmeHashLike w ] -> lift $ void $ runMaybeT do + key <- lift (selectFixmeKey w) >>= toMPlus + fme <- lift $ getFixme key + liftIO $ print $ pretty fme + + _ -> throwIO $ BadFormException @C nil + -- magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO + -- liftIO $ print $ pretty magic + + + entry $ bindMatch "report" $ nil_ $ lift . \case + ( SymbolVal "template" : StringLike t : p ) -> do + report (Just t) p + + ( SymbolVal "--template" : StringLike t : p ) -> do + report (Just t) p + + p -> do + report Nothing p + + entry $ bindMatch "fixme:key:show" $ nil_ \case + [ FixmeHashLike w ] -> lift $ void $ runMaybeT do + key <- lift (selectFixmeKey w) >>= toMPlus + liftIO $ print $ pretty key + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "fixme:scan-magic" $ nil_ $ const do + magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO + liftIO $ print $ pretty magic + + entry $ bindMatch "fixme:path" $ nil_ $ const do + path <- lift fixmeWorkDir + liftIO $ print $ pretty path + + entry $ bindMatch "fixme:files" $ nil_ $ const do + w <- lift fixmeWorkDir + incl <- lift (asks fixmeEnvFileMask >>= readTVarIO) + excl <- lift (asks fixmeEnvFileExclude >>= readTVarIO) + glob incl excl w $ \fn -> do + liftIO $ putStrLn (makeRelative w fn) + pure True + + entry $ bindMatch "fixme:state:drop" $ nil_ $ const $ lift do + cleanupDatabase + + entry $ bindMatch "fixme:state:cleanup" $ nil_ $ const $ lift do + cleanupDatabase + + entry $ bindMatch "fixme:git:import" $ nil_ $ const $ lift do + import_ + + entry $ bindMatch "fixme:git:list" $ nil_ $ const do + fxs <- lift scanFiles + for_ fxs $ \fme -> do + liftIO $ print $ pretty fme + + -- TODO: some-uncommited-shit + + -- TODO: some-shit + -- one + + -- TODO: some-shit + -- new text + + entry $ bindMatch "env:show" $ nil_ $ const $ do + lift printEnv + + entry $ bindMatch "refchan:show" $ nil_ $ const do + tref <- lift $ asks fixmeEnvRefChan + r <- readTVarIO tref + liftIO $ print $ pretty (fmap AsBase58 r) + + entry $ bindMatch "refchan" $ nil_ \case + [SignPubKeyLike rchan] -> do + tref<- lift $ asks fixmeEnvRefChan + atomically $ writeTVar tref (Just rchan) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "author" $ nil_ \case + [SignPubKeyLike au] -> do + t <- lift $ asks fixmeEnvAuthor + atomically $ writeTVar t (Just au) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "reader" $ nil_ \case + [EncryptPubKeyLike reader] -> do + t <- lift $ asks fixmeEnvReader + atomically $ writeTVar t (Just reader) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "git:commits" $ const $ do + co <- lift listCommits <&> fmap (mkStr @C . view _1) + pure $ mkList co + + entry $ bindMatch "fixme:refchan:export" $ nil_ $ \case + [SymbolVal "dry"] -> do + notice $ yellow "export is running in dry mode" + void $ lift $ refchanExport [RefChanExportDry] + + _ -> void $ lift $ refchanExport () + + entry $ bindMatch "fixme:refchan:import" $ nil_ $ const $ lift do + void $ refchanImport + + + entry $ bindMatch "update" $ nil_ $ const $ lift do + refchanUpdate + + entry $ bindMatch "fixme:refchan:update" $ nil_ $ const $ lift do + refchanUpdate + + entry $ bindMatch "git:blobs" $ \_ -> do + blobs <- lift (listBlobs Nothing) + + elems <- for blobs $ \(f,h) -> do + pure $ mkList @C [ mkStr f, mkSym ".", mkStr h ] + + pure $ mkList @C elems + + entry $ bindMatch "init" $ nil_ $ const $ do + lift init + + brief "initializes a new refchan" $ + desc ( vcat [ + "Refchan is an ACL-controlled CRDT channel useful for syncronizing" + , "fixme-new state amongst the different remote setups/peers/directories" + , "use it if you want to use fixme-new in a distributed fashion" ] + ) $ + args [] $ + returns "string" "refchan-key" $ do + entry $ bindMatch "refchan:init" $ nil_ $ const $ do - 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 + let rch0 = refChanHeadDefault @L4Proto + sto <- lift getStorage + peer <- lift $ getClientAPI @PeerAPI @UNIX + rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX - what <- selectStage + confFile <- localConfig + conf <- liftIO (readFile confFile) + <&> parseTop + <&> either (error.show) (fmap (fixContext @_ @C)) - 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) + let already = headMay [ x + | ListVal [StringLike "refchan", SignPubKeyLike x] <- conf + ] - Just (Left{}) -> do - put sto k (LBS.toStrict $ serialise w) + flip runContT pure $ callCC \done -> do - Just (Right prev) | getSequence w > getSequence prev -> do - put sto k (LBS.toStrict $ serialise w) + when (isJust already) do + warn $ red "refchan is already set" <+> pretty (fmap AsBase58 already) - _ -> pure () + poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () + >>= orThrowUser "hbs2-peer not connected" + <&> parseTop + <&> fromRight mempty - compactStorageClose sto + pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x + | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked + ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set" - cleanStage -importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m () -importFromLog sto = do - fset <- listAllFixmeHashes + notice $ green "default peer" <+> pretty (AsBase58 pkey) - -- 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 + signK' <- lift $ runKeymanClientRO $ listCredentials + <&> headMay - 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)) + signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman") - withState $ transactional do - for_ (rights toImport) insertFixme + notice $ green "default author" <+> pretty (AsBase58 signK) - let w = lefts toImport - runForms (mconcat w) + -- 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 - unless (List.null toImport) do - updateIndexes + notice $ green "group key" <+> maybe "none" pretty gkh' - -- compactStorageClose sto + readers <- fromMaybe mempty <$> runMaybeT do + gh <- toMPlus gkh' + gk <- loadGroupKeyMaybe @'HBS2Basic sto gh + >>= toMPlus + pure $ HM.keys (recipients gk) -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 + notice $ green "readers" <+> pretty (length readers) - comments2 <- asks fixmeEnvFileComments >>= readTVarIO - <&> HM.toList - <&> fmap (over _2 HS.toList) + let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers) + & set refChanHeadAuthors (HS.singleton signK) + & set refChanHeadPeers (HM.singleton pkey 1) - attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList - vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList - for_ tags $ \m -> do - liftIO $ print $ "fixme-prefix" <+> pretty m + let unlucky = HM.null (view refChanHeadPeers rch1) + || HS.null (view refChanHeadAuthors rch1) - for_ masks $ \m -> do - liftIO $ print $ "fixme-files" <+> dquotes (pretty m) - for_ days $ \d -> do - liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d + liftIO $ print $ pretty rch1 - for_ comments1 $ \d -> do - liftIO $ print $ "fixme-comments" <+> dquotes (pretty d) + 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 - for_ comments2 $ \(ft, comm') -> do - for_ comm' $ \comm -> do - liftIO $ print $ "fixme-file-comments" - <+> dquotes (pretty ft) <+> dquotes (pretty comm) + creds <- lift $ runKeymanClientRO $ loadCredentials refchan + >>= orThrowUser "can't load credentials" - for_ attr $ \a -> do - liftIO $ print $ "fixme-attribs" - <+> pretty a + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1 - for_ vals$ \(v, vs) -> do - liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs)) + href <- writeAsMerkle sto (serialise box) - for_ g $ \git -> do - liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git) + callService @RpcPollAdd peer (refchan, "refchan", 17) + >>= orThrowUser "can't subscribe to refchan" - dbPath <- asks fixmeEnvDbPath >>= readTVarIO - liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath) + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" - (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + liftIO $ appendFile confFile $ + show $ pretty ( mkList @C [ mkSym "refchan" + , mkSym (show $ pretty (AsBase58 refchan)) ] + ) - liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after - ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList + entry $ bindMatch "set-template" $ nil_ \case + [SymbolVal who, SymbolVal w] -> do + templates <- lift $ asks fixmeEnvTemplates + t <- readTVarIO templates + for_ (HM.lookup w t) $ \tpl -> do + atomically $ modifyTVar templates (HM.insert who tpl) - for_ ma $ \(n, syn) -> do - liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn) + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "define-template" $ nil_ $ \case + [SymbolVal who, IsSimpleTemplate body ] -> do + t <- lift $ asks fixmeEnvTemplates + atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate body))) -help :: FixmePerks m => m () -help = do - notice "this is help message" + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "log:trace:on" $ nil_ $ const do + lift $ setLogging @TRACE $ toStderr . logPrefix "" -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 + entry $ bindMatch "log:trace:off" $ nil_ $ const do + lift $ setLoggingOff @TRACE - emit = S.yield . reverse + entry $ bindMatch "log:debug:on" $ nil_ $ const do + lift $ setLogging @DEBUG $ toStderr . logPrefix "" -sanitizeLog :: [Syntax c] -> [Syntax c] -sanitizeLog lls = flip filter lls $ \case - ListVal (SymbolVal "deleted" : _) -> True - ListVal (SymbolVal "modified" : _) -> True - _ -> False + entry $ bindMatch "log:debug:off" $ nil_ $ const do + lift $ setLoggingOff @DEBUG -pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c] -pattern Template w syn <- (mbTemplate -> (w, syn)) + entry $ bindMatch "debug:peer:check" $ nil_ $ const do + peer <- lift $ getClientAPI @PeerAPI @UNIX + poked <- callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () + <&> fromMaybe "hbs2-peer not connected" + liftIO $ putStrLn poked -mbTemplate :: [Syntax c] -> (Maybe Id, [Syntax c]) -mbTemplate = \case - ( SymbolVal "template" : StringLike w : rest ) -> (Just (fromString w), rest) - other -> (Nothing, other) + conf <- readConfig -pattern IsSimpleTemplate :: forall {c} . [Syntax c] -> [Syntax c] -pattern IsSimpleTemplate xs <- [ListVal (SymbolVal "simple" : xs)] + argz <- liftIO getArgs -run :: FixmePerks m => [String] -> FixmeM m () -run what = do + let args = zipWith (\i s -> bindValue (mkId ("$_" <> show i)) (mkStr @C s )) [1..] argz + & HM.unions - sc <- readConfig + let finalDict = dict <> args -- :: Dict C (FixmeM m) - 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) + atomically $ writeTVar tvd finalDict + run finalDict (conf <> forms) >>= eatNil display diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs new file mode 100644 index 00000000..f459cde7 --- /dev/null +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -0,0 +1,540 @@ +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +module Fixme.Run.Internal where + +import Prelude hiding (init) +import Fixme.Prelude hiding (indent) +import Fixme.Types +import Fixme.Config +import Fixme.State +import Fixme.Scan.Git.Local as Git +import Fixme.Scan as Scan + +import HBS2.Git.Local.CLI + +import HBS2.Polling +import HBS2.OrDie +import HBS2.Base58 +import HBS2.Data.Types.SignedBox +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.RPC.Client.RefChan +import HBS2.Storage.Operations.ByteString +import HBS2.System.Dir +import HBS2.Net.Auth.Credentials +import DBPipe.SQLite hiding (field) + + +import HBS2.KeyMan.Keys.Direct + +import Data.Config.Suckless.Script.File + +import Data.List.Split (chunksOf) +import Data.Aeson.Encode.Pretty as Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString qualified as BS +import Data.Either +import Data.Maybe +import Data.HashSet qualified as HS +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8) +import Text.InterpolatedString.Perl6 (qc) +import Data.Coerce +import Data.Word +import Lens.Micro.Platform +import System.Process.Typed +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Control.Concurrent.STM (flushTQueue) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import System.Directory (getModificationTime) + + +import Streaming.Prelude qualified as S + +pattern IsSimpleTemplate :: forall {c} . [Syntax c] -> Syntax c +pattern IsSimpleTemplate xs <- ListVal (SymbolVal "simple" : xs) + +{- HLINT ignore "Functor law" -} + +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) + |] + + +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") + ] + + +printEnv :: FixmePerks m => FixmeM m () +printEnv = do + g <- asks fixmeEnvGitDir >>= readTVarIO + masks <- asks fixmeEnvFileMask >>= readTVarIO + excl <- asks fixmeEnvFileExclude >>= 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_ excl $ \m -> do + liftIO $ print $ "fixme-exclude" <+> 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) + + rchan <- asks fixmeEnvRefChan >>= readTVarIO + + liftIO $ print $ ("refchan" <+> pretty (AsBase58 <$> rchan)) + + author <- asks fixmeEnvAuthor >>= readTVarIO + + liftIO $ print $ ("author" <+> pretty (AsBase58 <$> author)) + + reader <- asks fixmeEnvReader >>= readTVarIO + + liftIO $ print $ ("reader" <+> pretty (AsBase58 <$> reader)) + +scanFiles :: FixmePerks m => FixmeM m [Fixme] +scanFiles = do + w <- fixmeWorkDir + incl <- asks fixmeEnvFileMask >>= readTVarIO + excl <- asks fixmeEnvFileExclude >>= readTVarIO + + keys <- newTVarIO (mempty :: HashMap Text Integer) + + S.toList_ do + + glob incl excl w $ \fn -> do + + ts <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds + + let fnShort = makeRelative w fn + + lbs <- liftIO (try @_ @IOException $ LBS.readFile fn) + <&> fromRight mempty + + fxs0 <- lift $ scanBlob (Just fn) lbs + + for_ fxs0 $ \fme -> do + let key = fromString (fnShort <> "#") <> coerce (fixmeTitle fme) <> ":" :: Text + atomically $ modifyTVar keys (HM.insertWith (+) key 1) + no <- readTVarIO keys <&> HM.lookup key <&> fromMaybe 0 + let keyText = key <> fromString (show no) + let keyHash = FixmeKey $ fromString $ show $ pretty $ hashObject @HbSync (serialise keyText) + let f2 = mempty { fixmeTs = Just (fromIntegral ts) + , fixmeKey = keyHash + , fixmeAttr = HM.fromList + [ ( "fixme-key-string", FixmeAttrVal keyText) + , ( "file", FixmeAttrVal (fromString fnShort)) + ] + , fixmePlain = fixmePlain fme + } + let fmeNew = (fme <> f2) & fixmeDerivedFields + S.yield fmeNew + + pure True + + +report :: (FixmePerks m, HasPredicate q) => Maybe FilePath -> q -> FixmeM m () +report t q = do + + tpl <- asks fixmeEnvTemplates >>= readTVarIO + <&> HM.lookup (maybe "default" fromString t) + + fxs <- listFixme q + + case tpl of + Nothing -> + liftIO $ LBS.putStr $ Aeson.encodePretty (fmap fixmeAttr fxs) + + Just (Simple (SimpleTemplate simple)) -> do + for_ fxs $ \(Fixme{..}) -> do + let subst = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList fixmeAttr ] + let what = render (SimpleTemplate (inject subst simple)) + & fromRight "render error" + + liftIO $ hPutDoc stdout what + + +import_ :: FixmePerks m => FixmeM m () +import_ = do + fxs0 <- scanFiles + + fxs <- flip filterM fxs0 $ \fme -> do + let fn = fixmeGet "file" fme <&> Text.unpack . coerce + seen <- maybe1 fn (pure False) selectIsAlreadyScannedFile + pure (not seen) + + hashes <- catMaybes <$> flip runContT pure do + p <- ContT $ bracket startGitHash stopProcess + let files = mapMaybe (fixmeGet "file") fxs + & HS.fromList + & HS.toList + & fmap (Text.unpack . coerce) + for files $ \f -> do + mbHash <- lift $ gitHashPathStdin p f + case mbHash of + Just ha -> + pure $ Just (f, ha) + Nothing -> + pure Nothing + + versioned <- listBlobs Nothing <&> HM.fromList + let commited = HM.elems versioned & HS.fromList + + let blobs = HM.fromList hashes + + let isVersioned = maybe False (`HM.member` versioned) + + withState $ transactional do + for_ fxs $ \fme -> do + let fn = fixmeGet "file" fme <&> Text.unpack . coerce + fmeRich <- lift $ maybe1 fn (pure mempty) (`getMetaDataFromGitBlame` fme) + + let blob = fn >>= flip HM.lookup blobs + >>= \b -> pure (fixmeSet "blob" (fromString (show $ pretty $ b)) mempty) + + notice $ "fixme" <+> pretty (fixmeKey fme) <+> pretty fn + insertFixme (fromMaybe mempty blob <> fmeRich <> fme) + + -- TODO: add-scanned-only-on-commited + -- $workflow: test + -- поведение: если файл в гите И закоммичен -- то + -- добавляем в сканированные. + -- + -- если не в гите -- то добавляем в сканированные + -- + for_ fn $ \f -> do + let add = not (isVersioned fn) + || maybe False (`HS.member` commited) (HM.lookup f blobs) + + when add do + insertScannedFile f + +cat_ :: FixmePerks m => Text -> FixmeM m () +cat_ hash = do + + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + gd <- fixmeGetGitDirCLIOpt + + CatAction action <- asks fixmeEnvCatAction >>= readTVarIO + + dir <- fixmeWorkDir + + void $ flip runContT pure do + callCC \exit -> do + + mha <- lift $ selectFixmeKey hash + + ha <- ContT $ maybe1 mha (pure ()) + + fme' <- lift $ getFixme ha + + fx@Fixme{..} <- ContT $ maybe1 fme' (pure ()) + + 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 (const Nothing) Just + + maybe1 w none $ \lbs -> do + let piece = LBS8.lines lbs & drop start & take lno + liftIO $ action dict (LBS8.unlines piece) + exit () + + let fallback = LBS8.unlines $ fmap (LBS8.fromStrict . encodeUtf8 . coerce) fixmePlain + + liftIO $ action dict fallback + +class HasRefChanExportOpts a where + refchanExportDry :: a -> Bool + +data RefChanExportOpts = + RefChanExportDry + deriving (Eq,Ord,Show,Enum) + +instance HasRefChanExportOpts [RefChanExportOpts] where + refchanExportDry what = RefChanExportDry `elem` what + +instance HasRefChanExportOpts () where + refchanExportDry _ = False + +refchanExport :: (FixmePerks m, HasRefChanExportOpts a) => a -> FixmeM m Int +refchanExport opts = do + + let dry = refchanExportDry opts + + sto <- getStorage + rchanAPI <- getClientAPI @RefChanAPI @UNIX + + + chan <- asks fixmeEnvRefChan + >>= readTVarIO + >>= orThrowUser "refchan not set" + + au <- asks fixmeEnvAuthor + >>= readTVarIO + >>= orThrowUser "author's key not set" + + creds <- runKeymanClientRO $ loadCredentials au + >>= orThrowUser "can't read credentials" + + + let (pk,sk) = (view peerSignPk creds, view peerSignSk creds) + + withState do + -- FIXME: select-only-really-missed-records + -- сейчас всегда фуллскан. будет всё дольше и дольше + -- с ростом количества записей. Нужно отбирать + -- только такие элементы, которые реально отсутствуют + -- в рефчане + what <- select_ @_ @FixmeExported [qc| + select distinct o,w,k,cast (v as text) + from object obj + where not exists (select null from scanned where hash = obj.nonce) + order by o, k, v, w + |] + + let chu = chunksOf 10000 what + + flip runContT pure do + + for_ chu $ \x -> callCC \next -> do + + -- FIXME: encrypt-tree + -- 1. откуда ключ взять + -- 2. куда его положить + -- 3. один на всех? + -- 4. по одному на каждого? + -- 5. как будет устроена ротация + -- 6. как делать доступ к историческим данным + -- 6.1 новые ключи в этот же рефчан + -- 6.2 или новые ключи в какой-то еще рефчан + h <- writeAsMerkle sto (serialise x) + + let tx = AnnotatedHashRef Nothing (HashRef h) + + lift do + + let lbs = serialise tx + + let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs) + + warn $ "POST" <+> red "unencrypted!" <+> pretty (length x) <+> pretty (hashObject @HbSync (serialise box)) + + unless dry do + r <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box) + + when (isNothing r) do + err $ red "hbs2-peer rpc calling timeout" + + pure $ length what + +refchanUpdate :: FixmePerks m => FixmeM m () +refchanUpdate = do + + rchan <- asks fixmeEnvRefChan + >>= readTVarIO + >>= orThrowUser "refchan not set" + + api <- getClientAPI @RefChanAPI @UNIX + + h0 <- callService @RpcRefChanGet api rchan + >>= orThrowUser "can't request refchan head" + + txn <- refchanExport () + + unless (txn == 0) do + + notice $ "wait refchan" <+> pretty (AsBase58 rchan) <+> "to update..." + + -- TODO: implement-refchan-update-notifications + + -- FIXME: use-wait-time-from-refchan-head + + -- TODO: fix-this-lame-polling + flip fix 0 $ \next -> \case + n | n >= 3 -> pure () + n -> do + + h <- callService @RpcRefChanGet api rchan + >>= orThrowUser "can't request refchan head" + + if h0 /= h then + pure () + else do + pause @'Seconds 1 + next (succ n) + + none + + refchanImport + +refchanImport :: FixmePerks m => FixmeM m () +refchanImport = do + + sto <- getStorage + + chan <- asks fixmeEnvRefChan + >>= readTVarIO + >>= orThrowUser "refchan not set" + + + ttsmap <- newTVarIO HM.empty + accepts <- newTVarIO HM.empty + + tq <- newTQueueIO + + -- TODO: assume-huge-list + -- scanned <- listAllScanned + let goodToGo x = do + here <- selectIsAlreadyScanned x + pure $ not here + + walkRefChanTx @UNIX goodToGo chan $ \txh u -> do + + case u of + + A (AcceptTran (Just ts) _ what) -> do + debug $ red "ACCEPT" <+> pretty ts <+> pretty what + atomically $ modifyTVar ttsmap (HM.insertWith max what (coerce @_ @Word64 ts)) + atomically $ modifyTVar accepts (HM.insertWith (<>) what (HS.singleton txh)) + + A _ -> none + + P orig (ProposeTran _ box) -> void $ runMaybeT do + (_, bs) <- unboxSignedBox0 box & toMPlus + + AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) + & toMPlus . either (const Nothing) Just + + scanned <- lift $ selectIsAlreadyScanned href + + -- notice $ yellow "SCANNED" <+> pretty scanned + + if scanned then do + atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh + lift $ withState $ transactional do + insertScanned txh + for_ atx insertScanned + + else do + + -- FIXME: decrypt-tree + what <- runExceptT (readFromMerkle sto (SimpleKey (coerce href))) + <&> either (const Nothing) Just + >>= toMPlus + + exported <- deserialiseOrFail @[FixmeExported] what + & toMPlus + + for_ exported $ \e -> do + atomically $ writeTQueue tq (txh, orig, href, e) + + imported <- atomically $ flushTQueue tq + + withState $ transactional do + for_ imported $ \(txh, h, href, i) -> do + w <- readTVarIO ttsmap <&> fromMaybe (exportedWeight i) . HM.lookup h + let item = i { exportedWeight = w } + + if exportedWeight item /= 0 then do + notice $ "import" <+> pretty (exportedKey item) <+> pretty (exportedWeight item) + insertFixmeExported (localNonce (href,i)) item + else do + debug $ "SKIP TX!" <+> pretty txh + + atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup h + insertScanned txh + insertScanned href + for_ atx insertScanned + diff --git a/fixme-new/lib/Fixme/RunOld.hs b/fixme-new/lib/Fixme/RunOld.hs new file mode 100644 index 00000000..14e5db1f --- /dev/null +++ b/fixme-new/lib/Fixme/RunOld.hs @@ -0,0 +1,791 @@ +{-# Language MultiWayIf #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +module Fixme.RunOld where + +import Prelude hiding (init) +import Fixme.Prelude hiding (indent) +import Fixme.Types +import Fixme.Config +import Fixme.State +import Fixme.Scan.Git.Local as Git +import Fixme.Scan as Scan + +import HBS2.Git.Local.CLI + +import HBS2.Base58 +import HBS2.Merkle +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Storage.Compact +import HBS2.System.Dir +import DBPipe.SQLite hiding (field) +import Data.Config.Suckless + +import Data.Aeson.Encode.Pretty as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Either +import Data.Maybe +import Data.HashSet qualified as HS +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.HashSet (HashSet) +import Data.Set qualified as Set +import Data.Generics.Product.Fields (field) +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Text.InterpolatedString.Perl6 (qc) +import Data.Coerce +import Control.Monad.Identity +import Lens.Micro.Platform +import System.Process.Typed +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import System.IO.Temp as Temp +import System.IO qualified as IO + + +import Streaming.Prelude qualified as S + + +{- HLINT ignore "Functor law" -} + +pattern Init :: forall {c}. Syntax c +pattern Init <- ListVal [SymbolVal "init"] + +pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c +pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e)) + +pattern Update :: forall {c}. [ScanGitArgs] -> Syntax c +pattern Update e <- ListVal (SymbolVal "update" : (scanGitArgs -> e)) + +pattern ReadFixmeStdin :: forall {c}. Syntax c +pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"] + +pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c +pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e)) + + +pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c +pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s] + +pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c +pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ] + + +logRootKey :: SomeRefKey ByteString +logRootKey = SomeRefKey "ROOT" + +scanGitArgs :: [Syntax c] -> [ScanGitArgs] +scanGitArgs syn = [ w | ScanGitArgs w <- syn ] + + +fileMasks :: [Syntax c] -> [FilePattern] +fileMasks what = [ show (pretty s) | s <- what ] + +fixmePrefix :: Syntax c -> Maybe FixmeTag +fixmePrefix = \case + SymbolVal s -> Just (FixmeTag (coerce s)) + _ -> Nothing + + +defaultTemplate :: HashMap Id FixmeTemplate +defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ] + where + short = parseTop s & fromRight mempty + s = [qc| +(trim 10 $fixme-key) " " +(align 6 $fixme-tag) " " +(trim 50 ($fixme-title)) +(nl) + |] + + +runFixmeCLI :: FixmePerks m => FixmeM m a -> m a +runFixmeCLI m = do + dbPath <- localDBPath + git <- findGitDir + env <- FixmeEnv + <$> newMVar () + <*> newTVarIO mempty + <*> newTVarIO dbPath + <*> newTVarIO Nothing + <*> newTVarIO git + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defCommentMap + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defaultCatAction + <*> newTVarIO defaultTemplate + <*> newTVarIO mempty + <*> newTVarIO (1,3) + + -- FIXME: defer-evolve + -- не все действия требуют БД, + -- хорошо бы, что бы она не создавалась, + -- если не требуется + runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env + `finally` flushLoggers + where + setupLogger = do + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + + flushLoggers = do + silence + + -- FIXME: tied-fucking-context + defaultCatAction = CatAction $ \dict lbs -> do + LBS.putStr lbs + pure () + +silence :: FixmePerks m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + + + +readConfig :: FixmePerks m => FixmeM m [Syntax C] +readConfig = do + + user <- userConfigs + lo <- localConfig + + w <- for (lo : user) $ \conf -> do + try @_ @IOException (liftIO $ readFile conf) + <&> fromRight mempty + <&> parseTop + <&> fromRight mempty + + pure $ mconcat w + +init :: FixmePerks m => FixmeM m () +init = do + + lo <- localConfigDir + + let lo0 = takeFileName lo + + mkdir lo + touch (lo "config") + + let gitignore = lo ".gitignore" + here <- doesPathExist gitignore + + unless here do + liftIO $ writeFile gitignore $ show $ + vcat [ pretty ("." localDBName) + ] + + notice $ yellow "run" <> line <> vcat [ + "git add" <+> pretty (lo0 ".gitignore") + , "git add" <+> pretty (lo0 "config") + ] + + + +readFixmeStdin :: FixmePerks m => FixmeM m () +readFixmeStdin = do + what <- liftIO LBS8.getContents + fixmies <- Scan.scanBlob Nothing what + liftIO $ print $ vcat (fmap pretty fixmies) + + +list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m () +list_ tpl a = do + tpl <- asks fixmeEnvTemplates >>= readTVarIO + <&> HM.lookup (fromMaybe "default" tpl) + + fixmies <- selectFixmeThin a + + case tpl of + Nothing-> do + liftIO $ LBS.putStr $ Aeson.encodePretty fixmies + + Just (Simple (SimpleTemplate simple)) -> do + for_ fixmies $ \(FixmeThin attr) -> do + let subst = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList attr ] + let what = render (SimpleTemplate (inject subst simple)) + & fromRight "render error" + + liftIO $ hPutDoc stdout what + + +catFixmeMetadata :: FixmePerks m => Text -> FixmeM m () +catFixmeMetadata = cat_ True + +catFixme :: FixmePerks m => Text -> FixmeM m () +catFixme = cat_ False + +cat_ :: FixmePerks m => Bool -> Text -> FixmeM m () +cat_ metaOnly hash = do + + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + gd <- fixmeGetGitDirCLIOpt + + CatAction action <- asks fixmeEnvCatAction >>= readTVarIO + + void $ flip runContT pure do + callCC \exit -> do + + mha <- lift $ selectFixmeHash hash + + ha <- ContT $ maybe1 mha (pure ()) + + fme' <- lift $ selectFixme ha + + Fixme{..} <- ContT $ maybe1 fme' (pure ()) + + when metaOnly do + for_ (HM.toList fixmeAttr) $ \(k,v) -> do + liftIO $ print $ (pretty k <+> pretty v) + exit () + + let gh' = HM.lookup "blob" fixmeAttr + + -- FIXME: define-fallback-action + gh <- ContT $ maybe1 gh' none + + let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String + + let start = fromMaybe 0 fixmeStart & fromIntegral & (\x -> x - before) & max 0 + let bbefore = if start > before then before + 1 else 1 + let origLen = maybe 0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1 + let lno = max 1 $ origLen + after + before + + let dict = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList fixmeAttr ] + <> + [ (mkId (FixmeAttrName "before"), mkStr @C (FixmeAttrVal $ Text.pack $ show bbefore)) + ] + + debug (pretty cmd) + + w <- gitRunCommand cmd + <&> either (LBS8.pack . show) id + <&> LBS8.lines + <&> drop start + <&> take lno + + liftIO $ action dict (LBS8.unlines w) + +delete :: FixmePerks m => Text -> FixmeM m () +delete txt = do + acts <- asks fixmeEnvUpdateActions >>= readTVarIO + hashes <- selectFixmeHashes txt + for_ hashes $ \ha -> do + insertFixmeDelStaged ha + +modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m () +modify_ txt a b = do + acts <- asks fixmeEnvUpdateActions >>= readTVarIO + void $ runMaybeT do + ha <- toMPlus =<< lift (selectFixmeHash txt) + lift $ insertFixmeModStaged ha (fromString a) (fromString b) + + +importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m () +importFromLog sto = do + fset <- listAllFixmeHashes + + -- sto <- compactStorageOpen @HbSync readonly fn + ks <- keys sto + + toImport <- S.toList_ do + for_ ks $ \k -> runMaybeT do + v <- get sto k & MaybeT + what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus + + case what of + Added _ fx -> do + let ha = hashObject @HbSync (serialise fx) & HashRef + unless (HS.member ha fset) do + warn $ red "import" <+> viaShow (pretty ha) + lift $ S.yield (Right fx) + w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w)) + + withState $ transactional do + for_ (rights toImport) insertFixme + + let w = lefts toImport + eval (mconcat w) + + unless (List.null toImport) do + updateIndexes + + -- compactStorageClose sto + +printEnv :: FixmePerks m => FixmeM m () +printEnv = do + g <- asks fixmeEnvGitDir >>= readTVarIO + masks <- asks fixmeEnvFileMask >>= readTVarIO + tags <- asks fixmeEnvTags >>= readTVarIO + days <- asks fixmeEnvGitScanDays >>= readTVarIO + comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList + + comments2 <- asks fixmeEnvFileComments >>= readTVarIO + <&> HM.toList + <&> fmap (over _2 HS.toList) + + attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList + vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList + + for_ tags $ \m -> do + liftIO $ print $ "fixme-prefix" <+> pretty m + + for_ masks $ \m -> do + liftIO $ print $ "fixme-files" <+> dquotes (pretty m) + + for_ days $ \d -> do + liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d + + for_ comments1 $ \d -> do + liftIO $ print $ "fixme-comments" <+> dquotes (pretty d) + + for_ comments2 $ \(ft, comm') -> do + for_ comm' $ \comm -> do + liftIO $ print $ "fixme-file-comments" + <+> dquotes (pretty ft) <+> dquotes (pretty comm) + + for_ attr $ \a -> do + liftIO $ print $ "fixme-attribs" + <+> pretty a + + for_ vals$ \(v, vs) -> do + liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs)) + + for_ g $ \git -> do + liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git) + + dbPath <- asks fixmeEnvDbPath >>= readTVarIO + liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath) + + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + + liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after + + ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList + + for_ ma $ \(n, syn) -> do + liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn) + + +help :: FixmePerks m => m () +help = do + notice "this is help message" + + +-- splitForms :: [String] -> [[String]] +-- splitForms s0 = runIdentity $ S.toList_ (go mempty s0) +-- where +-- go acc ( "then" : rest ) = emit acc >> go mempty rest +-- go acc ( "and" : rest ) = emit acc >> go mempty rest +-- go acc ( x : rest ) = go ( x : acc ) rest +-- go acc [] = emit acc + +-- emit = S.yield . reverse + +sanitizeLog :: [Syntax c] -> [Syntax c] +sanitizeLog lls = flip filter lls $ \case + ListVal (SymbolVal "deleted" : _) -> True + ListVal (SymbolVal "modified" : _) -> True + _ -> False + +pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c] +pattern Template w syn <- (mbTemplate -> (w, syn)) + +mbTemplate :: [Syntax c] -> (Maybe Id, [Syntax c]) +mbTemplate = \case + ( SymbolVal "template" : StringLike w : rest ) -> (Just (fromString w), rest) + other -> (Nothing, other) + +pattern IsSimpleTemplate :: forall {c} . [Syntax c] -> [Syntax c] +pattern IsSimpleTemplate xs <- [ListVal (SymbolVal "simple" : xs)] + +run :: FixmePerks m => [String] -> FixmeM m () +run what = do + + sc <- readConfig + + let s0 = fmap (parseTop . unwords) (splitForms what) + & rights + & mconcat + + runForms (sc <> s0) + + +runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m) + => [Syntax c] + -> FixmeM m () +runForms ss = for_ ss $ \s -> do + + macros <- asks fixmeEnvMacro >>= readTVarIO + + debug $ pretty s + + case s of + + (ListVal (SymbolVal name : rest)) | HM.member name macros -> do + let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ] + maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do + debug $ yellow "run macro" <+> pretty macro + runForms [macro] + + FixmeFiles xs -> do + t <- asks fixmeEnvFileMask + atomically (modifyTVar t (<> xs)) + + FixmePrefix tag -> do + t <- asks fixmeEnvTags + atomically (modifyTVar t (HS.insert tag)) + + FixmeGitScanFilterDays d -> do + t <- asks fixmeEnvGitScanDays + atomically (writeTVar t (Just d)) + + ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do + let co = Text.pack b & HS.singleton + t <- asks fixmeEnvFileComments + atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co)) + + ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do + t <- asks fixmeEnvDefComments + let co = fmap Text.pack xs & HS.fromList + atomically $ modifyTVar t (<> co) + + ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do + ta <- asks fixmeEnvAttribs + atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) + + ListVal [SymbolVal "fixme-git-dir", StringLike g] -> do + ta <- asks fixmeEnvGitDir + atomically $ writeTVar ta (Just g) + + ListVal [SymbolVal "fixme-state-path", StringLike g] -> do + p <- asks fixmeEnvDbPath + db <- asks fixmeEnvDb + atomically do + writeTVar p g + writeTVar db Nothing + + evolve + + ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do + t <- asks fixmeEnvCatContext + atomically $ writeTVar t (fromIntegral a, fromIntegral b) + + ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do + t <- asks fixmeEnvCatAction + let action = CatAction $ \dict lbs -> do + + let ccmd = case inject dict cmd0 of + (StringLike p : StringLikeList xs) -> Just (p, xs) + _ -> Nothing + + + debug $ pretty ccmd + + maybe1 ccmd none $ \(p, args) -> do + + let input = byteStringInput lbs + let cmd = setStdin input $ setStderr closed + $ proc p args + void $ runProcess cmd + + atomically $ writeTVar t action + + ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do + t <- asks fixmeEnvAttribValues + let name = fromString n + let vals = fmap fromString xs & HS.fromList + atomically $ modifyTVar t (HM.insertWith (<>) name vals) + + Init -> init + + ScanGitLocal args -> scanGitLocal args Nothing + + Update args -> scanGitLocal args Nothing + + ListVal (SymbolVal "list" : (Template n [])) -> do + debug $ "list" <+> pretty n + list_ n () + + ListVal (SymbolVal "list" : (Template n whatever)) -> do + debug $ "list" <+> pretty n + list_ n whatever + + ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do + catFixmeMetadata hash + + ListVal [SymbolVal "cat", FixmeHashLike hash] -> do + catFixme hash + + ListVal [SymbolVal "delete", FixmeHashLike hash] -> do + delete hash + + ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do + modify_ hash a b + + ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme (Just t) hash (fromString a) (fromString b) + + ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme Nothing hash (fromString a) (fromString b) + + ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do + deleteFixme hash + + ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do + deleteFixme hash + + ListVal [SymbolVal "added", FixmeHashLike _] -> do + -- we don't add fixmies at this stage + -- but in fixme-import + none + + ReadFixmeStdin -> readFixmeStdin + + ListVal [SymbolVal "print-env"] -> printEnv + + ListVal (SymbolVal "hello" : xs) -> do + notice $ "hello" <+> pretty xs + + ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do + debug $ yellow "define-macro" <+> pretty name <+> pretty macro + macros <- asks fixmeEnvMacro + atomically $ modifyTVar macros (HM.insert name (fixContext macro)) + + ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do + trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) + t <- asks fixmeEnvTemplates + atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) + + ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do + templates <- asks fixmeEnvTemplates + t <- readTVarIO templates + for_ (HM.lookup w t) $ \tpl -> do + atomically $ modifyTVar templates (HM.insert who tpl) + + -- FIXME: maybe-rename-fixme-update-action + ListVal (SymbolVal "fixme-update-action" : xs) -> do + debug $ "fixme-update-action" <+> pretty xs + env <- ask + t <- asks fixmeEnvUpdateActions + let repl syn = [ ( "$1", syn ) ] + let action = UpdateAction @c $ \syn -> do + liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) + + atomically $ modifyTVar t (<> [action]) + + ListVal (SymbolVal "update-action" : xs) -> do + debug $ "update-action" <+> pretty xs + env <- ask + t <- asks fixmeEnvReadLogActions + let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs)) + atomically $ modifyTVar t (<> [action]) + + ListVal [SymbolVal "import-git-logs", StringLike fn] -> do + warn $ red "import-git-logs" <+> pretty fn + scanGitLogLocal fn importFromLog + + ListVal [SymbolVal "import", StringLike fn] -> do + warn $ red "IMPORT" <+> pretty fn + sto <- compactStorageOpen readonly fn + importFromLog sto + compactStorageClose sto + + ListVal [SymbolVal "export", StringLike fn] -> do + warn $ red "EXPORT" <+> pretty fn + exportToLog fn + + ListVal [SymbolVal "git:list-refs"] -> do + refs <- listRefs False + for_ refs $ \(h,r) -> do + liftIO $ print $ pretty h <+> pretty r + + ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do + debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b + + temp <- liftIO $ emptyTempFile "." "merge-result" + sa <- compactStorageOpen @HbSync readonly o + sb <- compactStorageOpen @HbSync readonly b + r <- compactStorageOpen @HbSync mempty temp + + for_ [sa,sb] $ \sto -> do + ks <- keys sto + for_ ks $ \k -> runMaybeT do + v <- get sto k & MaybeT + put r k v + + compactStorageClose r + compactStorageClose sa + compactStorageClose sb + + mv temp target + + ListVal [SymbolVal "no-debug"] -> do + setLoggingOff @DEBUG + + ListVal [SymbolVal "silence"] -> do + silence + + ListVal [SymbolVal "builtin:run-stdin"] -> do + let ini = mempty :: [Text] + flip fix ini $ \next acc -> do + eof <- liftIO IO.isEOF + s <- if eof then pure "" else liftIO Text.getLine <&> Text.strip + if Text.null s then do + let code = parseTop (Text.unlines acc) & fromRight mempty + runForms code + unless eof do + next mempty + else do + next (acc <> [s]) + + ListVal [SymbolVal "builtin:evolve"] -> do + evolve + + ListVal [SymbolVal "builtin:list-commits"] -> do + co <- listCommits + liftIO $ print $ vcat (fmap (pretty . view _1) co) + + ListVal [SymbolVal "builtin:cleanup-state"] -> do + cleanupDatabase + + ListVal [SymbolVal "builtin:clean-stage"] -> do + cleanStage + + ListVal [SymbolVal "builtin:drop-stage"] -> do + cleanStage + + ListVal [SymbolVal "builtin:show-stage"] -> do + stage <- selectStage + liftIO $ print $ vcat (fmap pretty stage) + + ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do + sto <- compactStorageOpen @HbSync readonly fn + + ks <- keys sto + + entries <- mapM (get sto) ks + <&> catMaybes + <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + <&> rights + + liftIO $ print $ vcat (fmap pretty entries) + + compactStorageClose sto + + ListVal [SymbolVal "builtin:update-indexes"] -> do + updateIndexes + + ListVal [SymbolVal "builtin:scan-magic"] -> do + magic <- scanMagic + liftIO $ print $ pretty magic + + ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do + w <- selectFixmeHash x + liftIO $ print $ pretty w + + ListVal [SymbolVal "builtin:git:list-stage"] -> do + stage <- gitListStage + for_ stage $ \case + Left (fn,h) -> liftIO $ print $ "N" <+> pretty h <+> pretty fn + Right (fn,h) -> liftIO $ print $ "E" <+> pretty h <+> pretty fn + + ListVal (SymbolVal "builtin:git:extract-file-meta-data" : StringLikeList fs) -> do + fxm <- gitExtractFileMetaData fs <&> HM.toList + liftIO $ print $ vcat (fmap (pretty.snd) fxm) + + ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do + env <- ask + gitStage <- gitListStage + + let dry = or [ True | StringLike "dry" <- opts ] + let verbose = or [ True | StringLike "verbose" <- opts ] + + blobs <- for gitStage $ \case + Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn) + Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash)) + + let fns = fmap (view _1) blobs + + -- TODO: extract-metadata-from-git-blame + -- subj + + stageFile <- localConfigDir <&> ( "current-stage.log") + + fmeStage <- compactStorageOpen mempty stageFile + + for_ blobs $ \(fn, bhash, readBlob) -> do + nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer) + lbs <- readBlob + fxs <- scanBlob (Just fn) lbs + >>= \e -> do + for e $ \fx0 -> do + n <- atomically $ stateTVar nno (\m -> do + let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0 + (what, HM.insert (fixmeTitle fx0) (succ what) m) + ) + let ls = fixmePlain fx0 + meta <- getMetaDataFromGitBlame fn fx0 + let tit = fixmeTitle fx0 & coerce @_ @Text + + -- FIXME: fix-this-copypaste + let ks = [qc|{fn}#{tit}:{n}|] :: Text + let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal + let kh = HM.singleton "fixme-key" ksh + let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh + + pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta) + & set (field @"fixmePlain") ls + + & over (field @"fixmeAttr") + (HM.insert "blob" (fromString $ show $ pretty bhash)) + & over (field @"fixmeAttr") + (mappend (kh<>kv)) + + unless dry do + for_ fxs $ \fx -> void $ runMaybeT do + e <- getEpoch + let what = Added e fx + let k = mkKey (FromFixmeKey fx) + get fmeStage k >>= guard . isNothing + put fmeStage k (LBS.toStrict $ serialise what) + + when verbose do + liftIO $ print (pretty fx) + + when dry do + warn $ red "FUCKING DRY!" + + compactStorageClose fmeStage + + ListVal [SymbolVal "trace"] -> do + setLogging @TRACE (logPrefix "[trace] " . toStderr) + trace "trace on" + + ListVal [SymbolVal "no-trace"] -> do + trace "trace off" + setLoggingOff @TRACE + + ListVal [SymbolVal "debug"] -> do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " + + w -> err (pretty w) + + diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index 386cad6b..686d8b0e 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/fixme-new/lib/Fixme/Scan.hs @@ -1,5 +1,5 @@ {-# Language MultiWayIf #-} -module Fixme.Scan (scanBlob,scanMagic) where +module Fixme.Scan (scanBlob,scanMagic,updateScanMagic) where import Fixme.Prelude hiding (indent) import Fixme.Types @@ -57,16 +57,23 @@ scanMagic :: FixmePerks m => FixmeM m HashRef scanMagic = do env <- ask w <- atomically do - tagz <- fixmeEnvTags env & readTVar - co <- fixmeEnvDefComments env & readTVar + tagz <- fixmeEnvTags env & readTVar + co <- fixmeEnvDefComments env & readTVar fco <- fixmeEnvFileComments env & readTVar m <- fixmeEnvFileMask env & readTVar + e <- fixmeEnvFileExclude env & readTVar a <- fixmeEnvAttribs env & readTVar v <- fixmeEnvAttribValues env & readTVar - pure $ serialise (tagz, co, fco, m, a, v) + pure $ serialise (tagz, co, fco, m, e, a, v) pure $ HashRef $ hashObject w +updateScanMagic :: (FixmePerks m) => FixmeM m () +updateScanMagic = do + t <- asks fixmeEnvScanMagic + magic <- scanMagic + atomically $ writeTVar t (Just magic) + scanBlob :: forall m . FixmePerks m => Maybe FilePath -- ^ filename to detect type -> ByteString -- ^ content @@ -172,7 +179,7 @@ scanBlob fpath lbs = do FixmeHead lno _ tag title -> Fixme (FixmeTag tag) (FixmeTitle title) - Nothing + mempty Nothing (Just (FixmeOffset (fromIntegral lno))) Nothing diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 445f5369..5d2910d5 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -9,7 +9,6 @@ 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 @@ -51,24 +50,6 @@ 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" -} @@ -115,31 +96,13 @@ listCommits = do spec = sq <> delims " \t" - -listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)] -listRefs every = do +listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => Maybe GitHash -> m [(FilePath,GitHash)] +listBlobs mco = 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 + let what = maybe "HEAD" (show . pretty) mco - 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}|] + gitRunCommand [qc|git {gd} ls-tree -r -l -t {what}|] <&> fromRight mempty <&> fmap LBS8.words . LBS8.lines <&> mapMaybe @@ -166,142 +129,22 @@ filterBlobs xs = do pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) filterBlobs0 pat xs +listRelevantBlobs :: FixmePerks m + => FixmeM m [(FilePath, GitHash)] +listRelevantBlobs = do + commits <- listCommits + S.toList_ $ do + for_ commits $ \(co, _) -> do + found <- lift $ listBlobs (Just co) >>= filterBlobs + S.each found -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 +listFixmies :: FixmePerks m + => FixmeM m [Fixme] +listFixmies = do 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 + blobs <- lift listRelevantBlobs gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin) @@ -310,14 +153,7 @@ scanGitLocal args p = do 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 () - + for_ blobs $ \(fp,h) -> do liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin prefix <- liftIO (BS.hGetLine ssout) <&> BS.words @@ -328,110 +164,15 @@ scanGitLocal args p = do 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| + liftIO $ mapM_ (print . pretty) poor - 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 + _ -> pure () - 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) + pure mempty gitListStage :: (FixmePerks m) @@ -539,7 +280,7 @@ gitExtractFileMetaData fns = do rich0 <- S.toList_ $ do for_ co $ \(c, (t,n,m)) -> do let pat = [ (True, f) | f <- fns ] - blobz <- lift $ listBlobs c >>= filterBlobs0 pat + blobz <- lift $ listBlobs (Just c) >>= filterBlobs0 pat for_ blobz $ \(f,h) -> do let attr = HM.fromList [ ("commit", FixmeAttrVal (fromString $ show $ pretty c)) @@ -557,16 +298,6 @@ gitExtractFileMetaData fns = do 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) @@ -597,7 +328,7 @@ listCommitForIndex fn = do ) for_ s0 $ \(h, GitCommit w _) -> do - blobz <- listBlobs h <&> HS.fromList . fmap ( uncurry GitBlobInfo ) + blobz <- listBlobs (Just h) <&> HS.fromList . fmap ( uncurry GitBlobInfo ) fn (h, GitCommit w blobz) where @@ -609,11 +340,28 @@ gitCatBlob h = do (_,s,_) <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|] pure s + +startGitHash :: (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ()) +startGitHash = do + gd <- fixmeGetGitDirCLIOpt + let cmd = [qc|git {gd} hash-object --stdin-paths|] + debug $ pretty cmd + let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd + startProcess config + +gitHashPathStdin :: FixmePerks m => (Process Handle Handle e) -> FilePath -> FixmeM m (Maybe GitHash) +gitHashPathStdin prc file = do + let ssin = getStdin prc + let sout = getStdout prc + liftIO $ IO.hPutStrLn ssin file >> IO.hFlush ssin + liftIO (IO.hGetLine sout) <&> fromStringMay @GitHash + 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 + -- ssin <- getStdin config startProcess config diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 9bc8b96d..ead1514e 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -1,48 +1,42 @@ {-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} {-# 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 + , listFixme + , insertFixme + , insertFixmeExported + , modifyFixme + , insertScannedFile + , insertScanned + , selectIsAlreadyScannedFile + , selectIsAlreadyScanned + , listAllScanned + , selectFixmeKey + , getFixme + , insertTree + , FixmeExported(..) , HasPredicate(..) , SelectPredicate(..) + , LocalNonce(..) ) where -import Fixme.Prelude +import Fixme.Prelude hiding (key) import Fixme.Types import Fixme.Config +import HBS2.Base58 import HBS2.System.Dir -import Data.Config.Suckless +import Data.Config.Suckless hiding (key) 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.ByteString.Lazy qualified as LBS import Data.HashMap.Strict qualified as HM import Text.InterpolatedString.Perl6 (q,qc) import Data.Text qualified as Text @@ -57,6 +51,8 @@ import Control.Monad.Trans.Maybe import Data.Coerce import Data.Fixed import Data.Word (Word64) +import System.Directory (getModificationTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import System.TimeIt -- TODO: runPipe-omitted @@ -68,6 +64,15 @@ import System.TimeIt -- на лету бесплатно +newtype SomeHash h = SomeHash { fromSomeHash :: h } + deriving newtype (IsString) + +instance Pretty (AsBase58 h) => ToField (SomeHash h) where + toField (SomeHash h) = toField ( show $ pretty (AsBase58 h)) + +instance IsString (SomeHash h) => FromField (SomeHash h) where + fromField = fmap fromString . fromField @String + pattern Operand :: forall {c} . Text -> Syntax c pattern Operand what <- (operand -> Just what) @@ -123,235 +128,27 @@ withState what = do createTables :: FixmePerks m => DBPipeM m () createTables = do - -- тут все таблицы будут называться с префиксом - -- fixme, что бы может быть можно было встроить - -- в другую бд, если вдруг понадобится + -- ddl [qc| create table if not exists tree + -- ( hash text not null + -- , nonce text not null + -- , primary key (hash,nonce) + -- ) + -- |] - 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 scanned + ( hash text not null primary key ) |] - 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 object + ( o text not null + , w integer not null + , k text not null + , v blob not null + , nonce text null + , primary key (o,k) ) |] - 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 @@ -389,18 +186,18 @@ instance IsContext c => HasPredicate [Syntax c] where go = \case ( SymbolVal "!" : rest ) -> do - mklist [mksym "not", unlist (go rest)] + mkList [mkSym "not", unlist (go rest)] ( Operand a : SymbolVal "~" : Operand b : rest ) -> do - go (mklist [mksym "like", mkstr a, mkstr b] : rest) + go (mkList [mkSym "like", mkStr a, mkStr b] : rest) ( w : SymbolVal "&&" : rest ) -> do - mklist [mksym "and", unlist w, unlist (go rest)] + mkList [mkSym "and", unlist w, unlist (go rest)] ( w : SymbolVal "||" : rest ) -> do - mklist [mksym "or", unlist w, unlist (go rest)] + mkList [mkSym "or", unlist w, unlist (go rest)] - w -> mklist w + w -> mkList w unlist = \case ListVal [x] -> x @@ -410,50 +207,6 @@ instance IsContext c => HasPredicate [Syntax c] where {- 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 @@ -469,16 +222,12 @@ genPredQ tbl what = go what All -> ("true", mempty) FixmeHashExactly x -> - ([qc|({tbl}.fixme = ?)|], [Bound x]) - - AttrLike "fixme-hash" val -> do - let binds = [Bound (val <> "%")] - ([qc|({tbl}.fixme like ?)|], binds) + ([qc|(o.o = ?)|], [Bound x]) AttrLike name val -> do let x = val <> "%" let binds = [Bound x] - ([qc|(json_extract({tbl}.json, '$."{name}"') like ?)|], binds) + ([qc|(json_extract({tbl}.blob, '$."{name}"') like ?)|], binds) Not a -> do let (sql, bound) = go a @@ -494,214 +243,238 @@ genPredQ tbl what = go what let bsql = go b ([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql) - Ignored -> ("false", mempty) + Ignored -> ("true", 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|] + update_ [qc|delete from object|] + update_ [qc|delete from scanned|] + +scannedKey :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> m HashRef +scannedKey fme = do + magic <- asks fixmeEnvScanMagic >>= readTVarIO + let file = fixmeAttr fme & HM.lookup "file" + let w = fixmeTs fme + pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef + +scannedKeyForFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath-> m HashRef +scannedKeyForFile file = do + dir <- fixmeWorkDir + magic <- asks fixmeEnvScanMagic >>= readTVarIO + let fn = dir file + w <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds + pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef + +selectIsAlreadyScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> m Bool +selectIsAlreadyScannedFile file = do + k <- scannedKeyForFile file + selectIsAlreadyScanned k + +selectIsAlreadyScanned :: (FixmePerks m, MonadReader FixmeEnv m) => HashRef -> m Bool +selectIsAlreadyScanned k = withState do + what <- select @(Only Int) [qc|select 1 from scanned where hash = ? limit 1|] (Only k) + pure $ not $ List.null what -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) +insertTree :: FixmePerks m => HashRef -> FixmeKey -> FixmeAttrName -> DBPipeM m () +insertTree h o k = do + insert [qc| insert into tree (hash,o,k) + values (?,?,?) + on conflict (hash,o,k) do nothing + |] (h,o,k) + +listAllScanned :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef) +listAllScanned = withState do + select_ [qc|select hash from scanned|] <&> HS.fromList . fmap ( fromSomeHash . fromOnly ) + +insertScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m () +insertScannedFile file = do + k <- lift $ scannedKeyForFile file + insertScanned k + +insertScanned:: (FixmePerks m) => HashRef -> DBPipeM m () +insertScanned k = do + insert [qc| insert into scanned (hash) + values(?) + on conflict (hash) do nothing|] + (Only k) + +selectFixmeKey :: (FixmePerks m, MonadReader FixmeEnv m) => Text -> m (Maybe FixmeKey) +selectFixmeKey s = do + withState do + select @(Only FixmeKey) [qc|select distinct(o) from object where o like ? order by w desc|] (Only (s<>"%")) + <&> fmap fromOnly + <&> headMay -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) +listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q) + => q + -> m [Fixme] +listFixme expr = do + let (w,bound) = genPredQ "s1" (predicate expr) -type StageModRow = (HashRef,Word64,Text,Text) + let present = [qc|and coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String -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 + let sql = [qc| + with s1 as ( + select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as blob) as blob + from object o + group by o.o + ) + select s1.blob from s1 + where + {w} + {present} + order by + json_extract(s1.blob, '$.commit-time') asc nulls last, + json_extract(s1.blob, '$.w') asc nulls last |] - updateFixmeJson - -- FIXME: delete-table-grows - -- надо добавлять статус в fixmedeleted - -- только если он отличается от последнего - -- известного статуса - update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|] + + debug $ pretty sql + + withState $ select @(Only LBS.ByteString) sql bound + <&> fmap (Aeson.decode @Fixme . fromOnly) + <&> catMaybes + +getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme) +getFixme key = do + + let sql = [qc| + select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as blob) as blob + from object o + where o.o = ? + group by o.o + limit 1 + |] + + runMaybeT do + + lift (withState $ select @(Only LBS.ByteString) sql (Only key)) + <&> fmap (Aeson.decode @Fixme . fromOnly) + <&> catMaybes + <&> headMay + >>= toMPlus +modifyFixme :: (FixmePerks m) + => FixmeKey + -> [(FixmeAttrName, FixmeAttrVal)] + -> FixmeM m () +modifyFixme o a' = do + FixmeEnv{..} <- ask -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)) + attrNames <- readTVarIO fixmeEnvAttribs + values <- readTVarIO fixmeEnvAttribValues + + now <- liftIO getPOSIXTime <&> fromIntegral . round + + let a = [ (k,v) | (k,v) <- a' + , k `HS.member` attrNames + , not (HM.member k values) || v `HS.member` fromMaybe mempty (HM.lookup k values) + ] + + let w = mempty { fixmeAttr = HM.fromList a, fixmeKey = o, fixmeTs = Just now } + + withState $ insertFixme w + +insertFixme :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> DBPipeM m () +insertFixme fme = do + + void $ runMaybeT do + + let o = fixmeKey fme + w <- fixmeTs fme & toMPlus + let attrs = fixmeAttr fme + let txt = fixmePlain fme & Text.unlines . fmap coerce + + let sql = [qc| + insert into object (o, w, k, v) + values (?, ?, ?, ?) + on conflict (o, k) + do update set + v = case + when excluded.w > object.w and (excluded.v <> object.v) then excluded.v + else object.v + end, + w = case + when excluded.w > object.w and (excluded.v <> object.v) then excluded.w + else object.w + end, + nonce = case when excluded.w > object.w and (excluded.v <> object.v) then null + else object.nonce + end + |] + + for_ (fixmeStart fme) $ \s -> do + lift $ insert sql (o,w,"fixme-start",s) + + for_ (fixmeEnd fme) $ \s -> do + lift $ insert sql (o,w,"fixme-end",s) + + for_ (HM.toList attrs) $ \(k,v) -> do + lift $ insert sql (o,w,k,v) + + lift $ insert sql (o,w,"fixme-text",txt) -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 +data FixmeExported = + FixmeExported + { exportedKey :: FixmeKey + , exportedWeight :: Word64 + , exportedName :: FixmeAttrName + , exportedValue :: FixmeAttrVal + } + deriving stock Generic -selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m) - => m [HashRef] -selectProcessed = withState do - select_ [qc|select hash from fixmeprocessed|] - <&> fmap fromOnly +instance FromRow FixmeExported +instance ToRow FixmeExported +instance Serialise FixmeExported + +class LocalNonce a where + localNonce :: a -> HashRef + +instance LocalNonce FixmeExported where + localNonce FixmeExported{..} = + HashRef $ hashObject @HbSync + $ serialise (exportedKey,exportedName,exportedValue,exportedWeight) + +instance LocalNonce (HashRef, FixmeExported) where + localNonce (h, e) = HashRef $ hashObject @HbSync + $ serialise (h, localNonce e) + +data WithNonce a = WithNonce HashRef a + +instance ToRow (WithNonce FixmeExported) where + toRow (WithNonce nonce f@FixmeExported{..}) = toRow (exportedKey, exportedWeight, exportedName, exportedValue, nonce) + +insertFixmeExported :: FixmePerks m => HashRef -> FixmeExported -> DBPipeM m () +insertFixmeExported h item = do + + let sql = [qc| + + insert into object (o, w, k, v, nonce) + values (?, ?, ?, ?, ?) + on conflict (o, k) + do update set + v = case + when excluded.w > object.w then excluded.v + else object.v + end, + w = case + when excluded.w > object.w then excluded.w + else object.w + end, + nonce = case + when excluded.w > object.w then excluded.nonce + else object.nonce + end + |] + + insert sql (WithNonce h item) + insertScanned h diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 74170805..5caaabb6 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Fixme.Types ( module Fixme.Types + , module Exported ) where import Fixme.Prelude hiding (align) @@ -10,11 +12,25 @@ import HBS2.Base58 import DBPipe.SQLite hiding (field) import HBS2.Git.Local +import HBS2.OrDie +import HBS2.Storage as Exported +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client as Exported hiding (encode,decode) +import HBS2.Peer.RPC.Client.Unix as Exported hiding (encode,decode) +import HBS2.Peer.RPC.API.Peer as Exported +import HBS2.Peer.RPC.API.RefChan as Exported +import HBS2.Peer.RPC.API.Storage as Exported +import HBS2.Peer.RPC.Client.StorageClient as Exported + + import Data.Config.Suckless import Prettyprinter.Render.Terminal import Control.Applicative -import Data.Aeson +import Data.Aeson as Aeson +import Data.Aeson.KeyMap as Aeson hiding (null) +import Data.Aeson.Key qualified as Aeson +import Data.Aeson.Types as Aeson import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as LBS @@ -33,6 +49,17 @@ import Text.InterpolatedString.Perl6 (qc) import Data.Generics.Product.Fields (field) import Lens.Micro.Platform + +data MyPeerClientEndpoints = + MyPeerClientEndpoints + { _peerSocket :: FilePath + , _peerPeerAPI :: ServiceCaller PeerAPI UNIX + , _peerRefChanAPI :: ServiceCaller RefChanAPI UNIX + , _peerStorageAPI :: ServiceCaller StorageAPI UNIX + } + +makeLenses 'MyPeerClientEndpoints + -- FIXME: move-to-suckless-conf deriving stock instance Ord (Syntax C) @@ -43,26 +70,12 @@ 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 String where + mkId s = fromString s + instance MkId FixmeAttrName where mkId (k :: FixmeAttrName) = Id ("$" <> coerce k) @@ -72,45 +85,6 @@ instance MkId (Text,Int) where 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 @@ -126,15 +100,15 @@ tsFromFromSyn = \case _ -> Nothing newtype FixmeTag = FixmeTag { fromFixmeTag :: Text } - deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField) + deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON) deriving stock (Data,Generic) newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text } - deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable) + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable,FromJSON,ToJSON) deriving stock (Data,Generic) newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text } - deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField) + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON) deriving stock (Data,Generic) @@ -150,16 +124,16 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text } deriving stock (Data,Generic) newtype FixmeTimestamp = FixmeTimestamp Word64 - deriving newtype (Eq,Ord,Show,Num,ToField,FromField) + deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON) deriving stock (Data,Generic) newtype FixmeKey = FixmeKey Text - deriving newtype (Eq,Ord,Show,ToField,FromField) + deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty,FromJSON,ToJSON,Semigroup,Monoid) deriving stock (Data,Generic) newtype FixmeOffset = FixmeOffset Word32 - deriving newtype (Eq,Ord,Show,Num,ToField,FromField) + deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON) deriving newtype (Integral,Real,Enum) deriving stock (Data,Generic) @@ -168,7 +142,7 @@ data Fixme = Fixme { fixmeTag :: FixmeTag , fixmeTitle :: FixmeTitle - , fixmeKey :: Maybe FixmeKey + , fixmeKey :: FixmeKey , fixmeTs :: Maybe FixmeTimestamp , fixmeStart :: Maybe FixmeOffset , fixmeEnd :: Maybe FixmeOffset @@ -178,7 +152,7 @@ data Fixme = deriving stock (Ord,Eq,Show,Data,Generic) instance Monoid Fixme where - mempty = Fixme mempty mempty Nothing Nothing Nothing Nothing mempty mempty + mempty = Fixme mempty mempty mempty Nothing Nothing Nothing mempty mempty instance Semigroup Fixme where (<>) a b = b { fixmeTs = fixmeTs b <|> fixmeTs a @@ -190,13 +164,68 @@ instance Semigroup Fixme where , fixmeAttr = fixmeAttr a <> fixmeAttr b } +fixmeGet :: FixmeAttrName -> Fixme -> Maybe FixmeAttrVal +fixmeGet name Fixme{..} = HM.lookup name fixmeAttr + +fixmeSet :: FixmeAttrName -> FixmeAttrVal -> Fixme -> Fixme +fixmeSet name val fx = fx { fixmeAttr = HM.insert name val (fixmeAttr fx) } + +instance FromJSON FixmeOffset where + parseJSON = \case + Number x -> pure (FixmeOffset (ceiling x)) + + String s -> do + n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s)) + pure $ FixmeOffset n + + _ -> fail "invalid FixmeOffset value" + + +instance FromJSON FixmeTimestamp where + parseJSON = \case + Number x -> pure (FixmeTimestamp (ceiling x)) + + String s -> do + n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s)) + pure $ FixmeTimestamp n + + _ -> fail "invalid FixmeTimestamp value" + + +instance FromJSON Fixme where + parseJSON = withObject "Fixme" $ \o -> do + fixmeKey <- o .: "fixme-key" + fixmeTag <- o .: "fixme-tag" + fixmeTitle <- o .: "fixme-title" + fixmeStart <- o .:? "fixme-start" + fixmeEnd <- o .:? "fixme-end" + fixmeTs <- o .:? "fixme-timestamp" + + fixmePlainTxt <- o .:? "fixme-text" <&> fromMaybe mempty + let fixmePlain = fmap FixmePlainLine (Text.lines fixmePlainTxt) + + let wtf = [ unpackItem k v + | (k,v) <- Aeson.toList o + , k /= "fixme-text" + ] & catMaybes + + let fixmeAttr = HM.fromList wtf + + return Fixme{..} + + where + unpackItem k v = do + (FixmeAttrName (Aeson.toText k),) <$> + case v of + String x -> pure (FixmeAttrVal x) + _ -> Nothing + 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 ) @@ -235,13 +264,31 @@ instance MkKey (FromFixmeKey Fixme) where maybe k2 (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr) where k2 = mappend "A" $ serialise fx & LBS.toStrict +instance IsContext c => MkStr c GitHash where + mkStr ha = mkStr (show $ pretty ha) + +instance IsContext c => MkStr c GitRef where + mkStr ha = mkStr (show $ pretty ha) + +instance IsContext c => MkStr c HashRef where + mkStr ha = mkStr (show $ pretty ha) + +instance IsContext c => MkStr c FixmeAttrVal where + mkStr v = mkStr (coerce @_ @Text v) + +instance IsContext c => MkStr c (AsBase58 ByteString) where + mkStr v = mkStr (show $ pretty v) + +instance IsContext c => MkStr c FixmeAttrName where + mkStr v = mkStr (coerce @_ @Text v) + 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 ] + 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) ] + pretty $ mkList @C [ mkSym "added", mkStr (AsBase58 $ mkKey e) ] instance Serialise CompactAction @@ -280,6 +327,11 @@ instance Monoid FixmeOpts where instance Semigroup FixmeOpts where (<>) _ b = FixmeOpts (fixmeOptNoEvolve b) +data PeerNotConnected = PeerNotConnected + deriving (Show,Typeable) + +instance Exception PeerNotConnected + data FixmeEnv = FixmeEnv { fixmeLock :: MVar () @@ -288,18 +340,24 @@ data FixmeEnv = , fixmeEnvDb :: TVar (Maybe DBPipeEnv) , fixmeEnvGitDir :: TVar (Maybe FilePath) , fixmeEnvFileMask :: TVar [FilePattern] + , fixmeEnvFileExclude :: 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) + , fixmeEnvScanMagic :: TVar (Maybe HashRef) , fixmeEnvUpdateActions :: TVar [UpdateAction] , fixmeEnvReadLogActions :: TVar [ReadLogAction] , fixmeEnvCatAction :: TVar CatAction , fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate) , fixmeEnvMacro :: TVar (HashMap Id (Syntax C)) , fixmeEnvCatContext :: TVar (Int,Int) + , fixmeEnvMyEndpoints :: TVar (Maybe MyPeerClientEndpoints) + , fixmeEnvRefChan :: TVar (Maybe (PubKey 'Sign 'HBS2Basic)) + , fixmeEnvAuthor :: TVar (Maybe (PubKey 'Sign 'HBS2Basic)) + , fixmeEnvReader :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic)) } @@ -327,6 +385,12 @@ fixmeGetGitDirCLIOpt = do <&> fmap (\d -> [qc|--git-dir {d}|]) <&> fromMaybe "" +builtinAttribs :: HashSet FixmeAttrName +builtinAttribs = HS.singleton "deleted" + +builtinAttribVals :: HashMap FixmeAttrName (HashSet FixmeAttrVal) +builtinAttribVals = HM.fromList [("deleted", HS.fromList ["true","false"])] + newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } deriving newtype ( Applicative , Functor @@ -337,7 +401,7 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } ) -fixmeEnvBare :: FixmePerks m => m FixmeEnv +fixmeEnvBare :: forall m . FixmePerks m => m FixmeEnv fixmeEnvBare = FixmeEnv <$> newMVar () @@ -348,23 +412,26 @@ fixmeEnvBare = <*> newTVarIO mempty <*> newTVarIO mempty <*> newTVarIO mempty - <*> newTVarIO mempty + <*> newTVarIO builtinAttribs + <*> newTVarIO builtinAttribVals <*> newTVarIO mempty <*> newTVarIO defCommentMap <*> newTVarIO Nothing + <*> newTVarIO mzero <*> newTVarIO mempty <*> newTVarIO mempty <*> newTVarIO (CatAction $ \_ _ -> pure ()) <*> newTVarIO mempty <*> newTVarIO mempty <*> newTVarIO (1,3) + <*> newTVarIO mzero + <*> newTVarIO mzero + <*> newTVarIO mzero + <*> newTVarIO mzero 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 @@ -376,6 +443,29 @@ instance Serialise FixmeKey instance Serialise Fixme +instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI PeerAPI UNIX m where + getClientAPI = getApiOrThrow peerPeerAPI + +instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI RefChanAPI UNIX m where + getClientAPI = getApiOrThrow peerRefChanAPI + +instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI StorageAPI UNIX m where + getClientAPI = getApiOrThrow peerStorageAPI + + +instance (FixmePerks m, MonadReader FixmeEnv m) => HasStorage m where + getStorage = do + api <- getClientAPI @StorageAPI @UNIX + pure $ AnyStorage (StorageClient api) + +getApiOrThrow :: (MonadReader FixmeEnv m, MonadIO m) + => Getting b MyPeerClientEndpoints b -> m b +getApiOrThrow getter = + asks fixmeEnvMyEndpoints + >>= readTVarIO + >>= orThrow PeerNotConnected + <&> view getter + instance ToField GitHash where toField h = toField (show $ pretty h) @@ -614,7 +704,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of (_,_) -> b fixmeDerivedFields :: Fixme -> Fixme -fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc +fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc where email = HM.lookup "commiter-email" (fixmeAttr fx) & maybe mempty (\x -> " <" <> x <> ">") @@ -624,10 +714,19 @@ fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx)) } + key = HM.singleton "fixme-key" (FixmeAttrVal $ coerce $ (fixmeKey fx)) + + fxKey = mempty { fixmeAttr = key } + lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno } + fxE = join $ for (fixmeStart fx) $ \n -> do + Just $ FixmeOffset $ fromIntegral $ fromIntegral n + length (fixmePlain fx) + + fxEnd = mempty { fixmeEnd = fxE } + fxCo = maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter diff --git a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs index 43a92c3b..68846f19 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs @@ -1,5 +1,7 @@ module HBS2.CLI.Run.KeyMan - (keymanEntries) where + ( module HBS2.CLI.Run.KeyMan + , keymanNewCredentials + ) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs index 878ba42e..16cddd63 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -1,4 +1,7 @@ -module HBS2.CLI.Run.RefChan where +module HBS2.CLI.Run.RefChan + ( module HBS2.CLI.Run.RefChan + , keymanNewCredentials + ) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 2884ad2e..e2135c9d 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -264,7 +264,6 @@ instance Asymm 'HBS2Basic where instance Hashed HbSync Sign.PublicKey where hashObject pk = hashObject (Crypto.encode pk) - pattern SignPubKeyLike :: forall {c} . PubKey 'Sign 'HBS2Basic -> Syntax c pattern SignPubKeyLike x <- ( \case @@ -272,3 +271,10 @@ pattern SignPubKeyLike x <- ( _ -> Nothing -> Just x ) +pattern EncryptPubKeyLike :: forall {c} . PubKey 'Encrypt 'HBS2Basic -> Syntax c +pattern EncryptPubKeyLike x <- ( + \case + StringLike s -> fromStringMay s + _ -> Nothing + -> Just x ) + diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index c9bc2c58..25e44bd5 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -57,6 +57,7 @@ touch what = do pwd :: MonadIO m => m FilePath pwd = liftIO D.getCurrentDirectory + doesPathExist :: MonadIO m => FilePath -> m Bool doesPathExist = liftIO . D.doesPathExist diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs index 5fb1eb81..d8081eb5 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs +++ b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs @@ -70,6 +70,22 @@ runKeymanClient action = do void $ ContT $ bracket (async (runPipe db)) cancel lift $ withDB db (fromKeyManClient action) +listCredentials :: forall m . + ( MonadIO m + , SerialisedCredentials 'HBS2Basic + ) + => KeyManClient m [PubKey 'Sign 'HBS2Basic] +listCredentials = KeyManClient do + select_ [qc| + select f.key + from keytype t + join keyfile f on t.key = f.key + left join keyweight w on w.key = f.key + where t.type = 'sign' + order by w.weight desc nulls last + limit 100 |] + <&> mapMaybe ( fromStringMay . fromOnly ) + loadCredentials :: forall a m . ( MonadIO m , SomePubKeyPerks a diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index f5e8106c..7b12dfd4 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -26,6 +26,7 @@ import HBS2.Net.Messaging.Encrypted.ByPass import HBS2.Net.PeerLocator import HBS2.Peer.Proto import HBS2.Peer.Proto.RefChan qualified as R +import HBS2.Peer.Proto.RefChan.Adapter import HBS2.Net.Proto.Notify import HBS2.OrDie import HBS2.Storage.Simple @@ -864,7 +865,7 @@ runPeer opts = Exception.handle (\e -> myException e pause @'Seconds 600 liftIO $ Cache.purgeExpired nbcache - rce <- refChanWorkerEnv conf penv denv + rce <- refChanWorkerEnv conf penv denv refChanNotifySource let refChanAdapter = RefChanAdapter @@ -872,14 +873,21 @@ runPeer opts = Exception.handle (\e -> myException e , refChanSubscribed = isPolledRef @e brains "refchan" , refChanWriteTran = refChanWriteTranFn rce , refChanValidatePropose = refChanValidateTranFn @e rce - + -- TODO: inject-refchanUpdateNotifyCallback , refChanNotifyRely = \r u -> do trace "refChanNotifyRely!" refChanNotifyRelyFn @e rce r u case u of - R.Notify rr s -> do - emitNotify refChanNotifySource (RefChanNotifyKey r, RefChanNotifyData rr s) + R.Notify rr x -> do + emitNotify refChanNotifySource (RefChanNotifyKey r, RefChanNotifyData rr x) _ -> pure () + + -- , refChanEmitRefChanUpdated = \rchan val -> do + -- emitNotify refChanNotifySource (RefChanNotifyKey rchan, RefChanUpdated rchan val) + + -- , refChanEmitRefChanHeadUpdated = \rchan old val -> do + -- emitNotify refChanNotifySource (RefChanNotifyKey rchan, RefChanHeadUpdated rchan old val) + -- pure () } rcw <- async $ liftIO $ runRefChanRelyWorker rce refChanAdapter diff --git a/hbs2-peer/app/RefChan.hs b/hbs2-peer/app/RefChan.hs index d1b134f5..09cf18d9 100644 --- a/hbs2-peer/app/RefChan.hs +++ b/hbs2-peer/app/RefChan.hs @@ -29,12 +29,15 @@ import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.Unix import HBS2.Peer.Proto.Peer import HBS2.Peer.Proto.RefChan +import HBS2.Peer.Proto.RefChan.Adapter +import HBS2.Net.Proto.Notify (SomeNotifySource(..)) +import HBS2.Peer.Notify import HBS2.Net.Proto.Sessions import HBS2.Storage import PeerTypes hiding (downloads) import PeerConfig -import BlockDownload +import BlockDownload() import Brains import Control.Monad.Trans.Cont @@ -44,6 +47,7 @@ import Control.Exception () import Control.Monad.Except () import Control.Monad.Reader import Control.Monad.Trans.Maybe +import Data.Coerce import Data.Cache (Cache) import Data.Cache qualified as Cache import Data.HashMap.Strict (HashMap) @@ -87,6 +91,7 @@ data RefChanWorkerEnv e = { _refChanWorkerConf :: PeerConfig , _refChanPeerEnv :: PeerEnv e , _refChanWorkerEnvDEnv :: DownloadEnv e + , _refChanNotifySource :: SomeNotifySource (RefChanEvents e) , _refChanWorkerEnvHeadQ :: TQueue (RefChanId e, RefChanHeadBlockTran e) , _refChanWorkerEnvDownload :: TVar (HashMap HashRef (RefChanId e, (TimeSpec, OnDownloadComplete))) , _refChanWorkerEnvNotify :: TVar (HashMap (RefChanId e) ()) @@ -108,18 +113,20 @@ refChanWorkerEnv :: forall m e . (MonadIO m, ForRefChans e) => PeerConfig -> PeerEnv e -> DownloadEnv e + -> SomeNotifySource (RefChanEvents e) -> m (RefChanWorkerEnv e) -refChanWorkerEnv conf pe de = liftIO $ RefChanWorkerEnv @e conf pe de - <$> newTQueueIO - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTQueueIO - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTQueueIO - <*> Cache.newCache (Just defRequestLimit) - <*> Cache.newCache (Just defRequestLimit) +refChanWorkerEnv conf pe de nsource = + liftIO $ RefChanWorkerEnv @e conf pe de nsource + <$> newTQueueIO + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTQueueIO + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTQueueIO + <*> Cache.newCache (Just defRequestLimit) + <*> Cache.newCache (Just defRequestLimit) refChanOnHeadFn :: forall e m . (ForRefChans e, MonadIO m) => RefChanWorkerEnv e -> RefChanId e -> RefChanHeadBlockTran e -> m () refChanOnHeadFn env chan tran = do @@ -531,7 +538,7 @@ refChanWorker :: forall e s m . ( MonadIO m -> SomeBrains e -> m () -refChanWorker env brains = do +refChanWorker env@RefChanWorkerEnv{..} brains = do penv <- ask @@ -559,7 +566,7 @@ refChanWorker env brains = do polls <- ContT $ withAsync (refChanPoll penv) - wtrans <- ContT $ withAsync (liftIO $ withPeerM penv $ refChanWriter penv) + wtrans <- ContT $ withAsync (liftIO $ withPeerM penv $ refChanWriter) cleanup1 <- ContT $ withAsync (liftIO (cleanupRounds penv)) @@ -633,8 +640,7 @@ refChanWorker env brains = do debug $ "CLEANUP ROUND" <+> pretty x - - refChanWriter penv = do + refChanWriter = do sto <- getStorage forever do pause @'Seconds 1 @@ -665,13 +671,17 @@ refChanWorker env brains = do -- FIXME: might-be-problems-on-large-logs let hashesNew = HashSet.fromList (hashes <> new) & HashSet.toList - -- -- FIXME: remove-chunk-num-hardcode + -- FIXME: remove-chunk-num-hardcode + -- $class: hardcode let pt = toPTree (MaxSize 256) (MaxNum 256) hashesNew nref <- makeMerkle 0 pt $ \(_,_,bss) -> void $ liftIO $ putBlock sto bss - liftIO $ updateRef sto c nref - debug $ "REFCHANLOG UPDATED:" <+> pretty c <+> pretty nref + -- TODO: ASAP-notify-on-refchan-update + -- $workflow: wip + + updateRef sto c nref + notifyOnRefChanUpdated env c nref refChanPoll penv = withPeerM penv do @@ -724,8 +734,8 @@ refChanWorker env brains = do let what = unboxSignedBox @(RefChanHeadBlock e) @s lbs notify <- atomically $ do - no <- readTVar (_refChanWorkerEnvNotify env) <&> HashMap.member chan - modifyTVar (_refChanWorkerEnvNotify env) (HashMap.delete chan) + no <- readTVar _refChanWorkerEnvNotify <&> HashMap.member chan + modifyTVar _refChanWorkerEnvNotify (HashMap.delete chan) pure no case what of @@ -985,14 +995,34 @@ logMergeProcess penv env q = withPeerM penv do unless (HashSet.null merged) do + -- FIXME: sub-optimal-partition + -- убрать этот хардкод размеров + -- он приводит к излишне мелким блокам let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList merged) liftIO do nref <- makeMerkle 0 pt $ \(_,_,bss) -> do void $ putBlock sto bss - debug $ "NEW REFCHAN" <+> pretty chanKey <+> pretty nref - + -- TODO: ASAP-emit-refchan-updated-notify + -- $workflow: wip updateRef sto chanKey nref + notifyOnRefChanUpdated env chanKey nref +notifyOnRefChanUpdated :: forall e s m . ( ForRefChans e + , s ~ Encryption e + , MonadUnliftIO m + ) + => RefChanWorkerEnv e + -> RefChanLogKey s + -> Hash HbSync + -> m () + +notifyOnRefChanUpdated RefChanWorkerEnv{..} c nref = do + emitNotify _refChanNotifySource notification + debug $ "REFCHAN UPDATED:" <+> pretty c <+> pretty nref + where + notification = + (RefChanNotifyKey (coerce c), RefChanUpdated (coerce c) (HashRef nref)) + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 80ad71e6..01d83c2c 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -158,6 +158,7 @@ library HBS2.Peer.Proto.RefChan.RefChanHead HBS2.Peer.Proto.RefChan.RefChanNotify HBS2.Peer.Proto.RefChan.RefChanUpdate + HBS2.Peer.Proto.RefChan.Adapter HBS2.Peer.Proto.AnyRef HBS2.Peer.Proto.LWWRef HBS2.Peer.Proto.LWWRef.Internal diff --git a/hbs2-peer/lib/HBS2/Peer/Notify.hs b/hbs2-peer/lib/HBS2/Peer/Notify.hs index a73cffcf..bb9e83ca 100644 --- a/hbs2-peer/lib/HBS2/Peer/Notify.hs +++ b/hbs2-peer/lib/HBS2/Peer/Notify.hs @@ -29,9 +29,9 @@ import Codec.Serialise import Data.ByteString.Lazy (ByteString) import Data.ByteString qualified as BS - -data RefChanEvents e = - RefChanOnNotify +-- TODO: rename-to-RefChanEvents +-- $workflow: wip +data RefChanEvents e = RefChanEvents instance HasProtocol UNIX (NotifyProto (RefChanEvents L4Proto) UNIX) where type instance ProtocolId (NotifyProto (RefChanEvents L4Proto) UNIX) = 0x20e14bfa0ca1db8e @@ -49,7 +49,13 @@ deriving newtype instance ForRefChans e => Hashable (NotifyKey (RefChanEvents e) deriving newtype instance ForRefChans e => Eq (NotifyKey (RefChanEvents e)) data instance NotifyData (RefChanEvents e) = - RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString (Encryption e)) + RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString (Encryption e)) + -- TODO: ASAP-RefChanUpdatedEvent + -- $workflow: wip + | RefChanUpdated (RefChanId e) HashRef + -- TODO: ASAP-RefChanHeadUpdatedEvent + -- $workflow: wip + | RefChanHeadUpdated (RefChanId e) (Maybe HashRef) HashRef deriving Generic instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e)) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Adapter.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Adapter.hs new file mode 100644 index 00000000..6773a143 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Adapter.hs @@ -0,0 +1,18 @@ +module HBS2.Peer.Proto.RefChan.Adapter where + +import HBS2.Peer.Proto.RefChan.Types +import HBS2.Net.Proto.Notify +-- import HBS2.Peer.Notify +import HBS2.Data.Types.Refs + +data RefChanAdapter e m = + RefChanAdapter + { refChanOnHead :: RefChanId e -> RefChanHeadBlockTran e -> m () + , refChanSubscribed :: RefChanId e -> m Bool + , refChanWriteTran :: HashRef -> m () + , refChanValidatePropose :: RefChanId e -> HashRef -> m Bool + , refChanNotifyRely :: RefChanId e -> RefChanNotify e -> m () + -- , refChanNotifySink :: SomeNotifySource (RefChanEvents L4Proto) + } + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs index 5181f0a4..a320de52 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs @@ -8,6 +8,7 @@ import HBS2.Net.Auth.Credentials import HBS2.Base58 import HBS2.Peer.Proto.Peer import HBS2.Peer.Proto.BlockAnnounce +import HBS2.Peer.Proto.RefChan.Adapter import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Storage diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs index 97a00541..cc33f3cb 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs @@ -9,6 +9,7 @@ import HBS2.Net.Proto import HBS2.Net.Auth.Credentials import HBS2.Events import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.RefChan.Adapter import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs index d949074c..2801b941 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs @@ -14,6 +14,7 @@ import HBS2.Net.Auth.Credentials import HBS2.Base58 import HBS2.Events import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.RefChan.Adapter import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index 42dbcaaa..a0045ea1 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs @@ -12,7 +12,6 @@ module HBS2.Peer.Proto.RefChan.Types import HBS2.Prelude.Plated import HBS2.Hash import HBS2.Data.Detect -import HBS2.Clock import HBS2.Net.Proto import HBS2.Net.Auth.Credentials import HBS2.Base58 @@ -37,12 +36,10 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet import Data.Maybe -import Data.Either import Data.Text qualified as Text import Lens.Micro.Platform import Data.Hashable hiding (Hashed) import Data.Coerce -import Data.List qualified as List import Codec.Serialise {- HLINT ignore "Use newtype instead of data" -} @@ -382,15 +379,6 @@ data RefChanHead e = instance ForRefChans e => Serialise (RefChanHead e) --- FIXME: rename -data RefChanAdapter e m = - RefChanAdapter - { refChanOnHead :: RefChanId e -> RefChanHeadBlockTran e -> m () - , refChanSubscribed :: RefChanId e -> m Bool - , refChanWriteTran :: HashRef -> m () - , refChanValidatePropose :: RefChanId e -> HashRef -> m Bool - , refChanNotifyRely :: RefChanId e -> RefChanNotify e -> m () - } class HasRefChanId e p | p -> e where getRefChanId :: p -> RefChanId e diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 8e607b09..f65039fa 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -128,7 +128,6 @@ executable test-udp -- other-extensions: - -- type: exitcode-stdio-1.0 hs-source-dirs: test main-is: TestUDP.hs @@ -866,7 +865,6 @@ executable test-notify -- other-extensions: - type: exitcode-stdio-1.0 hs-source-dirs: test/notify-unix main-is: Main.hs build-depends: @@ -910,7 +908,6 @@ executable test-playground -- other-extensions: - type: exitcode-stdio-1.0 hs-source-dirs: test/playground main-is: Main.hs build-depends: @@ -961,7 +958,6 @@ executable test-pipe-mess -- other-extensions: - type: exitcode-stdio-1.0 hs-source-dirs: test main-is: TestPipeMessaging.hs build-depends: @@ -1082,3 +1078,48 @@ executable test-lsw-write , timeit +executable test-refchan-notify + import: shared-properties + default-language: Haskell2010 + + -- other-extensions: + + hs-source-dirs: test + main-is: TestRefChanNotify.hs + build-depends: + base + + , hbs2-core + , hbs2-peer + , suckless-conf + + , async + , bytestring + , cache + , containers + , hashable + , microlens-platform + , mtl + , prettyprinter + , QuickCheck + , quickcheck-instances + , random + , safe + , serialise + , stm + , streaming + , tasty + , tasty-quickcheck + , tasty-hunit + , tasty-quickcheck + , transformers + , uniplate + , vector + , filepath + , temporary + , unliftio + , unordered-containers + , unix + , timeit + + diff --git a/hbs2-tests/test/TestRefChanNotify.hs b/hbs2-tests/test/TestRefChanNotify.hs new file mode 100644 index 00000000..3a98eaca --- /dev/null +++ b/hbs2-tests/test/TestRefChanNotify.hs @@ -0,0 +1,156 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +module Main where + +import HBS2.Prelude.Plated +import HBS2.Actors.Peer +import HBS2.Base58 +import HBS2.OrDie +import HBS2.Hash +import HBS2.Data.Types.Refs +import HBS2.Net.Auth.Credentials +import HBS2.Polling +import HBS2.Misc.PrettyStuff +import HBS2.System.Dir +import HBS2.System.Logger.Simple.ANSI hiding (info) +import HBS2.Net.Messaging.Unix + +import HBS2.Net.Proto.Notify +import HBS2.Net.Proto.Service +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.Notify +import HBS2.Peer.RPC.API.Peer +-- import HBS2.Peer.RPC.API.RefLog +-- import HBS2.Peer.RPC.API.LWWRef +-- import HBS2.Peer.RPC.API.Storage +-- import HBS2.Peer.RPC.Client.StorageClient + +import HBS2.Peer.CLI.Detect +import HBS2.Peer.Proto.RefLog + +import Data.Config.Suckless +import Data.Config.Suckless.Script + +import HBS2.System.Logger.Simple.ANSI + +import Data.Maybe +import System.Environment +import Control.Monad.Trans.Cont +import Control.Monad.Reader +import Lens.Micro.Platform + + +data MyEnv = + MyEnv + { _myRefChan :: Maybe (RefChanId L4Proto) + } + +makeLenses ''MyEnv + + +main :: IO () +main = do + work + `finally` do + setLoggingOff @DEBUG + setLoggingOff @TRACE + setLoggingOff @NOTICE + setLoggingOff @ERROR + setLoggingOff @WARN + + +respawned :: MonadUnliftIO m => m a1 -> m a2 +respawned action = do + fix \next -> do + try @_ @SomeException action + warn $ red "respawning..." + pause @'Seconds 2 + next + +work :: IO () +work = do + + setLogging @WARN (toStderr . logPrefix "[warn] ") + setLogging @ERROR (toStderr . logPrefix "[error] ") + setLogging @DEBUG (toStderr . logPrefix "[debug] ") + setLogging @TRACE (toStderr . logPrefix "[trace] ") + setLogging @NOTICE toStdout + + tv <- newTVarIO (MyEnv mzero) + + let dict = makeDict @C do + + entry $ bindMatch "--refchan" $ nil_ \case + [SignPubKeyLike rchan] -> do + atomically $ modifyTVar tv (set myRefChan (Just rchan)) + + _ -> throwIO $ BadFormException @C nil + + + argz <- getArgs + forms <- parseTop (unlines $ unwords <$> splitForms argz) + & either (error.show) pure + + + void $ run dict forms + + rchan <- readTVarIO tv <&> view myRefChan + >>= orThrowUser "refchan not set" + + notice $ yellow "refchan set" <+> pretty (AsBase58 rchan) + + respawned $ flip runContT pure do + + -- NOTE: dont-retry + -- MUDontRetry -- ВАЖНО + -- что бы UnixClient не пытался перезапустить транспорт + -- т.к кажется в этом случае некорректно будут работать + -- нотификации ( не будет создан новый сокет, а будут + -- идти в старый. возможно это надо пофиксить, но пока + -- непонятно, как ) + -- + -- Короче, запретить ему повторный коннект, ловить + -- исключения и выход из клиентов и всё по новой. + -- + -- так лучше + -- + let o = [MUWatchdog 10,MUDontRetry] + + soname <- detectRPC + >>= orThrowUser "hbs2-peer not found" + + client <- liftIO $ race (pause @'Seconds 1) (newMessagingUnixOpts o False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + notif <- ContT $ withAsync (runMessagingUnix client) + + sink <- newNotifySink + + p1 <- ContT $ withAsync $ flip runReaderT client $ do + runProto @UNIX + [ makeResponse (makeNotifyClient @(RefChanEvents L4Proto) sink) + ] + + psink <- ContT $ withAsync $ flip runReaderT client $ do + debug $ red "notify restarted!" + runNotifyWorkerClient sink + + -- NOTE: wrap-to-thread-to-kill + -- важно обернуть это в поток, что бы + -- можно было пристрелить, если кто-то еще + -- отгниёт из других потоков + -- иначе будет висеть вечно + psink2 <- ContT $ withAsync do + runNotifySink sink (RefChanNotifyKey rchan) $ \case + RefChanUpdated r v -> do + notice $ red "refchan updated" <+> pretty (AsBase58 r) <+> pretty v + + _ -> do + notice $ "some other refchan event happened" + + void $ waitAnyCatchCancel [notif,p1,psink,psink2] + +