mirror of https://github.com/voidlizard/hbs2
merged refchan notifications and fixme-new (wip)
This commit is contained in:
Dmitry Zuikov
parent
0bba3721e6
commit
ff9ef2ddec
|
|
@ -9,76 +9,29 @@ fixme-prefix TODO:
|
||||||
fixme-prefix PR:
|
fixme-prefix PR:
|
||||||
fixme-prefix REVIEW:
|
fixme-prefix REVIEW:
|
||||||
|
|
||||||
fixme-git-scan-filter-days 30
|
fixme-attribs assigned workflow :class
|
||||||
|
|
||||||
fixme-attribs assigned workflow type
|
fixme-attribs class
|
||||||
|
|
||||||
fixme-attribs resolution cat scope
|
|
||||||
|
|
||||||
fixme-value-set workflow new backlog wip test fixed done
|
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 scope mvp-0 mvp-1 backlog
|
||||||
|
|
||||||
fixme-value-set type bug feature code
|
|
||||||
|
|
||||||
fixme-files **/*.txt docs/devlog.md
|
fixme-files **/*.txt docs/devlog.md
|
||||||
fixme-files **/*.hs
|
fixme-files **/*.hs
|
||||||
|
fixme-exclude **/.**
|
||||||
|
fixme-exclude dist-newstyle
|
||||||
|
|
||||||
fixme-file-comments "*.scm" ";"
|
fixme-file-comments "*.scm" ";"
|
||||||
|
|
||||||
fixme-comments ";" "--"
|
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
|
(define-template short
|
||||||
|
(quot
|
||||||
(simple
|
(simple
|
||||||
(trim 10 $fixme-key) " "
|
(trim 10 $fixme-key) " "
|
||||||
|
|
||||||
|
|
@ -95,12 +48,26 @@ fixme-comments ";" "--"
|
||||||
(align 12 $assigned) " "
|
(align 12 $assigned) " "
|
||||||
(align 20 (trim 20 $committer-name)) " "
|
(align 20 (trim 20 $committer-name)) " "
|
||||||
(trim 50 ($fixme-title)) " "
|
(trim 50 ($fixme-title)) " "
|
||||||
(nl)
|
(nl))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
(set-template default short)
|
(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)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
там, где они не нужны.
|
||||||
|
|
||||||
|
это плохо для файлопомойки.
|
||||||
|
|
||||||
|
нужно найти решения для проблемы
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Fixme
|
import Fixme
|
||||||
|
-- import Fixme.Run
|
||||||
import Fixme.Run
|
import Fixme.Run
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
|
||||||
|
|
@ -62,7 +63,7 @@ main = do
|
||||||
-- TODO: scan-all-sources
|
-- TODO: scan-all-sources
|
||||||
-- for-source-from-con
|
-- for-source-from-con
|
||||||
|
|
||||||
runFixmeCLI (run =<< liftIO getArgs)
|
runFixmeCLI runCLI
|
||||||
|
|
||||||
-- FIXME: test-fixme
|
-- FIXME: test-fixme
|
||||||
-- $workflow: wip
|
-- $workflow: wip
|
||||||
|
|
|
||||||
|
|
@ -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))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
|
||||||
|
fixme-pager (quot (bat "--file-name" $file "-H" $before))
|
||||||
|
|
||||||
|
fixme-def-context 2 5
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -57,6 +57,7 @@ common shared-properties
|
||||||
, hbs2-storage-simple
|
, hbs2-storage-simple
|
||||||
, hbs2-keyman-direct-lib
|
, hbs2-keyman-direct-lib
|
||||||
, hbs2-git
|
, hbs2-git
|
||||||
|
, hbs2-cli
|
||||||
, db-pipe
|
, db-pipe
|
||||||
, suckless-conf
|
, suckless-conf
|
||||||
, fuzzy-parse
|
, fuzzy-parse
|
||||||
|
|
@ -104,11 +105,13 @@ common shared-properties
|
||||||
library
|
library
|
||||||
import: shared-properties
|
import: shared-properties
|
||||||
|
|
||||||
|
other-modules:
|
||||||
|
Fixme.Run.Internal
|
||||||
|
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Fixme
|
Fixme
|
||||||
Fixme.Config
|
Fixme.Config
|
||||||
Fixme.Run
|
Fixme.Run
|
||||||
Fixme.Log
|
|
||||||
Fixme.Types
|
Fixme.Types
|
||||||
Fixme.Prelude
|
Fixme.Prelude
|
||||||
Fixme.State
|
Fixme.State
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@ import Fixme.Types
|
||||||
|
|
||||||
import HBS2.System.Dir
|
import HBS2.System.Dir
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Directory
|
import System.Directory (getXdgDirectory, XdgDirectory(..))
|
||||||
|
|
||||||
binName :: FixmePerks m => m FilePath
|
binName :: FixmePerks m => m FilePath
|
||||||
binName = liftIO getProgName
|
binName = liftIO getProgName
|
||||||
|
|
@ -16,6 +16,9 @@ localConfigDir = do
|
||||||
b <- binName
|
b <- binName
|
||||||
pure (p </> ("." <> b))
|
pure (p </> ("." <> b))
|
||||||
|
|
||||||
|
fixmeWorkDir :: FixmePerks m => m FilePath
|
||||||
|
fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
|
||||||
|
|
||||||
localConfig:: FixmePerks m => m FilePath
|
localConfig:: FixmePerks m => m FilePath
|
||||||
localConfig = localConfigDir <&> (</> "config")
|
localConfig = localConfigDir <&> (</> "config")
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
||||||
|
|
@ -4,6 +4,7 @@ module Fixme.Prelude
|
||||||
, GitRef(..)
|
, GitRef(..)
|
||||||
, Serialise(..)
|
, Serialise(..)
|
||||||
, serialise, deserialiseOrFail, deserialise
|
, serialise, deserialiseOrFail, deserialise
|
||||||
|
, module Exported
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import HBS2.Prelude.Plated as All
|
import HBS2.Prelude.Plated as All
|
||||||
|
|
@ -18,3 +19,6 @@ import Data.Function as All
|
||||||
import UnliftIO as All
|
import UnliftIO as All
|
||||||
import System.FilePattern as All
|
import System.FilePattern as All
|
||||||
import Control.Monad.Reader as All
|
import Control.Monad.Reader as All
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Script as Exported
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
||||||
|
|
@ -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)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
{-# Language MultiWayIf #-}
|
{-# Language MultiWayIf #-}
|
||||||
module Fixme.Scan (scanBlob,scanMagic) where
|
module Fixme.Scan (scanBlob,scanMagic,updateScanMagic) where
|
||||||
|
|
||||||
import Fixme.Prelude hiding (indent)
|
import Fixme.Prelude hiding (indent)
|
||||||
import Fixme.Types
|
import Fixme.Types
|
||||||
|
|
@ -61,12 +61,19 @@ scanMagic = do
|
||||||
co <- fixmeEnvDefComments env & readTVar
|
co <- fixmeEnvDefComments env & readTVar
|
||||||
fco <- fixmeEnvFileComments env & readTVar
|
fco <- fixmeEnvFileComments env & readTVar
|
||||||
m <- fixmeEnvFileMask env & readTVar
|
m <- fixmeEnvFileMask env & readTVar
|
||||||
|
e <- fixmeEnvFileExclude env & readTVar
|
||||||
a <- fixmeEnvAttribs env & readTVar
|
a <- fixmeEnvAttribs env & readTVar
|
||||||
v <- fixmeEnvAttribValues 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
|
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
|
scanBlob :: forall m . FixmePerks m
|
||||||
=> Maybe FilePath -- ^ filename to detect type
|
=> Maybe FilePath -- ^ filename to detect type
|
||||||
-> ByteString -- ^ content
|
-> ByteString -- ^ content
|
||||||
|
|
@ -172,7 +179,7 @@ scanBlob fpath lbs = do
|
||||||
FixmeHead lno _ tag title ->
|
FixmeHead lno _ tag title ->
|
||||||
Fixme (FixmeTag tag)
|
Fixme (FixmeTag tag)
|
||||||
(FixmeTitle title)
|
(FixmeTitle title)
|
||||||
Nothing
|
mempty
|
||||||
Nothing
|
Nothing
|
||||||
(Just (FixmeOffset (fromIntegral lno)))
|
(Just (FixmeOffset (fromIntegral lno)))
|
||||||
Nothing
|
Nothing
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,6 @@ import Fixme.Prelude hiding (indent)
|
||||||
import Fixme.Types
|
import Fixme.Types
|
||||||
import Fixme.State
|
import Fixme.State
|
||||||
import Fixme.Scan as Scan
|
import Fixme.Scan as Scan
|
||||||
import Fixme.Log
|
|
||||||
|
|
||||||
import HBS2.Storage
|
import HBS2.Storage
|
||||||
import HBS2.Storage.Compact
|
import HBS2.Storage.Compact
|
||||||
|
|
@ -51,24 +50,6 @@ import Data.Map qualified as Map
|
||||||
|
|
||||||
import Streaming.Prelude qualified as S
|
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" -}
|
{- HLINT ignore "Functor law" -}
|
||||||
|
|
||||||
|
|
@ -115,31 +96,13 @@ listCommits = do
|
||||||
|
|
||||||
spec = sq <> delims " \t"
|
spec = sq <> delims " \t"
|
||||||
|
|
||||||
|
listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => Maybe GitHash -> m [(FilePath,GitHash)]
|
||||||
listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)]
|
listBlobs mco = do
|
||||||
listRefs every = do
|
|
||||||
gd <- fixmeGetGitDirCLIOpt
|
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
|
let what = maybe "HEAD" (show . pretty) mco
|
||||||
filt _ | every = pure True
|
|
||||||
|
|
||||||
filt (h,_) = do
|
gitRunCommand [qc|git {gd} ls-tree -r -l -t {what}|]
|
||||||
done <- withState $ isProcessed $ ViaSerialise h
|
|
||||||
pure (not done)
|
|
||||||
|
|
||||||
listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m [(FilePath,GitHash)]
|
|
||||||
listBlobs co = do
|
|
||||||
gd <- fixmeGetGitDirCLIOpt
|
|
||||||
gitRunCommand [qc|git {gd} ls-tree -r -l -t {pretty co}|]
|
|
||||||
<&> fromRight mempty
|
<&> fromRight mempty
|
||||||
<&> fmap LBS8.words . LBS8.lines
|
<&> fmap LBS8.words . LBS8.lines
|
||||||
<&> mapMaybe
|
<&> mapMaybe
|
||||||
|
|
@ -166,142 +129,22 @@ filterBlobs xs = do
|
||||||
pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
|
pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
|
||||||
filterBlobs0 pat xs
|
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
|
listFixmies :: FixmePerks m
|
||||||
=> FilePath
|
=> FixmeM m [Fixme]
|
||||||
-> ( CompactStorage HbSync -> FixmeM m () )
|
listFixmies = do
|
||||||
-> FixmeM m ()
|
|
||||||
scanGitLogLocal refMask play = do
|
|
||||||
warn $ red "scanGitLogLocal" <+> pretty refMask
|
|
||||||
|
|
||||||
(t,refs) <- timeItT $ listRefs False
|
|
||||||
|
|
||||||
let hashes = fmap fst refs
|
|
||||||
|
|
||||||
warn $ yellow "listRefs in" <+> pretty (realToFrac t :: Fixed E6)
|
|
||||||
|
|
||||||
let pat = [(True, refMask)]
|
|
||||||
|
|
||||||
-- FIXME: use-cache-to-skip-already-processed-tips
|
|
||||||
logz <- withState do
|
|
||||||
S.toList_ $ for_ hashes $ \h -> do
|
|
||||||
done <- lift $ isProcessed (ViaSerialise h)
|
|
||||||
unless done do
|
|
||||||
blobs <- lift $ lift $ (listBlobs h >>= filterBlobs0 pat)
|
|
||||||
when (List.null blobs) do
|
|
||||||
lift $ insertProcessed (ViaSerialise h)
|
|
||||||
for_ blobs $ \(_,b) -> do
|
|
||||||
S.yield (h,b)
|
|
||||||
|
|
||||||
warn $ yellow "STEP 3" <+> "for each tree --- find log"
|
|
||||||
|
|
||||||
warn $ vcat (fmap pretty logz)
|
|
||||||
|
|
||||||
warn $ yellow "STEP 4" <+> "for each log --- scan log"
|
|
||||||
|
|
||||||
withState $ transactional do
|
|
||||||
|
|
||||||
flip runContT pure do
|
|
||||||
for_ logz $ \(commitHash, h) -> callCC \shit -> do
|
|
||||||
warn $ blue "SCAN BLOB" <+> pretty h
|
|
||||||
tmp <- ContT $ bracket (liftIO (emptySystemTempFile "fixme-log")) rm
|
|
||||||
blob <- lift $ lift $ gitCatBlob h
|
|
||||||
liftIO (LBS8.writeFile tmp blob)
|
|
||||||
|
|
||||||
esto <- lift $ try @_ @CompactStorageOpenError $ compactStorageOpen @HbSync readonly tmp
|
|
||||||
|
|
||||||
-- skip even problematic commit
|
|
||||||
lift $ insertProcessed (ViaSerialise commitHash)
|
|
||||||
|
|
||||||
either (const $ warn $ "skip malformed/unknown log" <+> pretty h) (const none) esto
|
|
||||||
sto <- either (const $ shit ()) pure esto
|
|
||||||
|
|
||||||
lift $ lift $ play sto
|
|
||||||
|
|
||||||
compactStorageClose sto
|
|
||||||
|
|
||||||
scanGitLocal :: FixmePerks m
|
|
||||||
=> [ScanGitArgs]
|
|
||||||
-> Maybe FilePath
|
|
||||||
-> FixmeM m ()
|
|
||||||
scanGitLocal args p = do
|
|
||||||
|
|
||||||
env <- ask
|
|
||||||
|
|
||||||
flip runContT pure do
|
flip runContT pure do
|
||||||
|
|
||||||
(dbFn, _) <- ContT $ withSystemTempFile "fixme-db" . curry
|
blobs <- lift listRelevantBlobs
|
||||||
|
|
||||||
tempDb <- newDBPipeEnv dbPipeOptsDef dbFn
|
|
||||||
|
|
||||||
withDB tempDb do
|
|
||||||
ddl [qc| create table co
|
|
||||||
( cohash text not null
|
|
||||||
, ts int null
|
|
||||||
, primary key (cohash)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc| create table coattr
|
|
||||||
( cohash text not null
|
|
||||||
, name text not null
|
|
||||||
, value text not null
|
|
||||||
, primary key (cohash,name)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc| create table blob
|
|
||||||
( hash text not null
|
|
||||||
, cohash text not null
|
|
||||||
, path text not null
|
|
||||||
, primary key (hash,cohash,path)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
-- update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|]
|
|
||||||
|
|
||||||
let onlyNewCommits xs
|
|
||||||
| ScanAllCommits `elem` args = pure xs
|
|
||||||
| otherwise = lift $ filterM (newCommit . view _1) xs
|
|
||||||
|
|
||||||
co <- lift listCommits >>= onlyNewCommits
|
|
||||||
|
|
||||||
lift do
|
|
||||||
withDB tempDb $ transactional do
|
|
||||||
for_ co $ \(commit, attr) -> do
|
|
||||||
|
|
||||||
debug $ "commit" <+> pretty commit
|
|
||||||
|
|
||||||
blobs <- lift $ listBlobs commit >>= withFixmeEnv env . filterBlobs
|
|
||||||
|
|
||||||
let ts = HM.lookup "commit-time" attr
|
|
||||||
>>= readMay @Word64 . Text.unpack . coerce
|
|
||||||
|
|
||||||
insert [qc|
|
|
||||||
insert into co (cohash,ts) values (?,?) on conflict (cohash) do nothing
|
|
||||||
|] (commit,ts)
|
|
||||||
|
|
||||||
for_ (HM.toList attr) $ \(a,b) -> do
|
|
||||||
insert [qc|
|
|
||||||
insert into coattr(cohash,name,value) values(?,?,?)
|
|
||||||
on conflict (cohash,name) do nothing
|
|
||||||
|] (commit,a,b)
|
|
||||||
|
|
||||||
for_ blobs $ \(fp,h) -> do
|
|
||||||
insert [qc| insert into blob (hash,cohash,path)
|
|
||||||
values (?,?,?)
|
|
||||||
on conflict (hash,cohash,path) do nothing
|
|
||||||
|] (h,commit,fp)
|
|
||||||
|
|
||||||
|
|
||||||
blobs <- withDB tempDb do
|
|
||||||
select_ @_ @(GitHash, FilePath) [qc|select distinct hash, path from blob order by path|]
|
|
||||||
|
|
||||||
when ( PrintBlobs `elem` args ) do
|
|
||||||
for_ blobs $ \(h,fp) -> do
|
|
||||||
notice $ pretty h <+> pretty fp
|
|
||||||
|
|
||||||
callCC \fucked -> do
|
|
||||||
|
|
||||||
gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
|
gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
|
||||||
|
|
||||||
|
|
@ -310,14 +153,7 @@ scanGitLocal args p = do
|
||||||
|
|
||||||
liftIO $ IO.hSetBuffering ssin LineBuffering
|
liftIO $ IO.hSetBuffering ssin LineBuffering
|
||||||
|
|
||||||
for_ blobs $ \(h,fp) -> callCC \next -> do
|
for_ blobs $ \(fp,h) -> do
|
||||||
|
|
||||||
seen <- lift (withState $ selectObjectHash h) <&> isJust
|
|
||||||
|
|
||||||
when seen do
|
|
||||||
trace $ red "ALREADY SEEN BLOB" <+> pretty h
|
|
||||||
next ()
|
|
||||||
|
|
||||||
liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
|
liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
|
||||||
prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
|
prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
|
||||||
|
|
||||||
|
|
@ -328,110 +164,15 @@ scanGitLocal args p = do
|
||||||
blob <- liftIO $ LBS8.hGet ssout len
|
blob <- liftIO $ LBS8.hGet ssout len
|
||||||
void $ liftIO $ BS.hGetLine ssout
|
void $ liftIO $ BS.hGetLine ssout
|
||||||
|
|
||||||
|
|
||||||
poor <- lift (Scan.scanBlob (Just fp) blob)
|
poor <- lift (Scan.scanBlob (Just fp) blob)
|
||||||
|
|
||||||
rich <- withDB tempDb do
|
liftIO $ mapM_ (print . pretty) poor
|
||||||
let q = [qc|
|
|
||||||
|
|
||||||
WITH CommitAttributes AS (
|
_ -> pure ()
|
||||||
SELECT co.cohash, co.ts, coattr.name, coattr.value
|
|
||||||
FROM co
|
|
||||||
JOIN coattr ON co.cohash = coattr.cohash
|
|
||||||
),
|
|
||||||
MinCommitTimes AS (
|
|
||||||
SELECT blob.hash, MIN(co.ts) as mintime
|
|
||||||
FROM blob
|
|
||||||
JOIN co ON blob.cohash = co.cohash
|
|
||||||
WHERE co.ts IS NOT NULL
|
|
||||||
GROUP BY blob.hash
|
|
||||||
),
|
|
||||||
RelevantCommits AS (
|
|
||||||
SELECT blob.hash, blob.cohash, blob.path
|
|
||||||
FROM blob
|
|
||||||
JOIN MinCommitTimes ON blob.hash = MinCommitTimes.hash
|
|
||||||
JOIN co ON blob.cohash = co.cohash AND co.ts = MinCommitTimes.mintime
|
|
||||||
)
|
|
||||||
SELECT CommitAttributes.name, CommitAttributes.value
|
|
||||||
FROM RelevantCommits
|
|
||||||
JOIN CommitAttributes ON RelevantCommits.cohash = CommitAttributes.cohash
|
|
||||||
WHERE RelevantCommits.hash = ?
|
|
||||||
|]
|
|
||||||
|
|
||||||
what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h)
|
|
||||||
<&> HM.fromList
|
|
||||||
<&> (<> HM.fromList [ ("blob",fromString $ show (pretty h))
|
|
||||||
, ("file",fromString fp)
|
|
||||||
])
|
|
||||||
|
|
||||||
for poor $ \f -> do
|
|
||||||
let lno = maybe mempty ( HM.singleton "line"
|
|
||||||
. FixmeAttrVal
|
|
||||||
. Text.pack
|
|
||||||
. show
|
|
||||||
)
|
|
||||||
(fixmeStart f)
|
|
||||||
|
|
||||||
let ts = HM.lookup "commit-time" what
|
|
||||||
<&> Text.unpack . coerce
|
|
||||||
>>= readMay
|
|
||||||
<&> FixmeTimestamp
|
|
||||||
|
|
||||||
pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> (what <> lno)) f
|
|
||||||
|
|
||||||
|
|
||||||
let fxpos1 = [ (fixmeTitle fx, [i :: Int])
|
|
||||||
| (i,fx) <- zip [0..] rich
|
|
||||||
-- , fixmeTitle fx /= mempty
|
|
||||||
] & Map.fromListWith (flip (<>))
|
|
||||||
|
|
||||||
let mt e = do
|
pure mempty
|
||||||
let seed = [ (fst e, i) | i <- snd e ]
|
|
||||||
flip fix (0,[],seed) $ \next (num,acc,rest) ->
|
|
||||||
case rest of
|
|
||||||
[] -> acc
|
|
||||||
(x:xs) -> next (succ num, (x,num) : acc, xs)
|
|
||||||
|
|
||||||
let fxpos2 = [ mt e
|
|
||||||
| e <- Map.toList fxpos1
|
|
||||||
] & mconcat
|
|
||||||
& Map.fromList
|
|
||||||
|
|
||||||
fixmies <- for (zip [0..] rich) $ \(i,fx) -> do
|
|
||||||
let title = fixmeTitle fx
|
|
||||||
let kb = Map.lookup (title,i) fxpos2
|
|
||||||
let ka = HM.lookup "file" (fixmeAttr fx)
|
|
||||||
let kk = (,,) <$> ka <*> pure title <*> kb
|
|
||||||
|
|
||||||
case kk of
|
|
||||||
Nothing -> pure fx
|
|
||||||
Just (a,b,c) -> do
|
|
||||||
let ks = [qc|{show (pretty a)}#{show (pretty b)}:{show c}|] :: Text
|
|
||||||
let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
|
|
||||||
let kh = HM.singleton "fixme-key" ksh
|
|
||||||
let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
|
|
||||||
pure $ over (field @"fixmeAttr") (<> kv) fx
|
|
||||||
|
|
||||||
when ( PrintFixme `elem` args ) do
|
|
||||||
for_ fixmies $ \fixme -> do
|
|
||||||
notice $ pretty fixme
|
|
||||||
|
|
||||||
when ( ScanRunDry `elem` args ) $ fucked ()
|
|
||||||
|
|
||||||
debug $ "actually-import-fixmies" <+> pretty h
|
|
||||||
|
|
||||||
liftIO $ withFixmeEnv env $ withState $ transactional do
|
|
||||||
insertBlob h
|
|
||||||
for_ fixmies insertFixme
|
|
||||||
|
|
||||||
_ -> fucked ()
|
|
||||||
|
|
||||||
unless ( ScanRunDry `elem` args ) do
|
|
||||||
lift runLogActions
|
|
||||||
|
|
||||||
liftIO $ withFixmeEnv env $ withState $ transactional do
|
|
||||||
for_ co $ \w -> do
|
|
||||||
insertCommit (view _1 w)
|
|
||||||
|
|
||||||
|
|
||||||
gitListStage :: (FixmePerks m)
|
gitListStage :: (FixmePerks m)
|
||||||
|
|
@ -539,7 +280,7 @@ gitExtractFileMetaData fns = do
|
||||||
rich0 <- S.toList_ $ do
|
rich0 <- S.toList_ $ do
|
||||||
for_ co $ \(c, (t,n,m)) -> do
|
for_ co $ \(c, (t,n,m)) -> do
|
||||||
let pat = [ (True, f) | f <- fns ]
|
let pat = [ (True, f) | f <- fns ]
|
||||||
blobz <- lift $ listBlobs c >>= filterBlobs0 pat
|
blobz <- lift $ listBlobs (Just c) >>= filterBlobs0 pat
|
||||||
|
|
||||||
for_ blobz $ \(f,h) -> do
|
for_ blobz $ \(f,h) -> do
|
||||||
let attr = HM.fromList [ ("commit", FixmeAttrVal (fromString $ show $ pretty c))
|
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 ]
|
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
|
data GitBlobInfo = GitBlobInfo FilePath GitHash
|
||||||
deriving stock (Eq,Ord,Data,Generic,Show)
|
deriving stock (Eq,Ord,Data,Generic,Show)
|
||||||
|
|
@ -597,7 +328,7 @@ listCommitForIndex fn = do
|
||||||
)
|
)
|
||||||
|
|
||||||
for_ s0 $ \(h, GitCommit w _) -> 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)
|
fn (h, GitCommit w blobz)
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
@ -609,11 +340,28 @@ gitCatBlob h = do
|
||||||
(_,s,_) <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|]
|
(_,s,_) <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|]
|
||||||
pure s
|
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 :: (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())
|
||||||
startGitCatFile = do
|
startGitCatFile = do
|
||||||
gd <- fixmeGetGitDirCLIOpt
|
gd <- fixmeGetGitDirCLIOpt
|
||||||
let cmd = [qc|git {gd} cat-file --batch|]
|
let cmd = [qc|git {gd} cat-file --batch|]
|
||||||
debug $ pretty cmd
|
debug $ pretty cmd
|
||||||
let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd
|
let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd
|
||||||
|
-- ssin <- getStdin config
|
||||||
startProcess config
|
startProcess config
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,48 +1,42 @@
|
||||||
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Fixme.State
|
module Fixme.State
|
||||||
( evolve
|
( evolve
|
||||||
, withState
|
, withState
|
||||||
, insertFixme
|
|
||||||
, selectFixmeThin
|
|
||||||
, selectFixmeHash
|
|
||||||
, selectFixmeHashes
|
|
||||||
, selectFixme
|
|
||||||
, deleteFixme
|
|
||||||
, updateFixme
|
|
||||||
, insertCommit
|
|
||||||
, insertBlob
|
|
||||||
, selectObjectHash
|
|
||||||
, newCommit
|
|
||||||
, cleanupDatabase
|
, cleanupDatabase
|
||||||
, updateIndexes
|
, listFixme
|
||||||
, insertFixmeDelStaged
|
, insertFixme
|
||||||
, insertFixmeModStaged
|
, insertFixmeExported
|
||||||
, selectStageModified
|
, modifyFixme
|
||||||
, selectStageDeleted
|
, insertScannedFile
|
||||||
, selectStage
|
, insertScanned
|
||||||
, cleanStage
|
, selectIsAlreadyScannedFile
|
||||||
, insertProcessed
|
, selectIsAlreadyScanned
|
||||||
, isProcessed
|
, listAllScanned
|
||||||
, selectProcessed
|
, selectFixmeKey
|
||||||
, checkFixmeExists
|
, getFixme
|
||||||
, listAllFixmeHashes
|
, insertTree
|
||||||
|
, FixmeExported(..)
|
||||||
, HasPredicate(..)
|
, HasPredicate(..)
|
||||||
, SelectPredicate(..)
|
, SelectPredicate(..)
|
||||||
|
, LocalNonce(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Fixme.Prelude
|
import Fixme.Prelude hiding (key)
|
||||||
import Fixme.Types
|
import Fixme.Types
|
||||||
import Fixme.Config
|
import Fixme.Config
|
||||||
|
|
||||||
|
import HBS2.Base58
|
||||||
import HBS2.System.Dir
|
import HBS2.System.Dir
|
||||||
import Data.Config.Suckless
|
import Data.Config.Suckless hiding (key)
|
||||||
import Data.Config.Suckless.Syntax
|
import Data.Config.Suckless.Syntax
|
||||||
import DBPipe.SQLite hiding (field)
|
import DBPipe.SQLite hiding (field)
|
||||||
|
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.HashSet qualified as HS
|
import Data.HashSet qualified as HS
|
||||||
import Data.Aeson as Aeson
|
import Data.Aeson as Aeson
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
import Data.HashMap.Strict qualified as HM
|
import Data.HashMap.Strict qualified as HM
|
||||||
import Text.InterpolatedString.Perl6 (q,qc)
|
import Text.InterpolatedString.Perl6 (q,qc)
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
|
|
@ -57,6 +51,8 @@ import Control.Monad.Trans.Maybe
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
import Data.Fixed
|
import Data.Fixed
|
||||||
import Data.Word (Word64)
|
import Data.Word (Word64)
|
||||||
|
import System.Directory (getModificationTime)
|
||||||
|
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||||
import System.TimeIt
|
import System.TimeIt
|
||||||
|
|
||||||
-- TODO: runPipe-omitted
|
-- 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 :: forall {c} . Text -> Syntax c
|
||||||
pattern Operand what <- (operand -> Just what)
|
pattern Operand what <- (operand -> Just what)
|
||||||
|
|
||||||
|
|
@ -123,235 +128,27 @@ withState what = do
|
||||||
createTables :: FixmePerks m => DBPipeM m ()
|
createTables :: FixmePerks m => DBPipeM m ()
|
||||||
createTables = do
|
createTables = do
|
||||||
|
|
||||||
-- тут все таблицы будут называться с префиксом
|
-- ddl [qc| create table if not exists tree
|
||||||
-- fixme, что бы может быть можно было встроить
|
-- ( hash text not null
|
||||||
-- в другую бд, если вдруг понадобится
|
-- , nonce text not null
|
||||||
|
-- , primary key (hash,nonce)
|
||||||
|
-- )
|
||||||
|
-- |]
|
||||||
|
|
||||||
ddl [qc|
|
ddl [qc| create table if not exists scanned
|
||||||
create table if not exists fixmegitobject
|
( hash text not null primary key )
|
||||||
( hash text not null
|
|
||||||
, type text null
|
|
||||||
, primary key (hash)
|
|
||||||
)
|
|
||||||
|]
|
|]
|
||||||
|
|
||||||
ddl [qc|
|
ddl [qc| create table if not exists object
|
||||||
create table if not exists fixme
|
( o text not null
|
||||||
( id text not null
|
, w integer not null
|
||||||
, ts integer
|
, k text not null
|
||||||
, fixme blob not null
|
, v blob not null
|
||||||
, primary key (id)
|
, nonce text null
|
||||||
|
, primary key (o,k)
|
||||||
)
|
)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create table if not exists fixmedeleted
|
|
||||||
( id text not null
|
|
||||||
, ts integer not null
|
|
||||||
, deleted bool not null
|
|
||||||
, primary key (id,ts)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create table if not exists fixmerel
|
|
||||||
( origin text not null
|
|
||||||
, related text not null
|
|
||||||
, ts integer not null
|
|
||||||
, reason text not null
|
|
||||||
, primary key (origin,related,ts)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create table if not exists fixmeattr
|
|
||||||
( fixme text not null
|
|
||||||
, ts integer null
|
|
||||||
, name text not null
|
|
||||||
, value text
|
|
||||||
, primary key (fixme,ts,name)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc| drop view if exists fixmeattrview |]
|
|
||||||
|
|
||||||
let commits = [qc|name in ('commit','committer','committer-name','committer-email','commit-time')|] :: Text
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create view fixmeattrview as
|
|
||||||
with ranked1 as (
|
|
||||||
select
|
|
||||||
fixme,
|
|
||||||
name,
|
|
||||||
value,
|
|
||||||
row_number() over (partition by fixme, name order by ts desc nulls first) as rn
|
|
||||||
from fixmeattr
|
|
||||||
where not ({commits})
|
|
||||||
)
|
|
||||||
, ranked2 as (
|
|
||||||
select
|
|
||||||
fixme,
|
|
||||||
name,
|
|
||||||
value,
|
|
||||||
row_number() over (partition by fixme, name order by ts asc nulls last) as rn
|
|
||||||
from fixmeattr
|
|
||||||
where ({commits})
|
|
||||||
)
|
|
||||||
|
|
||||||
select distinct fixme,name,value
|
|
||||||
from
|
|
||||||
(
|
|
||||||
select
|
|
||||||
fixme,
|
|
||||||
name,
|
|
||||||
value
|
|
||||||
from ranked1
|
|
||||||
where rn = 1
|
|
||||||
|
|
||||||
union
|
|
||||||
|
|
||||||
select
|
|
||||||
fixme,
|
|
||||||
name,
|
|
||||||
value
|
|
||||||
from ranked2
|
|
||||||
where rn = 1
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc|drop view if exists fixmeactualview|]
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create view fixmeactualview as
|
|
||||||
with a1 as (
|
|
||||||
select
|
|
||||||
a.fixme,
|
|
||||||
f.ts,
|
|
||||||
a.name,
|
|
||||||
a.value
|
|
||||||
from
|
|
||||||
fixmeattrview a
|
|
||||||
join fixme f on a.fixme = f.id
|
|
||||||
where
|
|
||||||
a.name = 'fixme-key'
|
|
||||||
and not exists (select null from fixmedeleted d where d.id = f.id)
|
|
||||||
),
|
|
||||||
rn AS (
|
|
||||||
select
|
|
||||||
f.id,
|
|
||||||
f.ts,
|
|
||||||
a.value AS fixmekey,
|
|
||||||
row_number() over (partition by a.value order by f.ts desc) as rn
|
|
||||||
from
|
|
||||||
fixme f
|
|
||||||
join a1 a on f.id = a.fixme and a.name = 'fixme-key'
|
|
||||||
)
|
|
||||||
select id as fixme, fixmekey, ts from rn
|
|
||||||
where rn = 1
|
|
||||||
and not exists (
|
|
||||||
select null
|
|
||||||
from fixmeattr a
|
|
||||||
join fixmedeleted d on d.id = a.fixme
|
|
||||||
where a.name = 'fixme-key'
|
|
||||||
and a.value = rn.fixmekey
|
|
||||||
)
|
|
||||||
|
|
||||||
|]
|
|
||||||
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create table if not exists fixmeactual
|
|
||||||
( fixme text not null
|
|
||||||
, primary key (fixme)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create table if not exists fixmejson
|
|
||||||
( fixme text not null
|
|
||||||
, fixmekey text
|
|
||||||
, json blob
|
|
||||||
, primary key (fixme)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc|
|
|
||||||
create index if not exists idx_fixmekey ON fixmejson(fixmekey)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc| create table if not exists fixmestagedel
|
|
||||||
( hash text not null primary key
|
|
||||||
, ts integer not null
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc| create table if not exists fixmestagemod
|
|
||||||
( hash text not null
|
|
||||||
, ts integer not null
|
|
||||||
, attr text not null
|
|
||||||
, value text
|
|
||||||
, primary key (hash,attr)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
ddl [qc| create table if not exists fixmeprocessed
|
|
||||||
( hash text not null
|
|
||||||
, primary key (hash)
|
|
||||||
)
|
|
||||||
|]
|
|
||||||
|
|
||||||
-- .fixme-new/state.db
|
|
||||||
-- and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
|
|
||||||
|
|
||||||
insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
|
|
||||||
insertCommit gh = do
|
|
||||||
insert [qc|
|
|
||||||
insert into fixmegitobject (hash,type) values(?,'commit')
|
|
||||||
on conflict (hash) do nothing
|
|
||||||
|] (Only gh)
|
|
||||||
|
|
||||||
insertBlob :: FixmePerks m => GitHash -> DBPipeM m ()
|
|
||||||
insertBlob gh = do
|
|
||||||
insert [qc|
|
|
||||||
insert into fixmegitobject (hash,type) values(?,'blob')
|
|
||||||
on conflict (hash) do nothing
|
|
||||||
|] (Only gh)
|
|
||||||
|
|
||||||
selectObjectHash :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash)
|
|
||||||
selectObjectHash gh = do
|
|
||||||
select [qc|select hash from fixmegitobject where hash = ?|] (Only gh)
|
|
||||||
<&> fmap fromOnly . listToMaybe
|
|
||||||
|
|
||||||
newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool
|
|
||||||
newCommit gh = isNothing <$> withState (selectObjectHash gh)
|
|
||||||
|
|
||||||
insertFixme :: FixmePerks m => Fixme -> DBPipeM m ()
|
|
||||||
insertFixme fx@Fixme{..} = do
|
|
||||||
let fixme = serialise fx
|
|
||||||
let fxId = hashObject @HbSync fixme & HashRef
|
|
||||||
insert [qc|insert into fixme (id, ts, fixme) values (?,?,?)
|
|
||||||
on conflict(id) do nothing
|
|
||||||
|] (fxId, fixmeTs, fixme)
|
|
||||||
|
|
||||||
for_ (HM.toList fixmeAttr) $ \(n,v) -> do
|
|
||||||
insert [qc|
|
|
||||||
insert into fixmeattr(fixme,ts,name,value)
|
|
||||||
values (?,?,?,?)
|
|
||||||
on conflict (fixme,ts,name) do update set value = excluded.value
|
|
||||||
|] (fxId, fixmeTs, n, v)
|
|
||||||
|
|
||||||
insert [qc|
|
|
||||||
insert into fixmeattr(fixme,ts,name,value)
|
|
||||||
values (?,?,?,?)
|
|
||||||
on conflict (fixme,ts,name) do update set value = excluded.value
|
|
||||||
|] (fxId, fixmeTs, "fixme-tag", fixmeTag)
|
|
||||||
|
|
||||||
insert [qc|
|
|
||||||
insert into fixmeattr(fixme,ts,name,value)
|
|
||||||
values (?,?,?,?)
|
|
||||||
on conflict (fixme,ts,name) do update set value = excluded.value
|
|
||||||
|] (fxId, fixmeTs, "fixme-title", fixmeTitle)
|
|
||||||
|
|
||||||
|
|
||||||
data SelectPredicate =
|
data SelectPredicate =
|
||||||
All
|
All
|
||||||
|
|
@ -389,18 +186,18 @@ instance IsContext c => HasPredicate [Syntax c] where
|
||||||
go = \case
|
go = \case
|
||||||
|
|
||||||
( SymbolVal "!" : rest ) -> do
|
( SymbolVal "!" : rest ) -> do
|
||||||
mklist [mksym "not", unlist (go rest)]
|
mkList [mkSym "not", unlist (go rest)]
|
||||||
|
|
||||||
( Operand a : SymbolVal "~" : Operand b : rest ) -> do
|
( 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
|
( w : SymbolVal "&&" : rest ) -> do
|
||||||
mklist [mksym "and", unlist w, unlist (go rest)]
|
mkList [mkSym "and", unlist w, unlist (go rest)]
|
||||||
|
|
||||||
( w : SymbolVal "||" : rest ) -> do
|
( 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
|
unlist = \case
|
||||||
ListVal [x] -> x
|
ListVal [x] -> x
|
||||||
|
|
@ -410,50 +207,6 @@ instance IsContext c => HasPredicate [Syntax c] where
|
||||||
{- HLINT ignore "Functor law" -}
|
{- HLINT ignore "Functor law" -}
|
||||||
{- HLINT ignore "Eta reduce" -}
|
{- 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
|
data Bound = forall a . (ToField a, Show a) => Bound a
|
||||||
|
|
||||||
instance ToField Bound where
|
instance ToField Bound where
|
||||||
|
|
@ -469,16 +222,12 @@ genPredQ tbl what = go what
|
||||||
All -> ("true", mempty)
|
All -> ("true", mempty)
|
||||||
|
|
||||||
FixmeHashExactly x ->
|
FixmeHashExactly x ->
|
||||||
([qc|({tbl}.fixme = ?)|], [Bound x])
|
([qc|(o.o = ?)|], [Bound x])
|
||||||
|
|
||||||
AttrLike "fixme-hash" val -> do
|
|
||||||
let binds = [Bound (val <> "%")]
|
|
||||||
([qc|({tbl}.fixme like ?)|], binds)
|
|
||||||
|
|
||||||
AttrLike name val -> do
|
AttrLike name val -> do
|
||||||
let x = val <> "%"
|
let x = val <> "%"
|
||||||
let binds = [Bound x]
|
let binds = [Bound x]
|
||||||
([qc|(json_extract({tbl}.json, '$."{name}"') like ?)|], binds)
|
([qc|(json_extract({tbl}.blob, '$."{name}"') like ?)|], binds)
|
||||||
|
|
||||||
Not a -> do
|
Not a -> do
|
||||||
let (sql, bound) = go a
|
let (sql, bound) = go a
|
||||||
|
|
@ -494,214 +243,238 @@ genPredQ tbl what = go what
|
||||||
let bsql = go b
|
let bsql = go b
|
||||||
([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql)
|
([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 :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
|
||||||
cleanupDatabase = do
|
cleanupDatabase = do
|
||||||
warn $ red "cleanupDatabase"
|
warn $ red "cleanupDatabase"
|
||||||
withState $ transactional do
|
withState $ transactional do
|
||||||
update_ [qc|delete from fixme|]
|
update_ [qc|delete from object|]
|
||||||
update_ [qc|delete from fixmeattr|]
|
update_ [qc|delete from scanned|]
|
||||||
update_ [qc|delete from fixmegitobject|]
|
|
||||||
update_ [qc|delete from fixmedeleted|]
|
scannedKey :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> m HashRef
|
||||||
update_ [qc|delete from fixmerel|]
|
scannedKey fme = do
|
||||||
update_ [qc|delete from fixmeactual|]
|
magic <- asks fixmeEnvScanMagic >>= readTVarIO
|
||||||
update_ [qc|delete from fixmejson|]
|
let file = fixmeAttr fme & HM.lookup "file"
|
||||||
update_ [qc|delete from fixmestagedel|]
|
let w = fixmeTs fme
|
||||||
update_ [qc|delete from fixmestagemod|]
|
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)
|
insertTree :: FixmePerks m => HashRef -> FixmeKey -> FixmeAttrName -> DBPipeM m ()
|
||||||
=> Text
|
insertTree h o k = do
|
||||||
-> FixmeAttrName
|
insert [qc| insert into tree (hash,o,k)
|
||||||
-> FixmeAttrVal
|
values (?,?,?)
|
||||||
-> m ()
|
on conflict (hash,o,k) do nothing
|
||||||
insertFixmeModStaged hash k v = withState do
|
|] (h,o,k)
|
||||||
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)
|
|
||||||
|
|
||||||
|
listAllScanned :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef)
|
||||||
|
listAllScanned = withState do
|
||||||
|
select_ [qc|select hash from scanned|] <&> HS.fromList . fmap ( fromSomeHash . fromOnly )
|
||||||
|
|
||||||
insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
insertScannedFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m ()
|
||||||
insertFixmeDelStaged hash = withState do
|
insertScannedFile file = do
|
||||||
ts <- getEpoch
|
k <- lift $ scannedKeyForFile file
|
||||||
insert [qc| insert into fixmestagedel (hash,ts) values(?,?)
|
insertScanned k
|
||||||
on conflict (hash)
|
|
||||||
do update set hash = excluded.hash
|
|
||||||
, ts = excluded.ts
|
|
||||||
|] (hash,ts)
|
|
||||||
|
|
||||||
|
insertScanned:: (FixmePerks m) => HashRef -> DBPipeM m ()
|
||||||
|
insertScanned k = do
|
||||||
|
insert [qc| insert into scanned (hash)
|
||||||
|
values(?)
|
||||||
|
on conflict (hash) do nothing|]
|
||||||
|
(Only k)
|
||||||
|
|
||||||
type StageModRow = (HashRef,Word64,Text,Text)
|
selectFixmeKey :: (FixmePerks m, MonadReader FixmeEnv m) => Text -> m (Maybe FixmeKey)
|
||||||
|
selectFixmeKey s = do
|
||||||
selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
withState do
|
||||||
selectStageModified = withState do
|
select @(Only FixmeKey) [qc|select distinct(o) from object where o like ? order by w desc|] (Only (s<>"%"))
|
||||||
what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|]
|
|
||||||
for what $ \(h,t,k,v) -> do
|
|
||||||
pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v)
|
|
||||||
|
|
||||||
selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
|
||||||
selectStageDeleted = withState do
|
|
||||||
what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|]
|
|
||||||
for what $ \(h,t) -> do
|
|
||||||
pure $ Deleted t h
|
|
||||||
|
|
||||||
selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
|
||||||
selectStage = do
|
|
||||||
a <- selectStageModified
|
|
||||||
b <- selectStageDeleted
|
|
||||||
pure (a<>b)
|
|
||||||
|
|
||||||
cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m ()
|
|
||||||
cleanStage = withState do
|
|
||||||
transactional do
|
|
||||||
update_ [qc|delete from fixmestagedel|]
|
|
||||||
update_ [qc|delete from fixmestagemod|]
|
|
||||||
|
|
||||||
deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
|
||||||
deleteFixme hash = withState do
|
|
||||||
trace $ red "deleteFixme" <+> pretty hash
|
|
||||||
|
|
||||||
here <- select [qc| select true
|
|
||||||
from fixmedeleted
|
|
||||||
where deleted and id = ?
|
|
||||||
order by ts desc
|
|
||||||
limit 1
|
|
||||||
|] (Only hash) <&> isJust . listToMaybe . fmap (fromOnly @Bool)
|
|
||||||
|
|
||||||
unless here do
|
|
||||||
insert [qc| insert into fixmedeleted (id,ts,deleted)
|
|
||||||
values (?,(strftime('%s', 'now')),true)
|
|
||||||
on conflict(id,ts) do nothing
|
|
||||||
|] (Only hash)
|
|
||||||
|
|
||||||
updateFixme :: (FixmePerks m,MonadReader FixmeEnv m)
|
|
||||||
=> Maybe FixmeTimestamp
|
|
||||||
-> Text
|
|
||||||
-> FixmeAttrName
|
|
||||||
-> FixmeAttrVal
|
|
||||||
-> m ()
|
|
||||||
|
|
||||||
updateFixme ts hash a b = withState do
|
|
||||||
warn $ red "updateFixme" <+> pretty hash
|
|
||||||
insert [qc| insert into fixmeattr (fixme,ts,name,value)
|
|
||||||
values (?,coalesce(?,strftime('%s', 'now')),?,?)
|
|
||||||
on conflict(fixme,ts,name) do update set value = excluded.value
|
|
||||||
|] (hash,ts,a,b)
|
|
||||||
|
|
||||||
updateIndexes :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
|
|
||||||
updateIndexes = withState $ transactional do
|
|
||||||
update_ [qc|delete from fixmeactual|]
|
|
||||||
update_ [qc|
|
|
||||||
insert into fixmeactual
|
|
||||||
select distinct fixme from fixmeactualview
|
|
||||||
|]
|
|
||||||
updateFixmeJson
|
|
||||||
-- FIXME: delete-table-grows
|
|
||||||
-- надо добавлять статус в fixmedeleted
|
|
||||||
-- только если он отличается от последнего
|
|
||||||
-- известного статуса
|
|
||||||
update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|]
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
insertProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
|
|
||||||
=> w
|
|
||||||
-> DBPipeM m ()
|
|
||||||
insertProcessed what = do
|
|
||||||
insert [qc| insert into fixmeprocessed (hash) values(?)
|
|
||||||
on conflict (hash) do nothing
|
|
||||||
|] (Only (show $ pretty $ hashObject @HbSync what))
|
|
||||||
|
|
||||||
|
|
||||||
isProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
|
|
||||||
=> w
|
|
||||||
-> DBPipeM m Bool
|
|
||||||
isProcessed what = do
|
|
||||||
let k = show $ pretty $ hashObject @HbSync what
|
|
||||||
select @(Only (Maybe Int)) [qc| select null from fixmeprocessed where hash = ? limit 1 |] (Only k)
|
|
||||||
<&> isJust . listToMaybe
|
|
||||||
|
|
||||||
selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m)
|
|
||||||
=> m [HashRef]
|
|
||||||
selectProcessed = withState do
|
|
||||||
select_ [qc|select hash from fixmeprocessed|]
|
|
||||||
<&> fmap fromOnly
|
<&> fmap fromOnly
|
||||||
|
<&> headMay
|
||||||
|
|
||||||
|
|
||||||
|
listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q)
|
||||||
|
=> q
|
||||||
|
-> m [Fixme]
|
||||||
|
listFixme expr = do
|
||||||
|
|
||||||
|
let (w,bound) = genPredQ "s1" (predicate expr)
|
||||||
|
|
||||||
|
let present = [qc|and coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
|
||||||
|
|
||||||
|
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
|
||||||
|
|]
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
|
||||||
|
data FixmeExported =
|
||||||
|
FixmeExported
|
||||||
|
{ exportedKey :: FixmeKey
|
||||||
|
, exportedWeight :: Word64
|
||||||
|
, exportedName :: FixmeAttrName
|
||||||
|
, exportedValue :: FixmeAttrVal
|
||||||
|
}
|
||||||
|
deriving stock Generic
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,9 @@
|
||||||
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
{-# LANGUAGE PatternSynonyms, ViewPatterns, TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Fixme.Types
|
module Fixme.Types
|
||||||
( module Fixme.Types
|
( module Fixme.Types
|
||||||
|
, module Exported
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Fixme.Prelude hiding (align)
|
import Fixme.Prelude hiding (align)
|
||||||
|
|
@ -10,11 +12,25 @@ import HBS2.Base58
|
||||||
import DBPipe.SQLite hiding (field)
|
import DBPipe.SQLite hiding (field)
|
||||||
import HBS2.Git.Local
|
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 Data.Config.Suckless
|
||||||
|
|
||||||
import Prettyprinter.Render.Terminal
|
import Prettyprinter.Render.Terminal
|
||||||
import Control.Applicative
|
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 (ByteString)
|
||||||
import Data.ByteString.Char8 qualified as BS8
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
import Data.ByteString.Lazy qualified as LBS
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
|
@ -33,6 +49,17 @@ import Text.InterpolatedString.Perl6 (qc)
|
||||||
import Data.Generics.Product.Fields (field)
|
import Data.Generics.Product.Fields (field)
|
||||||
import Lens.Micro.Platform
|
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
|
-- FIXME: move-to-suckless-conf
|
||||||
deriving stock instance Ord (Syntax C)
|
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 :: forall {c} . FixmeTimestamp -> Syntax c
|
||||||
pattern TimeStampLike e <- (tsFromFromSyn -> Just e)
|
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
|
class MkId a where
|
||||||
mkId :: a -> Id
|
mkId :: a -> Id
|
||||||
|
|
||||||
|
instance MkId String where
|
||||||
|
mkId s = fromString s
|
||||||
|
|
||||||
instance MkId FixmeAttrName where
|
instance MkId FixmeAttrName where
|
||||||
mkId (k :: FixmeAttrName) = Id ("$" <> coerce k)
|
mkId (k :: FixmeAttrName) = Id ("$" <> coerce k)
|
||||||
|
|
||||||
|
|
@ -72,45 +85,6 @@ instance MkId (Text,Int) where
|
||||||
instance MkId (String,Integer) where
|
instance MkId (String,Integer) where
|
||||||
mkId (p, i) = Id (fromString p <> fromString (show i))
|
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 :: Syntax c -> Maybe Text
|
||||||
fixmeHashFromSyn = \case
|
fixmeHashFromSyn = \case
|
||||||
|
|
@ -126,15 +100,15 @@ tsFromFromSyn = \case
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
|
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)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
|
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)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
|
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)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -150,16 +124,16 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
|
||||||
deriving stock (Data,Generic)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
newtype FixmeTimestamp = FixmeTimestamp Word64
|
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)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
|
|
||||||
newtype FixmeKey = FixmeKey Text
|
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)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
newtype FixmeOffset = FixmeOffset Word32
|
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 newtype (Integral,Real,Enum)
|
||||||
deriving stock (Data,Generic)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
|
|
@ -168,7 +142,7 @@ data Fixme =
|
||||||
Fixme
|
Fixme
|
||||||
{ fixmeTag :: FixmeTag
|
{ fixmeTag :: FixmeTag
|
||||||
, fixmeTitle :: FixmeTitle
|
, fixmeTitle :: FixmeTitle
|
||||||
, fixmeKey :: Maybe FixmeKey
|
, fixmeKey :: FixmeKey
|
||||||
, fixmeTs :: Maybe FixmeTimestamp
|
, fixmeTs :: Maybe FixmeTimestamp
|
||||||
, fixmeStart :: Maybe FixmeOffset
|
, fixmeStart :: Maybe FixmeOffset
|
||||||
, fixmeEnd :: Maybe FixmeOffset
|
, fixmeEnd :: Maybe FixmeOffset
|
||||||
|
|
@ -178,7 +152,7 @@ data Fixme =
|
||||||
deriving stock (Ord,Eq,Show,Data,Generic)
|
deriving stock (Ord,Eq,Show,Data,Generic)
|
||||||
|
|
||||||
instance Monoid Fixme where
|
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
|
instance Semigroup Fixme where
|
||||||
(<>) a b = b { fixmeTs = fixmeTs b <|> fixmeTs a
|
(<>) a b = b { fixmeTs = fixmeTs b <|> fixmeTs a
|
||||||
|
|
@ -190,13 +164,68 @@ instance Semigroup Fixme where
|
||||||
, fixmeAttr = fixmeAttr a <> fixmeAttr b
|
, 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)
|
newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
|
||||||
deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
|
deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
|
||||||
deriving stock (Data,Generic)
|
deriving stock (Data,Generic)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
type FixmePerks m = ( MonadUnliftIO m
|
type FixmePerks m = ( MonadUnliftIO m
|
||||||
, MonadIO m
|
, MonadIO m
|
||||||
)
|
)
|
||||||
|
|
@ -235,13 +264,31 @@ instance MkKey (FromFixmeKey Fixme) where
|
||||||
maybe k2 (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr)
|
maybe k2 (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr)
|
||||||
where k2 = mappend "A" $ serialise fx & LBS.toStrict
|
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
|
instance Pretty CompactAction where
|
||||||
pretty = \case
|
pretty = \case
|
||||||
Deleted s r -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r ]
|
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 ]
|
Modified s r k v -> pretty $ mkList @C [ mkSym "modified", mkInt s, mkStr r, mkStr k, mkStr v ]
|
||||||
-- FIXME: normal-pretty-instance
|
-- FIXME: normal-pretty-instance
|
||||||
e@(Added w fx) -> do
|
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
|
instance Serialise CompactAction
|
||||||
|
|
||||||
|
|
@ -280,6 +327,11 @@ instance Monoid FixmeOpts where
|
||||||
instance Semigroup FixmeOpts where
|
instance Semigroup FixmeOpts where
|
||||||
(<>) _ b = FixmeOpts (fixmeOptNoEvolve b)
|
(<>) _ b = FixmeOpts (fixmeOptNoEvolve b)
|
||||||
|
|
||||||
|
data PeerNotConnected = PeerNotConnected
|
||||||
|
deriving (Show,Typeable)
|
||||||
|
|
||||||
|
instance Exception PeerNotConnected
|
||||||
|
|
||||||
data FixmeEnv =
|
data FixmeEnv =
|
||||||
FixmeEnv
|
FixmeEnv
|
||||||
{ fixmeLock :: MVar ()
|
{ fixmeLock :: MVar ()
|
||||||
|
|
@ -288,18 +340,24 @@ data FixmeEnv =
|
||||||
, fixmeEnvDb :: TVar (Maybe DBPipeEnv)
|
, fixmeEnvDb :: TVar (Maybe DBPipeEnv)
|
||||||
, fixmeEnvGitDir :: TVar (Maybe FilePath)
|
, fixmeEnvGitDir :: TVar (Maybe FilePath)
|
||||||
, fixmeEnvFileMask :: TVar [FilePattern]
|
, fixmeEnvFileMask :: TVar [FilePattern]
|
||||||
|
, fixmeEnvFileExclude :: TVar [FilePattern]
|
||||||
, fixmeEnvTags :: TVar (HashSet FixmeTag)
|
, fixmeEnvTags :: TVar (HashSet FixmeTag)
|
||||||
, fixmeEnvAttribs :: TVar (HashSet FixmeAttrName)
|
, fixmeEnvAttribs :: TVar (HashSet FixmeAttrName)
|
||||||
, fixmeEnvAttribValues :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
|
, fixmeEnvAttribValues :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
|
||||||
, fixmeEnvDefComments :: TVar (HashSet Text)
|
, fixmeEnvDefComments :: TVar (HashSet Text)
|
||||||
, fixmeEnvFileComments :: TVar (HashMap FilePath (HashSet Text))
|
, fixmeEnvFileComments :: TVar (HashMap FilePath (HashSet Text))
|
||||||
, fixmeEnvGitScanDays :: TVar (Maybe Integer)
|
, fixmeEnvGitScanDays :: TVar (Maybe Integer)
|
||||||
|
, fixmeEnvScanMagic :: TVar (Maybe HashRef)
|
||||||
, fixmeEnvUpdateActions :: TVar [UpdateAction]
|
, fixmeEnvUpdateActions :: TVar [UpdateAction]
|
||||||
, fixmeEnvReadLogActions :: TVar [ReadLogAction]
|
, fixmeEnvReadLogActions :: TVar [ReadLogAction]
|
||||||
, fixmeEnvCatAction :: TVar CatAction
|
, fixmeEnvCatAction :: TVar CatAction
|
||||||
, fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate)
|
, fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate)
|
||||||
, fixmeEnvMacro :: TVar (HashMap Id (Syntax C))
|
, fixmeEnvMacro :: TVar (HashMap Id (Syntax C))
|
||||||
, fixmeEnvCatContext :: TVar (Int,Int)
|
, 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}|])
|
<&> fmap (\d -> [qc|--git-dir {d}|])
|
||||||
<&> fromMaybe ""
|
<&> 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 }
|
newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
|
||||||
deriving newtype ( Applicative
|
deriving newtype ( Applicative
|
||||||
, Functor
|
, 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 =
|
fixmeEnvBare =
|
||||||
FixmeEnv
|
FixmeEnv
|
||||||
<$> newMVar ()
|
<$> newMVar ()
|
||||||
|
|
@ -348,23 +412,26 @@ fixmeEnvBare =
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO builtinAttribs
|
||||||
|
<*> newTVarIO builtinAttribVals
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO defCommentMap
|
<*> newTVarIO defCommentMap
|
||||||
<*> newTVarIO Nothing
|
<*> newTVarIO Nothing
|
||||||
|
<*> newTVarIO mzero
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO (CatAction $ \_ _ -> pure ())
|
<*> newTVarIO (CatAction $ \_ _ -> pure ())
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO (1,3)
|
<*> newTVarIO (1,3)
|
||||||
|
<*> newTVarIO mzero
|
||||||
|
<*> newTVarIO mzero
|
||||||
|
<*> newTVarIO mzero
|
||||||
|
<*> newTVarIO mzero
|
||||||
|
|
||||||
withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
|
withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
|
||||||
withFixmeEnv env what = runReaderT ( fromFixmeM what) env
|
withFixmeEnv env what = runReaderT ( fromFixmeM what) env
|
||||||
|
|
||||||
-- FIXME: move-to-suckless-conf-library
|
|
||||||
deriving newtype instance Hashable Id
|
|
||||||
|
|
||||||
instance Serialise FixmeTag
|
instance Serialise FixmeTag
|
||||||
instance Serialise FixmeTitle
|
instance Serialise FixmeTitle
|
||||||
instance Serialise FixmePlainLine
|
instance Serialise FixmePlainLine
|
||||||
|
|
@ -376,6 +443,29 @@ instance Serialise FixmeKey
|
||||||
instance Serialise Fixme
|
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
|
instance ToField GitHash where
|
||||||
toField h = toField (show $ pretty h)
|
toField h = toField (show $ pretty h)
|
||||||
|
|
||||||
|
|
@ -614,7 +704,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
|
||||||
(_,_) -> b
|
(_,_) -> b
|
||||||
|
|
||||||
fixmeDerivedFields :: Fixme -> Fixme
|
fixmeDerivedFields :: Fixme -> Fixme
|
||||||
fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
|
fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
|
||||||
where
|
where
|
||||||
email = HM.lookup "commiter-email" (fixmeAttr fx)
|
email = HM.lookup "commiter-email" (fixmeAttr fx)
|
||||||
& maybe mempty (\x -> " <" <> x <> ">")
|
& 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)) }
|
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
|
lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show
|
||||||
|
|
||||||
fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
|
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 =
|
fxCo =
|
||||||
maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter
|
maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,7 @@
|
||||||
module HBS2.CLI.Run.KeyMan
|
module HBS2.CLI.Run.KeyMan
|
||||||
(keymanEntries) where
|
( module HBS2.CLI.Run.KeyMan
|
||||||
|
, keymanNewCredentials
|
||||||
|
) where
|
||||||
|
|
||||||
import HBS2.CLI.Prelude
|
import HBS2.CLI.Prelude
|
||||||
import HBS2.CLI.Run.Internal
|
import HBS2.CLI.Run.Internal
|
||||||
|
|
|
||||||
|
|
@ -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.Prelude
|
||||||
import HBS2.CLI.Run.Internal
|
import HBS2.CLI.Run.Internal
|
||||||
|
|
|
||||||
|
|
@ -264,7 +264,6 @@ instance Asymm 'HBS2Basic where
|
||||||
instance Hashed HbSync Sign.PublicKey where
|
instance Hashed HbSync Sign.PublicKey where
|
||||||
hashObject pk = hashObject (Crypto.encode pk)
|
hashObject pk = hashObject (Crypto.encode pk)
|
||||||
|
|
||||||
|
|
||||||
pattern SignPubKeyLike :: forall {c} . PubKey 'Sign 'HBS2Basic -> Syntax c
|
pattern SignPubKeyLike :: forall {c} . PubKey 'Sign 'HBS2Basic -> Syntax c
|
||||||
pattern SignPubKeyLike x <- (
|
pattern SignPubKeyLike x <- (
|
||||||
\case
|
\case
|
||||||
|
|
@ -272,3 +271,10 @@ pattern SignPubKeyLike x <- (
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
-> Just x )
|
-> Just x )
|
||||||
|
|
||||||
|
pattern EncryptPubKeyLike :: forall {c} . PubKey 'Encrypt 'HBS2Basic -> Syntax c
|
||||||
|
pattern EncryptPubKeyLike x <- (
|
||||||
|
\case
|
||||||
|
StringLike s -> fromStringMay s
|
||||||
|
_ -> Nothing
|
||||||
|
-> Just x )
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -57,6 +57,7 @@ touch what = do
|
||||||
pwd :: MonadIO m => m FilePath
|
pwd :: MonadIO m => m FilePath
|
||||||
pwd = liftIO D.getCurrentDirectory
|
pwd = liftIO D.getCurrentDirectory
|
||||||
|
|
||||||
|
|
||||||
doesPathExist :: MonadIO m => FilePath -> m Bool
|
doesPathExist :: MonadIO m => FilePath -> m Bool
|
||||||
doesPathExist = liftIO . D.doesPathExist
|
doesPathExist = liftIO . D.doesPathExist
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -70,6 +70,22 @@ runKeymanClient action = do
|
||||||
void $ ContT $ bracket (async (runPipe db)) cancel
|
void $ ContT $ bracket (async (runPipe db)) cancel
|
||||||
lift $ withDB db (fromKeyManClient action)
|
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 .
|
loadCredentials :: forall a m .
|
||||||
( MonadIO m
|
( MonadIO m
|
||||||
, SomePubKeyPerks a
|
, SomePubKeyPerks a
|
||||||
|
|
|
||||||
|
|
@ -26,6 +26,7 @@ import HBS2.Net.Messaging.Encrypted.ByPass
|
||||||
import HBS2.Net.PeerLocator
|
import HBS2.Net.PeerLocator
|
||||||
import HBS2.Peer.Proto
|
import HBS2.Peer.Proto
|
||||||
import HBS2.Peer.Proto.RefChan qualified as R
|
import HBS2.Peer.Proto.RefChan qualified as R
|
||||||
|
import HBS2.Peer.Proto.RefChan.Adapter
|
||||||
import HBS2.Net.Proto.Notify
|
import HBS2.Net.Proto.Notify
|
||||||
import HBS2.OrDie
|
import HBS2.OrDie
|
||||||
import HBS2.Storage.Simple
|
import HBS2.Storage.Simple
|
||||||
|
|
@ -864,7 +865,7 @@ runPeer opts = Exception.handle (\e -> myException e
|
||||||
pause @'Seconds 600
|
pause @'Seconds 600
|
||||||
liftIO $ Cache.purgeExpired nbcache
|
liftIO $ Cache.purgeExpired nbcache
|
||||||
|
|
||||||
rce <- refChanWorkerEnv conf penv denv
|
rce <- refChanWorkerEnv conf penv denv refChanNotifySource
|
||||||
|
|
||||||
let refChanAdapter =
|
let refChanAdapter =
|
||||||
RefChanAdapter
|
RefChanAdapter
|
||||||
|
|
@ -872,14 +873,21 @@ runPeer opts = Exception.handle (\e -> myException e
|
||||||
, refChanSubscribed = isPolledRef @e brains "refchan"
|
, refChanSubscribed = isPolledRef @e brains "refchan"
|
||||||
, refChanWriteTran = refChanWriteTranFn rce
|
, refChanWriteTran = refChanWriteTranFn rce
|
||||||
, refChanValidatePropose = refChanValidateTranFn @e rce
|
, refChanValidatePropose = refChanValidateTranFn @e rce
|
||||||
|
-- TODO: inject-refchanUpdateNotifyCallback
|
||||||
, refChanNotifyRely = \r u -> do
|
, refChanNotifyRely = \r u -> do
|
||||||
trace "refChanNotifyRely!"
|
trace "refChanNotifyRely!"
|
||||||
refChanNotifyRelyFn @e rce r u
|
refChanNotifyRelyFn @e rce r u
|
||||||
case u of
|
case u of
|
||||||
R.Notify rr s -> do
|
R.Notify rr x -> do
|
||||||
emitNotify refChanNotifySource (RefChanNotifyKey r, RefChanNotifyData rr s)
|
emitNotify refChanNotifySource (RefChanNotifyKey r, RefChanNotifyData rr x)
|
||||||
_ -> pure ()
|
_ -> 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
|
rcw <- async $ liftIO $ runRefChanRelyWorker rce refChanAdapter
|
||||||
|
|
|
||||||
|
|
@ -29,12 +29,15 @@ import HBS2.Net.Auth.Credentials
|
||||||
import HBS2.Net.Messaging.Unix
|
import HBS2.Net.Messaging.Unix
|
||||||
import HBS2.Peer.Proto.Peer
|
import HBS2.Peer.Proto.Peer
|
||||||
import HBS2.Peer.Proto.RefChan
|
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.Net.Proto.Sessions
|
||||||
import HBS2.Storage
|
import HBS2.Storage
|
||||||
|
|
||||||
import PeerTypes hiding (downloads)
|
import PeerTypes hiding (downloads)
|
||||||
import PeerConfig
|
import PeerConfig
|
||||||
import BlockDownload
|
import BlockDownload()
|
||||||
import Brains
|
import Brains
|
||||||
|
|
||||||
import Control.Monad.Trans.Cont
|
import Control.Monad.Trans.Cont
|
||||||
|
|
@ -44,6 +47,7 @@ import Control.Exception ()
|
||||||
import Control.Monad.Except ()
|
import Control.Monad.Except ()
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Data.Coerce
|
||||||
import Data.Cache (Cache)
|
import Data.Cache (Cache)
|
||||||
import Data.Cache qualified as Cache
|
import Data.Cache qualified as Cache
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
|
@ -87,6 +91,7 @@ data RefChanWorkerEnv e =
|
||||||
{ _refChanWorkerConf :: PeerConfig
|
{ _refChanWorkerConf :: PeerConfig
|
||||||
, _refChanPeerEnv :: PeerEnv e
|
, _refChanPeerEnv :: PeerEnv e
|
||||||
, _refChanWorkerEnvDEnv :: DownloadEnv e
|
, _refChanWorkerEnvDEnv :: DownloadEnv e
|
||||||
|
, _refChanNotifySource :: SomeNotifySource (RefChanEvents e)
|
||||||
, _refChanWorkerEnvHeadQ :: TQueue (RefChanId e, RefChanHeadBlockTran e)
|
, _refChanWorkerEnvHeadQ :: TQueue (RefChanId e, RefChanHeadBlockTran e)
|
||||||
, _refChanWorkerEnvDownload :: TVar (HashMap HashRef (RefChanId e, (TimeSpec, OnDownloadComplete)))
|
, _refChanWorkerEnvDownload :: TVar (HashMap HashRef (RefChanId e, (TimeSpec, OnDownloadComplete)))
|
||||||
, _refChanWorkerEnvNotify :: TVar (HashMap (RefChanId e) ())
|
, _refChanWorkerEnvNotify :: TVar (HashMap (RefChanId e) ())
|
||||||
|
|
@ -108,9 +113,11 @@ refChanWorkerEnv :: forall m e . (MonadIO m, ForRefChans e)
|
||||||
=> PeerConfig
|
=> PeerConfig
|
||||||
-> PeerEnv e
|
-> PeerEnv e
|
||||||
-> DownloadEnv e
|
-> DownloadEnv e
|
||||||
|
-> SomeNotifySource (RefChanEvents e)
|
||||||
-> m (RefChanWorkerEnv e)
|
-> m (RefChanWorkerEnv e)
|
||||||
|
|
||||||
refChanWorkerEnv conf pe de = liftIO $ RefChanWorkerEnv @e conf pe de
|
refChanWorkerEnv conf pe de nsource =
|
||||||
|
liftIO $ RefChanWorkerEnv @e conf pe de nsource
|
||||||
<$> newTQueueIO
|
<$> newTQueueIO
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
<*> newTVarIO mempty
|
<*> newTVarIO mempty
|
||||||
|
|
@ -531,7 +538,7 @@ refChanWorker :: forall e s m . ( MonadIO m
|
||||||
-> SomeBrains e
|
-> SomeBrains e
|
||||||
-> m ()
|
-> m ()
|
||||||
|
|
||||||
refChanWorker env brains = do
|
refChanWorker env@RefChanWorkerEnv{..} brains = do
|
||||||
|
|
||||||
penv <- ask
|
penv <- ask
|
||||||
|
|
||||||
|
|
@ -559,7 +566,7 @@ refChanWorker env brains = do
|
||||||
|
|
||||||
polls <- ContT $ withAsync (refChanPoll penv)
|
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))
|
cleanup1 <- ContT $ withAsync (liftIO (cleanupRounds penv))
|
||||||
|
|
||||||
|
|
@ -633,8 +640,7 @@ refChanWorker env brains = do
|
||||||
debug $ "CLEANUP ROUND" <+> pretty x
|
debug $ "CLEANUP ROUND" <+> pretty x
|
||||||
|
|
||||||
|
|
||||||
|
refChanWriter = do
|
||||||
refChanWriter penv = do
|
|
||||||
sto <- getStorage
|
sto <- getStorage
|
||||||
forever do
|
forever do
|
||||||
pause @'Seconds 1
|
pause @'Seconds 1
|
||||||
|
|
@ -665,13 +671,17 @@ refChanWorker env brains = do
|
||||||
-- FIXME: might-be-problems-on-large-logs
|
-- FIXME: might-be-problems-on-large-logs
|
||||||
let hashesNew = HashSet.fromList (hashes <> new) & HashSet.toList
|
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
|
let pt = toPTree (MaxSize 256) (MaxNum 256) hashesNew
|
||||||
|
|
||||||
nref <- makeMerkle 0 pt $ \(_,_,bss) -> void $ liftIO $ putBlock sto bss
|
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
|
refChanPoll penv = withPeerM penv do
|
||||||
|
|
||||||
|
|
@ -724,8 +734,8 @@ refChanWorker env brains = do
|
||||||
let what = unboxSignedBox @(RefChanHeadBlock e) @s lbs
|
let what = unboxSignedBox @(RefChanHeadBlock e) @s lbs
|
||||||
|
|
||||||
notify <- atomically $ do
|
notify <- atomically $ do
|
||||||
no <- readTVar (_refChanWorkerEnvNotify env) <&> HashMap.member chan
|
no <- readTVar _refChanWorkerEnvNotify <&> HashMap.member chan
|
||||||
modifyTVar (_refChanWorkerEnvNotify env) (HashMap.delete chan)
|
modifyTVar _refChanWorkerEnvNotify (HashMap.delete chan)
|
||||||
pure no
|
pure no
|
||||||
|
|
||||||
case what of
|
case what of
|
||||||
|
|
@ -985,14 +995,34 @@ logMergeProcess penv env q = withPeerM penv do
|
||||||
|
|
||||||
unless (HashSet.null merged) do
|
unless (HashSet.null merged) do
|
||||||
|
|
||||||
|
-- FIXME: sub-optimal-partition
|
||||||
|
-- убрать этот хардкод размеров
|
||||||
|
-- он приводит к излишне мелким блокам
|
||||||
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList merged)
|
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList merged)
|
||||||
|
|
||||||
liftIO do
|
liftIO do
|
||||||
nref <- makeMerkle 0 pt $ \(_,_,bss) -> do
|
nref <- makeMerkle 0 pt $ \(_,_,bss) -> do
|
||||||
void $ putBlock sto bss
|
void $ putBlock sto bss
|
||||||
|
|
||||||
debug $ "NEW REFCHAN" <+> pretty chanKey <+> pretty nref
|
-- TODO: ASAP-emit-refchan-updated-notify
|
||||||
|
-- $workflow: wip
|
||||||
updateRef sto chanKey nref
|
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))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -158,6 +158,7 @@ library
|
||||||
HBS2.Peer.Proto.RefChan.RefChanHead
|
HBS2.Peer.Proto.RefChan.RefChanHead
|
||||||
HBS2.Peer.Proto.RefChan.RefChanNotify
|
HBS2.Peer.Proto.RefChan.RefChanNotify
|
||||||
HBS2.Peer.Proto.RefChan.RefChanUpdate
|
HBS2.Peer.Proto.RefChan.RefChanUpdate
|
||||||
|
HBS2.Peer.Proto.RefChan.Adapter
|
||||||
HBS2.Peer.Proto.AnyRef
|
HBS2.Peer.Proto.AnyRef
|
||||||
HBS2.Peer.Proto.LWWRef
|
HBS2.Peer.Proto.LWWRef
|
||||||
HBS2.Peer.Proto.LWWRef.Internal
|
HBS2.Peer.Proto.LWWRef.Internal
|
||||||
|
|
|
||||||
|
|
@ -29,9 +29,9 @@ import Codec.Serialise
|
||||||
import Data.ByteString.Lazy (ByteString)
|
import Data.ByteString.Lazy (ByteString)
|
||||||
import Data.ByteString qualified as BS
|
import Data.ByteString qualified as BS
|
||||||
|
|
||||||
|
-- TODO: rename-to-RefChanEvents
|
||||||
data RefChanEvents e =
|
-- $workflow: wip
|
||||||
RefChanOnNotify
|
data RefChanEvents e = RefChanEvents
|
||||||
|
|
||||||
instance HasProtocol UNIX (NotifyProto (RefChanEvents L4Proto) UNIX) where
|
instance HasProtocol UNIX (NotifyProto (RefChanEvents L4Proto) UNIX) where
|
||||||
type instance ProtocolId (NotifyProto (RefChanEvents L4Proto) UNIX) = 0x20e14bfa0ca1db8e
|
type instance ProtocolId (NotifyProto (RefChanEvents L4Proto) UNIX) = 0x20e14bfa0ca1db8e
|
||||||
|
|
@ -50,6 +50,12 @@ deriving newtype instance ForRefChans e => Eq (NotifyKey (RefChanEvents e))
|
||||||
|
|
||||||
data instance NotifyData (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
|
deriving Generic
|
||||||
|
|
||||||
instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e))
|
instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e))
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -8,6 +8,7 @@ import HBS2.Net.Auth.Credentials
|
||||||
import HBS2.Base58
|
import HBS2.Base58
|
||||||
import HBS2.Peer.Proto.Peer
|
import HBS2.Peer.Proto.Peer
|
||||||
import HBS2.Peer.Proto.BlockAnnounce
|
import HBS2.Peer.Proto.BlockAnnounce
|
||||||
|
import HBS2.Peer.Proto.RefChan.Adapter
|
||||||
import HBS2.Net.Proto.Sessions
|
import HBS2.Net.Proto.Sessions
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.Storage
|
import HBS2.Storage
|
||||||
|
|
|
||||||
|
|
@ -9,6 +9,7 @@ import HBS2.Net.Proto
|
||||||
import HBS2.Net.Auth.Credentials
|
import HBS2.Net.Auth.Credentials
|
||||||
import HBS2.Events
|
import HBS2.Events
|
||||||
import HBS2.Peer.Proto.Peer
|
import HBS2.Peer.Proto.Peer
|
||||||
|
import HBS2.Peer.Proto.RefChan.Adapter
|
||||||
import HBS2.Net.Proto.Sessions
|
import HBS2.Net.Proto.Sessions
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.Data.Types.SignedBox
|
import HBS2.Data.Types.SignedBox
|
||||||
|
|
|
||||||
|
|
@ -14,6 +14,7 @@ import HBS2.Net.Auth.Credentials
|
||||||
import HBS2.Base58
|
import HBS2.Base58
|
||||||
import HBS2.Events
|
import HBS2.Events
|
||||||
import HBS2.Peer.Proto.Peer
|
import HBS2.Peer.Proto.Peer
|
||||||
|
import HBS2.Peer.Proto.RefChan.Adapter
|
||||||
import HBS2.Net.Proto.Sessions
|
import HBS2.Net.Proto.Sessions
|
||||||
import HBS2.Data.Types.Refs
|
import HBS2.Data.Types.Refs
|
||||||
import HBS2.Data.Types.SignedBox
|
import HBS2.Data.Types.SignedBox
|
||||||
|
|
|
||||||
|
|
@ -12,7 +12,6 @@ module HBS2.Peer.Proto.RefChan.Types
|
||||||
import HBS2.Prelude.Plated
|
import HBS2.Prelude.Plated
|
||||||
import HBS2.Hash
|
import HBS2.Hash
|
||||||
import HBS2.Data.Detect
|
import HBS2.Data.Detect
|
||||||
import HBS2.Clock
|
|
||||||
import HBS2.Net.Proto
|
import HBS2.Net.Proto
|
||||||
import HBS2.Net.Auth.Credentials
|
import HBS2.Net.Auth.Credentials
|
||||||
import HBS2.Base58
|
import HBS2.Base58
|
||||||
|
|
@ -37,12 +36,10 @@ import Data.HashMap.Strict qualified as HashMap
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.HashSet qualified as HashSet
|
import Data.HashSet qualified as HashSet
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Either
|
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Lens.Micro.Platform
|
import Lens.Micro.Platform
|
||||||
import Data.Hashable hiding (Hashed)
|
import Data.Hashable hiding (Hashed)
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
import Data.List qualified as List
|
|
||||||
import Codec.Serialise
|
import Codec.Serialise
|
||||||
|
|
||||||
{- HLINT ignore "Use newtype instead of data" -}
|
{- HLINT ignore "Use newtype instead of data" -}
|
||||||
|
|
@ -382,15 +379,6 @@ data RefChanHead e =
|
||||||
|
|
||||||
instance ForRefChans e => Serialise (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
|
class HasRefChanId e p | p -> e where
|
||||||
getRefChanId :: p -> RefChanId e
|
getRefChanId :: p -> RefChanId e
|
||||||
|
|
|
||||||
|
|
@ -128,7 +128,6 @@ executable test-udp
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
||||||
-- type: exitcode-stdio-1.0
|
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: TestUDP.hs
|
main-is: TestUDP.hs
|
||||||
|
|
||||||
|
|
@ -866,7 +865,6 @@ executable test-notify
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
hs-source-dirs: test/notify-unix
|
hs-source-dirs: test/notify-unix
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
@ -910,7 +908,6 @@ executable test-playground
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
hs-source-dirs: test/playground
|
hs-source-dirs: test/playground
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
@ -961,7 +958,6 @@ executable test-pipe-mess
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: TestPipeMessaging.hs
|
main-is: TestPipeMessaging.hs
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
@ -1082,3 +1078,48 @@ executable test-lsw-write
|
||||||
, timeit
|
, 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
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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]
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue