mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
d9785f1930
commit
e3655a8eb2
|
|
@ -23,6 +23,8 @@ fixme-value-set scope mvp-0 mvp-1 backlog
|
|||
|
||||
fixme-files **/*.txt docs/devlog.md
|
||||
fixme-files **/*.hs
|
||||
fixme-exclude **/.**
|
||||
fixme-exclude dist-newstyle
|
||||
|
||||
fixme-file-comments "*.scm" ";"
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ import Fixme.Types
|
|||
|
||||
import HBS2.System.Dir
|
||||
import System.Environment
|
||||
import System.Directory
|
||||
import System.Directory (getXdgDirectory, XdgDirectory(..))
|
||||
|
||||
binName :: FixmePerks m => m FilePath
|
||||
binName = liftIO getProgName
|
||||
|
|
@ -16,6 +16,9 @@ localConfigDir = do
|
|||
b <- binName
|
||||
pure (p </> ("." <> b))
|
||||
|
||||
fixmeWorkDir :: FixmePerks m => m FilePath
|
||||
fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
|
||||
|
||||
localConfig:: FixmePerks m => m FilePath
|
||||
localConfig = localConfigDir <&> (</> "config")
|
||||
|
||||
|
|
|
|||
|
|
@ -10,6 +10,8 @@ import Fixme.Scan.Git.Local as Git
|
|||
import Fixme.Scan as Scan
|
||||
import Fixme.Log
|
||||
|
||||
import Data.Config.Suckless.Script.File
|
||||
|
||||
import HBS2.KeyMan.Keys.Direct
|
||||
|
||||
import HBS2.Git.Local.CLI
|
||||
|
|
@ -59,6 +61,8 @@ 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" -}
|
||||
|
||||
|
||||
|
|
@ -121,8 +125,10 @@ runFixmeCLI m = do
|
|||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO defCommentMap
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO mzero
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO defaultCatAction
|
||||
|
|
@ -163,7 +169,7 @@ silence = do
|
|||
setLoggingOff @TRACE
|
||||
|
||||
|
||||
readConfig :: FixmePerks m => FixmeM m [Syntax C]
|
||||
readConfig :: (FixmePerks m) => FixmeM m [Syntax C]
|
||||
readConfig = do
|
||||
|
||||
user <- userConfigs
|
||||
|
|
@ -175,6 +181,8 @@ readConfig = do
|
|||
<&> parseTop
|
||||
>>= either (error.show) pure
|
||||
|
||||
updateScanMagic
|
||||
|
||||
pure $ mconcat w
|
||||
|
||||
|
||||
|
|
@ -223,16 +231,26 @@ runTop forms = do
|
|||
|
||||
entry $ bindMatch "fixme-attribs" $ nil_ \case
|
||||
StringLikeList xs -> do
|
||||
w <- fixmeWorkDir
|
||||
ta <- lift $ asks fixmeEnvAttribs
|
||||
atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
|
||||
atomically $ modifyTVar ta (<> HS.fromList (fmap (fromString . (</> w)) xs))
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
|
||||
entry $ bindMatch "fixme-files" $ nil_ \case
|
||||
StringLikeList xs -> do
|
||||
w <- fixmeWorkDir
|
||||
t <- lift $ asks fixmeEnvFileMask
|
||||
atomically (modifyTVar t (<> xs))
|
||||
atomically (modifyTVar t (<> fmap (w </>) xs))
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "fixme-exclude" $ nil_ \case
|
||||
StringLikeList xs -> do
|
||||
w <- fixmeWorkDir
|
||||
t <- lift $ asks fixmeEnvFileExclude
|
||||
atomically (modifyTVar t (<> fmap (w </>) xs))
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
|
|
@ -291,29 +309,55 @@ runTop forms = do
|
|||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "dump" $ nil_ \case
|
||||
[FixmeHashLike h] -> do
|
||||
lift $ dumpFixme h
|
||||
entry $ bindMatch "fixme:scan-magic" $ nil_ $ const do
|
||||
magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
|
||||
liftIO $ print $ pretty magic
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
entry $ bindMatch "fixme:path" $ nil_ $ const do
|
||||
path <- lift fixmeWorkDir
|
||||
liftIO $ print $ pretty path
|
||||
|
||||
entry $ bindMatch "cat" $ nil_ \case
|
||||
[SymbolVal "metadata", FixmeHashLike hash] -> do
|
||||
lift $ catFixmeMetadata hash
|
||||
entry $ bindMatch "fixme:files" $ nil_ $ const do
|
||||
w <- lift fixmeWorkDir
|
||||
incl <- lift (asks fixmeEnvFileMask >>= readTVarIO)
|
||||
excl <- lift (asks fixmeEnvFileExclude >>= readTVarIO)
|
||||
glob incl excl w $ \fn -> do
|
||||
liftIO $ putStrLn (makeRelative w fn)
|
||||
pure True
|
||||
|
||||
[FixmeHashLike hash] -> do
|
||||
lift $ catFixme hash
|
||||
entry $ bindMatch "fixme:state:drop" $ nil_ $ const $ lift do
|
||||
cleanupDatabase
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
entry $ bindMatch "fixme:state:cleanup" $ nil_ $ const $ lift do
|
||||
cleanupDatabase
|
||||
|
||||
entry $ bindMatch "report" $ nil_ \case
|
||||
[] -> lift $ list_ Nothing ()
|
||||
entry $ bindMatch "fixme:scan:import" $ nil_ $ const $ lift do
|
||||
fxs0 <- scanFiles
|
||||
|
||||
(SymbolVal "--template" : StringLike name : query) -> do
|
||||
lift $ list_ (Just (fromString name)) query
|
||||
fxs <- flip filterM fxs0 $ \fme -> do
|
||||
let fn = HM.lookup "file" (fixmeAttr fme) <&> Text.unpack . coerce
|
||||
seen <- maybe1 fn (pure False) selectIsAlreadyScanned
|
||||
pure (not seen)
|
||||
|
||||
query -> do
|
||||
lift $ list_ mzero query
|
||||
withState $ transactional do
|
||||
for_ fxs $ \fme -> do
|
||||
notice $ "fixme" <+> pretty (fixmeKey fme)
|
||||
insertFixme fme
|
||||
-- TODO: remove-code-duplucation
|
||||
let fn = HM.lookup "file" (fixmeAttr fme) <&> Text.unpack . coerce
|
||||
for_ fn insertScanned
|
||||
|
||||
entry $ bindMatch "fixme:scan:list" $ nil_ $ const do
|
||||
fxs <- lift scanFiles
|
||||
for_ fxs $ \fme -> do
|
||||
liftIO $ print $ pretty fme
|
||||
|
||||
-- TODO: some-shit
|
||||
-- one
|
||||
|
||||
|
||||
-- TODO: some-shit
|
||||
-- two
|
||||
|
||||
entry $ bindMatch "env:show" $ nil_ $ const $ do
|
||||
lift printEnv
|
||||
|
|
@ -334,87 +378,13 @@ runTop forms = do
|
|||
co <- lift listCommits <&> fmap (mkStr @C . view _1)
|
||||
pure $ mkList co
|
||||
|
||||
entry $ bindMatch "git:refs" $ const do
|
||||
refs <- lift $ listRefs False
|
||||
|
||||
elems <- for refs $ \(h,r) -> do
|
||||
pure $ mkList @C [mkStr h, mkSym ".", mkStr r]
|
||||
|
||||
pure $ mkList elems
|
||||
|
||||
-- TODO: implement-fixme:refchan:export
|
||||
entry $ bindMatch "fixme:refchan:export" $ nil_ \case
|
||||
_ -> none
|
||||
|
||||
-- TODO: implement-fixme:refchan:import
|
||||
|
||||
entry $ bindMatch "fixme:log:export" $ nil_ \case
|
||||
[StringLike fn] -> do
|
||||
lift $ exportToLog fn
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "fixme:log:import" $ nil_ \case
|
||||
[StringLike fn] -> lift do
|
||||
env <- ask
|
||||
d <- readTVarIO tvd
|
||||
importFromLog fn $ \ins -> do
|
||||
void $ run d ins
|
||||
updateIndexes
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "fixme:list:poor" $ nil_ $ const do
|
||||
fme <- lift listFixmies
|
||||
pure ()
|
||||
|
||||
entry $ bindMatch "deleted" $ nil_ $ \case
|
||||
[TimeStampLike _, FixmeHashLike hash] -> lift do
|
||||
trace $ red "deleted" <+> pretty hash
|
||||
deleteFixme hash
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
entry $ bindMatch "modified" $ nil_ $ \case
|
||||
[TimeStampLike _, FixmeHashLike hash, StringLike a, StringLike b] -> do
|
||||
trace $ red "modified!" <+> pretty hash <+> pretty a <+> pretty b
|
||||
lift $ updateFixme Nothing hash (fromString a) (fromString b)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
entry $ bindMatch "delete" $ nil_ \case
|
||||
[FixmeHashLike hash] -> lift $ delete hash
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "modify" $ nil_ \case
|
||||
[FixmeHashLike hash, StringLike a, StringLike b] -> do
|
||||
lift $ modify_ hash a b
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "fixme:stage:show" $ nil_ $ const do
|
||||
stage <- lift selectStage
|
||||
liftIO $ print $ vcat (fmap pretty stage)
|
||||
|
||||
entry $ bindMatch "fixme:state:drop" $ nil_ $ const do
|
||||
lift cleanupDatabase
|
||||
|
||||
entry $ bindMatch "fixme:state:clean" $ nil_ $ const do
|
||||
lift cleanupDatabase
|
||||
|
||||
entry $ bindMatch "fixme:stage:drop" $ nil_ $ const do
|
||||
lift cleanStage
|
||||
|
||||
entry $ bindMatch "fixme:stage:clean" $ nil_ $ const do
|
||||
lift cleanStage
|
||||
|
||||
entry $ bindMatch "fixme:config:path" $ const do
|
||||
co <- localConfig
|
||||
pure $ mkStr @C co
|
||||
|
||||
entry $ bindMatch "git:import" $ nil_ $ const do
|
||||
lift $ scanGitLocal mempty Nothing
|
||||
error "not implemented yet"
|
||||
-- lift $ scanGitLocal mempty Nothing
|
||||
|
||||
entry $ bindMatch "git:blobs" $ \_ -> do
|
||||
blobs <- lift listRelevantBlobs
|
||||
|
|
@ -436,11 +406,11 @@ runTop forms = do
|
|||
|
||||
notice $ "1. read refchan" <+> pretty (AsBase58 rchan)
|
||||
|
||||
fxs <- lift $ selectFixmeThin ()
|
||||
-- fxs <- lift $ selectFixmeThin ()
|
||||
|
||||
for_ fxs $ \(FixmeThin x) -> void $ runMaybeT do
|
||||
h <- HM.lookup "fixme-hash" x & toMPlus
|
||||
notice $ pretty h
|
||||
-- for_ fxs $ \(FixmeThin x) -> void $ runMaybeT do
|
||||
-- h <- HM.lookup "fixme-hash" x & toMPlus
|
||||
-- notice $ pretty h
|
||||
|
||||
notice "2. read issues from state"
|
||||
notice "3. discover new issues"
|
||||
|
|
|
|||
|
|
@ -20,7 +20,9 @@ import HBS2.Storage
|
|||
import HBS2.Storage.Compact
|
||||
import HBS2.System.Dir
|
||||
import DBPipe.SQLite hiding (field)
|
||||
|
||||
import Data.Config.Suckless
|
||||
import Data.Config.Suckless.Script.File
|
||||
|
||||
import Data.Aeson.Encode.Pretty as Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
@ -46,6 +48,8 @@ import Control.Monad.Trans.Cont
|
|||
import Control.Monad.Trans.Maybe
|
||||
import System.IO.Temp as Temp
|
||||
import System.IO qualified as IO
|
||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||
import System.Directory (getModificationTime)
|
||||
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
|
@ -53,6 +57,8 @@ 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
|
||||
|
|
@ -93,6 +99,7 @@ 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
|
||||
|
|
@ -110,6 +117,9 @@ printEnv = do
|
|||
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
|
||||
|
||||
|
|
@ -144,182 +154,44 @@ printEnv = do
|
|||
liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
|
||||
|
||||
|
||||
exportToLog :: FixmePerks m => FilePath -> FixmeM m ()
|
||||
exportToLog fn = do
|
||||
e <- getEpoch
|
||||
warn $ red "EXPORT-FIXMIES" <+> pretty fn
|
||||
sto <- compactStorageOpen @HbSync mempty fn
|
||||
fx <- selectFixmeThin ()
|
||||
for_ fx $ \(FixmeThin m) -> void $ runMaybeT do
|
||||
h <- HM.lookup "fixme-hash" m & toMPlus
|
||||
loaded <- lift (selectFixme (coerce h)) >>= toMPlus
|
||||
let what = Added e loaded
|
||||
let k = mkKey what
|
||||
get sto k >>= guard . isNothing
|
||||
put sto (mkKey what) (LBS.toStrict $ serialise what)
|
||||
warn $ red "export" <+> pretty h
|
||||
scanFiles :: FixmePerks m => FixmeM m [Fixme]
|
||||
scanFiles = do
|
||||
w <- fixmeWorkDir
|
||||
incl <- asks fixmeEnvFileMask >>= readTVarIO
|
||||
excl <- asks fixmeEnvFileExclude >>= readTVarIO
|
||||
|
||||
what <- selectStage
|
||||
keys <- newTVarIO (mempty :: HashMap Text Integer)
|
||||
|
||||
for_ what $ \w -> do
|
||||
let k = mkKey w
|
||||
v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
|
||||
case v0 of
|
||||
Nothing -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
S.toList_ do
|
||||
|
||||
Just (Left{}) -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
glob incl excl w $ \fn -> do
|
||||
|
||||
Just (Right prev) | getSequence w > getSequence prev -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
ts <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds
|
||||
|
||||
_ -> pure ()
|
||||
let fnShort = makeRelative w fn
|
||||
|
||||
compactStorageClose sto
|
||||
lbs <- liftIO (try @_ @IOException $ LBS.readFile fn)
|
||||
<&> fromRight mempty
|
||||
|
||||
cleanStage
|
||||
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 = Just 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
|
||||
|
||||
|
||||
sanitizeLog :: [Syntax c] -> [Syntax c]
|
||||
sanitizeLog lls = flip filter lls $ \case
|
||||
ListVal (SymbolVal "deleted" : _) -> True
|
||||
ListVal (SymbolVal "modified" : _) -> True
|
||||
_ -> False
|
||||
|
||||
importFromLog :: FixmePerks m
|
||||
=> FilePath
|
||||
-> ([Syntax C] -> FixmeM m ())
|
||||
-> FixmeM m ()
|
||||
importFromLog fn runIns = 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
|
||||
debug $ 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
|
||||
|
||||
runIns (sanitizeLog $ mconcat w)
|
||||
|
||||
unless (List.null toImport) do
|
||||
updateIndexes
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
|
||||
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
|
||||
|
||||
dumpFixme :: FixmePerks m => Text -> FixmeM m ()
|
||||
dumpFixme hash = do
|
||||
flip runContT pure do
|
||||
mha <- lift $ selectFixmeHash hash
|
||||
ha <- ContT $ maybe1 mha (pure ())
|
||||
fme' <- lift $ selectFixme ha
|
||||
liftIO $ print $ pretty fme'
|
||||
|
||||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
{-# Language MultiWayIf #-}
|
||||
module Fixme.Scan (scanBlob,scanMagic) where
|
||||
module Fixme.Scan (scanBlob,scanMagic,updateScanMagic) where
|
||||
|
||||
import Fixme.Prelude hiding (indent)
|
||||
import Fixme.Types
|
||||
|
|
@ -57,16 +57,23 @@ scanMagic :: FixmePerks m => FixmeM m HashRef
|
|||
scanMagic = do
|
||||
env <- ask
|
||||
w <- atomically do
|
||||
tagz <- fixmeEnvTags env & readTVar
|
||||
co <- fixmeEnvDefComments env & readTVar
|
||||
tagz <- fixmeEnvTags env & readTVar
|
||||
co <- fixmeEnvDefComments env & readTVar
|
||||
fco <- fixmeEnvFileComments env & readTVar
|
||||
m <- fixmeEnvFileMask env & readTVar
|
||||
e <- fixmeEnvFileExclude env & readTVar
|
||||
a <- fixmeEnvAttribs env & readTVar
|
||||
v <- fixmeEnvAttribValues env & readTVar
|
||||
|
||||
pure $ serialise (tagz, co, fco, m, a, v)
|
||||
pure $ serialise (tagz, co, fco, m, e, a, v)
|
||||
pure $ HashRef $ hashObject w
|
||||
|
||||
updateScanMagic :: (FixmePerks m) => FixmeM m ()
|
||||
updateScanMagic = do
|
||||
t <- asks fixmeEnvScanMagic
|
||||
magic <- scanMagic
|
||||
atomically $ writeTVar t (Just magic)
|
||||
|
||||
scanBlob :: forall m . FixmePerks m
|
||||
=> Maybe FilePath -- ^ filename to detect type
|
||||
-> ByteString -- ^ content
|
||||
|
|
|
|||
|
|
@ -115,27 +115,6 @@ listCommits = do
|
|||
|
||||
spec = sq <> delims " \t"
|
||||
|
||||
|
||||
listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)]
|
||||
listRefs every = do
|
||||
gd <- fixmeGetGitDirCLIOpt
|
||||
gitRunCommand [qc|git {gd} show-ref --dereference|]
|
||||
<&> fromRight mempty
|
||||
<&> fmap LBS8.words . LBS8.lines
|
||||
<&> mapMaybe
|
||||
(\case
|
||||
[h,b] -> (,) <$> fromStringMay @GitHash (LBS8.unpack h) <*> pure (GitRef (LBS8.toStrict b))
|
||||
_ -> Nothing
|
||||
)
|
||||
>>= filterM filt
|
||||
|
||||
where
|
||||
filt _ | every = pure True
|
||||
|
||||
filt (h,_) = do
|
||||
done <- withState $ isProcessed $ ViaSerialise h
|
||||
pure (not done)
|
||||
|
||||
listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m [(FilePath,GitHash)]
|
||||
listBlobs co = do
|
||||
gd <- fixmeGetGitDirCLIOpt
|
||||
|
|
@ -166,60 +145,6 @@ filterBlobs xs = do
|
|||
pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
|
||||
filterBlobs0 pat xs
|
||||
|
||||
|
||||
scanGitLogLocal :: FixmePerks m
|
||||
=> FilePath
|
||||
-> ( CompactStorage HbSync -> FixmeM m () )
|
||||
-> FixmeM m ()
|
||||
scanGitLogLocal refMask play = do
|
||||
warn $ red "scanGitLogLocal" <+> pretty refMask
|
||||
|
||||
(t,refs) <- timeItT $ listRefs False
|
||||
|
||||
let hashes = fmap fst refs
|
||||
|
||||
warn $ yellow "listRefs in" <+> pretty (realToFrac t :: Fixed E6)
|
||||
|
||||
let pat = [(True, refMask)]
|
||||
|
||||
-- FIXME: use-cache-to-skip-already-processed-tips
|
||||
logz <- withState do
|
||||
S.toList_ $ for_ hashes $ \h -> do
|
||||
done <- lift $ isProcessed (ViaSerialise h)
|
||||
unless done do
|
||||
blobs <- lift $ lift $ (listBlobs h >>= filterBlobs0 pat)
|
||||
when (List.null blobs) do
|
||||
lift $ insertProcessed (ViaSerialise h)
|
||||
for_ blobs $ \(_,b) -> do
|
||||
S.yield (h,b)
|
||||
|
||||
warn $ yellow "STEP 3" <+> "for each tree --- find log"
|
||||
|
||||
warn $ vcat (fmap pretty logz)
|
||||
|
||||
warn $ yellow "STEP 4" <+> "for each log --- scan log"
|
||||
|
||||
withState $ transactional do
|
||||
|
||||
flip runContT pure do
|
||||
for_ logz $ \(commitHash, h) -> callCC \shit -> do
|
||||
warn $ blue "SCAN BLOB" <+> pretty h
|
||||
tmp <- ContT $ bracket (liftIO (emptySystemTempFile "fixme-log")) rm
|
||||
blob <- lift $ lift $ gitCatBlob h
|
||||
liftIO (LBS8.writeFile tmp blob)
|
||||
|
||||
esto <- lift $ try @_ @CompactStorageOpenError $ compactStorageOpen @HbSync readonly tmp
|
||||
|
||||
-- skip even problematic commit
|
||||
lift $ insertProcessed (ViaSerialise commitHash)
|
||||
|
||||
either (const $ warn $ "skip malformed/unknown log" <+> pretty h) (const none) esto
|
||||
sto <- either (const $ shit ()) pure esto
|
||||
|
||||
lift $ lift $ play sto
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
listRelevantBlobs :: FixmePerks m
|
||||
=> FixmeM m [(FilePath, GitHash)]
|
||||
listRelevantBlobs = do
|
||||
|
|
@ -265,219 +190,6 @@ listFixmies = do
|
|||
|
||||
pure mempty
|
||||
|
||||
scanGitLocal :: FixmePerks m
|
||||
=> [ScanGitArgs]
|
||||
-> Maybe FilePath
|
||||
-> FixmeM m ()
|
||||
scanGitLocal args p = do
|
||||
|
||||
env <- ask
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
(dbFn, _) <- ContT $ withSystemTempFile "fixme-db" . curry
|
||||
|
||||
tempDb <- newDBPipeEnv dbPipeOptsDef dbFn
|
||||
|
||||
withDB tempDb do
|
||||
ddl [qc| create table co
|
||||
( cohash text not null
|
||||
, ts int null
|
||||
, primary key (cohash)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc| create table coattr
|
||||
( cohash text not null
|
||||
, name text not null
|
||||
, value text not null
|
||||
, primary key (cohash,name)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc| create table blob
|
||||
( hash text not null
|
||||
, cohash text not null
|
||||
, path text not null
|
||||
, primary key (hash,cohash,path)
|
||||
)
|
||||
|]
|
||||
|
||||
-- update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|]
|
||||
|
||||
let onlyNewCommits xs
|
||||
| ScanAllCommits `elem` args = pure xs
|
||||
| otherwise = lift $ filterM (newCommit . view _1) xs
|
||||
|
||||
co <- lift listCommits >>= onlyNewCommits
|
||||
|
||||
lift do
|
||||
withDB tempDb $ transactional do
|
||||
for_ co $ \(commit, attr) -> do
|
||||
|
||||
debug $ "commit" <+> pretty commit
|
||||
|
||||
blobs <- lift $ listBlobs commit >>= withFixmeEnv env . filterBlobs
|
||||
|
||||
let ts = HM.lookup "commit-time" attr
|
||||
>>= readMay @Word64 . Text.unpack . coerce
|
||||
|
||||
insert [qc|
|
||||
insert into co (cohash,ts) values (?,?) on conflict (cohash) do nothing
|
||||
|] (commit,ts)
|
||||
|
||||
for_ (HM.toList attr) $ \(a,b) -> do
|
||||
insert [qc|
|
||||
insert into coattr(cohash,name,value) values(?,?,?)
|
||||
on conflict (cohash,name) do nothing
|
||||
|] (commit,a,b)
|
||||
|
||||
for_ blobs $ \(fp,h) -> do
|
||||
insert [qc| insert into blob (hash,cohash,path)
|
||||
values (?,?,?)
|
||||
on conflict (hash,cohash,path) do nothing
|
||||
|] (h,commit,fp)
|
||||
|
||||
|
||||
blobs <- withDB tempDb do
|
||||
select_ @_ @(GitHash, FilePath) [qc|select distinct hash, path from blob order by path|]
|
||||
|
||||
when ( PrintBlobs `elem` args ) do
|
||||
for_ blobs $ \(h,fp) -> do
|
||||
notice $ pretty h <+> pretty fp
|
||||
|
||||
callCC \fucked -> do
|
||||
|
||||
gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
|
||||
|
||||
let ssin = getStdin gitCat
|
||||
let ssout = getStdout gitCat
|
||||
|
||||
liftIO $ IO.hSetBuffering ssin LineBuffering
|
||||
|
||||
for_ blobs $ \(h,fp) -> callCC \next -> do
|
||||
|
||||
seen <- lift (withState $ selectObjectHash h) <&> isJust
|
||||
|
||||
when seen do
|
||||
trace $ red "ALREADY SEEN BLOB" <+> pretty h
|
||||
next ()
|
||||
|
||||
liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
|
||||
prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
|
||||
|
||||
case prefix of
|
||||
[bh, "blob", ssize] -> do
|
||||
let mslen = readMay @Int (BS.unpack ssize)
|
||||
len <- ContT $ maybe1 mslen (pure ())
|
||||
blob <- liftIO $ LBS8.hGet ssout len
|
||||
void $ liftIO $ BS.hGetLine ssout
|
||||
|
||||
|
||||
poor <- lift (Scan.scanBlob (Just fp) blob)
|
||||
|
||||
rich <- withDB tempDb do
|
||||
let q = [qc|
|
||||
|
||||
WITH CommitAttributes AS (
|
||||
SELECT co.cohash, co.ts, coattr.name, coattr.value
|
||||
FROM co
|
||||
JOIN coattr ON co.cohash = coattr.cohash
|
||||
),
|
||||
MinCommitTimes AS (
|
||||
SELECT blob.hash, MIN(co.ts) as mintime
|
||||
FROM blob
|
||||
JOIN co ON blob.cohash = co.cohash
|
||||
WHERE co.ts IS NOT NULL
|
||||
GROUP BY blob.hash
|
||||
),
|
||||
RelevantCommits AS (
|
||||
SELECT blob.hash, blob.cohash, blob.path
|
||||
FROM blob
|
||||
JOIN MinCommitTimes ON blob.hash = MinCommitTimes.hash
|
||||
JOIN co ON blob.cohash = co.cohash AND co.ts = MinCommitTimes.mintime
|
||||
)
|
||||
SELECT CommitAttributes.name, CommitAttributes.value
|
||||
FROM RelevantCommits
|
||||
JOIN CommitAttributes ON RelevantCommits.cohash = CommitAttributes.cohash
|
||||
WHERE RelevantCommits.hash = ?
|
||||
|]
|
||||
|
||||
what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h)
|
||||
<&> HM.fromList
|
||||
<&> (<> HM.fromList [ ("blob",fromString $ show (pretty h))
|
||||
, ("file",fromString fp)
|
||||
])
|
||||
|
||||
for poor $ \f -> do
|
||||
let lno = maybe mempty ( HM.singleton "line"
|
||||
. FixmeAttrVal
|
||||
. Text.pack
|
||||
. show
|
||||
)
|
||||
(fixmeStart f)
|
||||
|
||||
let ts = HM.lookup "commit-time" what
|
||||
<&> Text.unpack . coerce
|
||||
>>= readMay
|
||||
<&> FixmeTimestamp
|
||||
|
||||
pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> (what <> lno)) f
|
||||
|
||||
|
||||
let fxpos1 = [ (fixmeTitle fx, [i :: Int])
|
||||
| (i,fx) <- zip [0..] rich
|
||||
-- , fixmeTitle fx /= mempty
|
||||
] & Map.fromListWith (flip (<>))
|
||||
|
||||
let mt e = do
|
||||
let seed = [ (fst e, i) | i <- snd e ]
|
||||
flip fix (0,[],seed) $ \next (num,acc,rest) ->
|
||||
case rest of
|
||||
[] -> acc
|
||||
(x:xs) -> next (succ num, (x,num) : acc, xs)
|
||||
|
||||
let fxpos2 = [ mt e
|
||||
| e <- Map.toList fxpos1
|
||||
] & mconcat
|
||||
& Map.fromList
|
||||
|
||||
fixmies <- for (zip [0..] rich) $ \(i,fx) -> do
|
||||
let title = fixmeTitle fx
|
||||
let kb = Map.lookup (title,i) fxpos2
|
||||
let ka = HM.lookup "file" (fixmeAttr fx)
|
||||
let kk = (,,) <$> ka <*> pure title <*> kb
|
||||
|
||||
case kk of
|
||||
Nothing -> pure fx
|
||||
Just (a,b,c) -> do
|
||||
let ks = [qc|{show (pretty a)}#{show (pretty b)}:{show c}|] :: Text
|
||||
let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
|
||||
let kh = HM.singleton "fixme-key" ksh
|
||||
let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
|
||||
pure $ over (field @"fixmeAttr") (<> kv) fx
|
||||
|
||||
when ( PrintFixme `elem` args ) do
|
||||
for_ fixmies $ \fixme -> do
|
||||
notice $ pretty fixme
|
||||
|
||||
when ( ScanRunDry `elem` args ) $ fucked ()
|
||||
|
||||
debug $ "actually-import-fixmies" <+> pretty h
|
||||
|
||||
lift $ withFixmeEnv env $ withState $ transactional do
|
||||
insertBlob h
|
||||
for_ fixmies insertFixme
|
||||
|
||||
_ -> fucked ()
|
||||
|
||||
unless ( ScanRunDry `elem` args ) do
|
||||
lift runLogActions
|
||||
|
||||
lift $ withFixmeEnv env $ withState $ transactional do
|
||||
for_ co $ \w -> do
|
||||
insertCommit (view _1 w)
|
||||
|
||||
|
||||
gitListStage :: (FixmePerks m)
|
||||
=> FixmeM m [Either (FilePath, GitHash) (FilePath, GitHash)]
|
||||
|
|
@ -602,16 +314,6 @@ gitExtractFileMetaData fns = do
|
|||
|
||||
pure $ HM.fromList [ (view _1 w, view _3 w) | w <- rich ]
|
||||
|
||||
-- TODO: move-outta-here
|
||||
runLogActions :: FixmePerks m => FixmeM m ()
|
||||
runLogActions = do
|
||||
debug $ yellow "runLogActions"
|
||||
actions <- asks fixmeEnvReadLogActions >>= readTVarIO
|
||||
|
||||
for_ actions $ \(ReadLogAction a) -> do
|
||||
liftIO (a (List noContext []))
|
||||
|
||||
updateIndexes
|
||||
|
||||
data GitBlobInfo = GitBlobInfo FilePath GitHash
|
||||
deriving stock (Eq,Ord,Data,Generic,Show)
|
||||
|
|
|
|||
|
|
@ -3,30 +3,10 @@
|
|||
module Fixme.State
|
||||
( evolve
|
||||
, withState
|
||||
, insertFixme
|
||||
, selectFixmeThin
|
||||
, selectFixmeHash
|
||||
, selectFixmeHashes
|
||||
, selectFixme
|
||||
, deleteFixme
|
||||
, updateFixme
|
||||
, insertCommit
|
||||
, insertBlob
|
||||
, selectObjectHash
|
||||
, newCommit
|
||||
, cleanupDatabase
|
||||
, updateIndexes
|
||||
, insertFixmeDelStaged
|
||||
, insertFixmeModStaged
|
||||
, selectStageModified
|
||||
, selectStageDeleted
|
||||
, selectStage
|
||||
, cleanStage
|
||||
, insertProcessed
|
||||
, isProcessed
|
||||
, selectProcessed
|
||||
, checkFixmeExists
|
||||
, listAllFixmeHashes
|
||||
, insertFixme
|
||||
, insertScanned
|
||||
, selectIsAlreadyScanned
|
||||
, HasPredicate(..)
|
||||
, SelectPredicate(..)
|
||||
) where
|
||||
|
|
@ -57,6 +37,8 @@ import Control.Monad.Trans.Maybe
|
|||
import Data.Coerce
|
||||
import Data.Fixed
|
||||
import Data.Word (Word64)
|
||||
import System.Directory (getModificationTime)
|
||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||
import System.TimeIt
|
||||
|
||||
-- TODO: runPipe-omitted
|
||||
|
|
@ -123,235 +105,20 @@ withState what = do
|
|||
createTables :: FixmePerks m => DBPipeM m ()
|
||||
createTables = do
|
||||
|
||||
-- тут все таблицы будут называться с префиксом
|
||||
-- fixme, что бы может быть можно было встроить
|
||||
-- в другую бд, если вдруг понадобится
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixmegitobject
|
||||
( hash text not null
|
||||
, type text null
|
||||
, primary key (hash)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixme
|
||||
( id text not null
|
||||
, ts integer
|
||||
, fixme blob not null
|
||||
, primary key (id)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixmedeleted
|
||||
( id text not null
|
||||
, ts integer not null
|
||||
, deleted bool not null
|
||||
, primary key (id,ts)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixmerel
|
||||
( origin text not null
|
||||
, related text not null
|
||||
, ts integer not null
|
||||
, reason text not null
|
||||
, primary key (origin,related,ts)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixmeattr
|
||||
( fixme text not null
|
||||
, ts integer null
|
||||
, name text not null
|
||||
, value text
|
||||
, primary key (fixme,ts,name)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc| drop view if exists fixmeattrview |]
|
||||
|
||||
let commits = [qc|name in ('commit','committer','committer-name','committer-email','commit-time')|] :: Text
|
||||
|
||||
ddl [qc|
|
||||
create view fixmeattrview as
|
||||
with ranked1 as (
|
||||
select
|
||||
fixme,
|
||||
name,
|
||||
value,
|
||||
row_number() over (partition by fixme, name order by ts desc nulls first) as rn
|
||||
from fixmeattr
|
||||
where not ({commits})
|
||||
)
|
||||
, ranked2 as (
|
||||
select
|
||||
fixme,
|
||||
name,
|
||||
value,
|
||||
row_number() over (partition by fixme, name order by ts asc nulls last) as rn
|
||||
from fixmeattr
|
||||
where ({commits})
|
||||
)
|
||||
|
||||
select distinct fixme,name,value
|
||||
from
|
||||
(
|
||||
select
|
||||
fixme,
|
||||
name,
|
||||
value
|
||||
from ranked1
|
||||
where rn = 1
|
||||
|
||||
union
|
||||
|
||||
select
|
||||
fixme,
|
||||
name,
|
||||
value
|
||||
from ranked2
|
||||
where rn = 1
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|drop view if exists fixmeactualview|]
|
||||
|
||||
ddl [qc|
|
||||
create view fixmeactualview as
|
||||
with a1 as (
|
||||
select
|
||||
a.fixme,
|
||||
f.ts,
|
||||
a.name,
|
||||
a.value
|
||||
from
|
||||
fixmeattrview a
|
||||
join fixme f on a.fixme = f.id
|
||||
where
|
||||
a.name = 'fixme-key'
|
||||
and not exists (select null from fixmedeleted d where d.id = f.id)
|
||||
),
|
||||
rn AS (
|
||||
select
|
||||
f.id,
|
||||
f.ts,
|
||||
a.value AS fixmekey,
|
||||
row_number() over (partition by a.value order by f.ts desc) as rn
|
||||
from
|
||||
fixme f
|
||||
join a1 a on f.id = a.fixme and a.name = 'fixme-key'
|
||||
)
|
||||
select id as fixme, fixmekey, ts from rn
|
||||
where rn = 1
|
||||
and not exists (
|
||||
select null
|
||||
from fixmeattr a
|
||||
join fixmedeleted d on d.id = a.fixme
|
||||
where a.name = 'fixme-key'
|
||||
and a.value = rn.fixmekey
|
||||
)
|
||||
|
||||
|]
|
||||
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixmeactual
|
||||
( fixme text not null
|
||||
, primary key (fixme)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists fixmejson
|
||||
( fixme text not null
|
||||
, fixmekey text
|
||||
, json blob
|
||||
, primary key (fixme)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create index if not exists idx_fixmekey ON fixmejson(fixmekey)
|
||||
|]
|
||||
|
||||
ddl [qc| create table if not exists fixmestagedel
|
||||
( hash text not null primary key
|
||||
, ts integer not null
|
||||
)
|
||||
ddl [qc| create table if not exists scanned
|
||||
( hash text not null primary key )
|
||||
|]
|
||||
|
||||
ddl [qc| create table if not exists fixmestagemod
|
||||
( hash text not null
|
||||
, ts integer not null
|
||||
, attr text not null
|
||||
, value text
|
||||
, primary key (hash,attr)
|
||||
ddl [qc| create table if not exists object
|
||||
( o text not null
|
||||
, w integer not null
|
||||
, k text not null
|
||||
, v blob not null
|
||||
, primary key (o,k)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc| create table if not exists fixmeprocessed
|
||||
( hash text not null
|
||||
, primary key (hash)
|
||||
)
|
||||
|]
|
||||
|
||||
-- .fixme-new/state.db
|
||||
-- and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
|
||||
|
||||
insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
|
||||
insertCommit gh = do
|
||||
insert [qc|
|
||||
insert into fixmegitobject (hash,type) values(?,'commit')
|
||||
on conflict (hash) do nothing
|
||||
|] (Only gh)
|
||||
|
||||
insertBlob :: FixmePerks m => GitHash -> DBPipeM m ()
|
||||
insertBlob gh = do
|
||||
insert [qc|
|
||||
insert into fixmegitobject (hash,type) values(?,'blob')
|
||||
on conflict (hash) do nothing
|
||||
|] (Only gh)
|
||||
|
||||
selectObjectHash :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash)
|
||||
selectObjectHash gh = do
|
||||
select [qc|select hash from fixmegitobject where hash = ?|] (Only gh)
|
||||
<&> fmap fromOnly . listToMaybe
|
||||
|
||||
newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool
|
||||
newCommit gh = isNothing <$> withState (selectObjectHash gh)
|
||||
|
||||
insertFixme :: FixmePerks m => Fixme -> DBPipeM m ()
|
||||
insertFixme fx@Fixme{..} = do
|
||||
let fixme = serialise fx
|
||||
let fxId = hashObject @HbSync fixme & HashRef
|
||||
insert [qc|insert into fixme (id, ts, fixme) values (?,?,?)
|
||||
on conflict(id) do nothing
|
||||
|] (fxId, fixmeTs, fixme)
|
||||
|
||||
for_ (HM.toList fixmeAttr) $ \(n,v) -> do
|
||||
insert [qc|
|
||||
insert into fixmeattr(fixme,ts,name,value)
|
||||
values (?,?,?,?)
|
||||
on conflict (fixme,ts,name) do update set value = excluded.value
|
||||
|] (fxId, fixmeTs, n, v)
|
||||
|
||||
insert [qc|
|
||||
insert into fixmeattr(fixme,ts,name,value)
|
||||
values (?,?,?,?)
|
||||
on conflict (fixme,ts,name) do update set value = excluded.value
|
||||
|] (fxId, fixmeTs, "fixme-tag", fixmeTag)
|
||||
|
||||
insert [qc|
|
||||
insert into fixmeattr(fixme,ts,name,value)
|
||||
values (?,?,?,?)
|
||||
on conflict (fixme,ts,name) do update set value = excluded.value
|
||||
|] (fxId, fixmeTs, "fixme-title", fixmeTitle)
|
||||
|
||||
|
||||
data SelectPredicate =
|
||||
All
|
||||
|
|
@ -410,50 +177,6 @@ instance IsContext c => HasPredicate [Syntax c] where
|
|||
{- HLINT ignore "Functor law" -}
|
||||
{- HLINT ignore "Eta reduce" -}
|
||||
|
||||
selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text)
|
||||
selectFixmeHash what = listToMaybe <$> selectFixmeHashes what
|
||||
|
||||
selectFixmeHashes :: (FixmePerks m) => Text -> FixmeM m [Text]
|
||||
selectFixmeHashes what = withState do
|
||||
let w = what <> "%"
|
||||
select @(Only Text)
|
||||
[qc| select fixme
|
||||
from fixmejson
|
||||
where json_extract(json,'$."fixme-key"') like ?
|
||||
union
|
||||
select id
|
||||
from fixme
|
||||
where id like ?
|
||||
|] (w,w)
|
||||
<&> fmap fromOnly
|
||||
|
||||
selectFixme :: FixmePerks m => Text -> FixmeM m (Maybe Fixme)
|
||||
selectFixme txt = do
|
||||
|
||||
attrs <- selectFixmeThin (FixmeHashExactly txt)
|
||||
<&> fmap coerce . headMay
|
||||
<&> fromMaybe mempty
|
||||
|
||||
runMaybeT do
|
||||
|
||||
lift (withState $ select [qc|select fixme from fixme where id = ? limit 1|] (Only txt))
|
||||
<&> listToMaybe . fmap fromOnly
|
||||
>>= toMPlus
|
||||
<&> (deserialiseOrFail @Fixme)
|
||||
>>= toMPlus
|
||||
<&> over (field @"fixmeAttr") (<> attrs)
|
||||
|
||||
|
||||
listAllFixmeHashes :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef)
|
||||
listAllFixmeHashes = withState do
|
||||
select_ @_ @(Only HashRef) [qc|select id from fixme|]
|
||||
<&> HS.fromList . fmap fromOnly
|
||||
|
||||
checkFixmeExists :: FixmePerks m => HashRef -> FixmeM m Bool
|
||||
checkFixmeExists what = withState do
|
||||
select @(Only (Maybe Int)) [qc|select 1 from fixme where id = ? limit 1|] (Only what)
|
||||
<&> not . List.null
|
||||
|
||||
data Bound = forall a . (ToField a, Show a) => Bound a
|
||||
|
||||
instance ToField Bound where
|
||||
|
|
@ -497,215 +220,70 @@ genPredQ tbl what = go what
|
|||
Ignored -> ("false", mempty)
|
||||
|
||||
|
||||
updateFixmeJson :: FixmePerks m => DBPipeM m ()
|
||||
updateFixmeJson = do
|
||||
|
||||
update_ [qc|
|
||||
|
||||
insert into fixmejson (fixme,fixmekey,json)
|
||||
with json as (
|
||||
select
|
||||
a.fixme as fixme,
|
||||
cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', f.fixme) as blob) as json
|
||||
|
||||
from
|
||||
fixmeattrview a join fixmeactual f on f.fixme = a.fixme
|
||||
|
||||
group by a.fixme
|
||||
)
|
||||
|
||||
select
|
||||
fixme
|
||||
, json_extract(json, '$."fixme-key"') as fixmekey
|
||||
, json
|
||||
from json where true
|
||||
on conflict (fixme) do update set json = excluded.json, fixmekey = excluded.fixmekey
|
||||
|]
|
||||
|
||||
|
||||
-- TODO: predicate-for-stage-toggle
|
||||
selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
|
||||
selectFixmeThin a = withState do
|
||||
|
||||
let predic = genPredQ "blob" (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
|
||||
where not exists (select null from fixmestagedel d where d.hash = m.hash)
|
||||
),
|
||||
|
||||
s2 as
|
||||
( select cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob, j.fixme as fixme
|
||||
|
||||
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
|
||||
)
|
||||
|
||||
select s2.blob from s2
|
||||
|
||||
where
|
||||
|
||||
(
|
||||
{fst predic}
|
||||
)
|
||||
|
||||
order by json_extract(blob, '$.commit-time'), json_extract(blob, '$.title')
|
||||
|
||||
|]
|
||||
|
||||
trace $ red "selectFixmeThin" <> line <> pretty sql
|
||||
|
||||
(t,r) <- timeItT $ select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly)
|
||||
|
||||
trace $ yellow "selectFixmeThin" <> line
|
||||
<> pretty sql <> line
|
||||
<> pretty (length r) <+> "rows" <> line
|
||||
<> pretty "elapsed" <+> pretty (realToFrac t :: Fixed E6)
|
||||
|
||||
pure r
|
||||
|
||||
cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
|
||||
cleanupDatabase = do
|
||||
warn $ red "cleanupDatabase"
|
||||
withState $ transactional do
|
||||
update_ [qc|delete from fixme|]
|
||||
update_ [qc|delete from fixmeattr|]
|
||||
update_ [qc|delete from fixmegitobject|]
|
||||
update_ [qc|delete from fixmedeleted|]
|
||||
update_ [qc|delete from fixmerel|]
|
||||
update_ [qc|delete from fixmeactual|]
|
||||
update_ [qc|delete from fixmejson|]
|
||||
update_ [qc|delete from fixmestagedel|]
|
||||
update_ [qc|delete from fixmestagemod|]
|
||||
|
||||
|
||||
insertFixmeModStaged :: (FixmePerks m,MonadReader FixmeEnv m)
|
||||
=> Text
|
||||
-> FixmeAttrName
|
||||
-> FixmeAttrVal
|
||||
-> m ()
|
||||
insertFixmeModStaged hash k v = withState do
|
||||
ts <- getEpoch
|
||||
insert [qc| insert into fixmestagemod (hash,ts,attr,value) values(?,?,?,?)
|
||||
on conflict (hash,attr)
|
||||
do update set hash = excluded.hash
|
||||
, ts = excluded.ts
|
||||
, attr = excluded.attr
|
||||
, value = excluded.value
|
||||
|] (hash,ts,k,v)
|
||||
|
||||
|
||||
insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||||
insertFixmeDelStaged hash = withState do
|
||||
ts <- getEpoch
|
||||
insert [qc| insert into fixmestagedel (hash,ts) values(?,?)
|
||||
on conflict (hash)
|
||||
do update set hash = excluded.hash
|
||||
, ts = excluded.ts
|
||||
|] (hash,ts)
|
||||
|
||||
|
||||
type StageModRow = (HashRef,Word64,Text,Text)
|
||||
|
||||
selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
||||
selectStageModified = withState do
|
||||
what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|]
|
||||
for what $ \(h,t,k,v) -> do
|
||||
pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v)
|
||||
|
||||
selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
||||
selectStageDeleted = withState do
|
||||
what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|]
|
||||
for what $ \(h,t) -> do
|
||||
pure $ Deleted t h
|
||||
|
||||
selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
||||
selectStage = do
|
||||
a <- selectStageModified
|
||||
b <- selectStageDeleted
|
||||
pure (a<>b)
|
||||
|
||||
cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m ()
|
||||
cleanStage = withState do
|
||||
transactional do
|
||||
update_ [qc|delete from fixmestagedel|]
|
||||
update_ [qc|delete from fixmestagemod|]
|
||||
|
||||
deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||||
deleteFixme hash = withState do
|
||||
trace $ red "deleteFixme" <+> pretty hash
|
||||
|
||||
here <- select [qc| select true
|
||||
from fixmedeleted
|
||||
where deleted and id = ?
|
||||
order by ts desc
|
||||
limit 1
|
||||
|] (Only hash) <&> isJust . listToMaybe . fmap (fromOnly @Bool)
|
||||
|
||||
unless here do
|
||||
insert [qc| insert into fixmedeleted (id,ts,deleted)
|
||||
values (?,(strftime('%s', 'now')),true)
|
||||
on conflict(id,ts) do nothing
|
||||
|] (Only hash)
|
||||
|
||||
updateFixme :: (FixmePerks m,MonadReader FixmeEnv m)
|
||||
=> Maybe FixmeTimestamp
|
||||
-> Text
|
||||
-> FixmeAttrName
|
||||
-> FixmeAttrVal
|
||||
-> m ()
|
||||
|
||||
updateFixme ts hash a b = withState do
|
||||
warn $ red "updateFixme" <+> pretty hash
|
||||
insert [qc| insert into fixmeattr (fixme,ts,name,value)
|
||||
values (?,coalesce(?,strftime('%s', 'now')),?,?)
|
||||
on conflict(fixme,ts,name) do update set value = excluded.value
|
||||
|] (hash,ts,a,b)
|
||||
|
||||
updateIndexes :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
|
||||
updateIndexes = withState $ transactional do
|
||||
update_ [qc|delete from fixmeactual|]
|
||||
update_ [qc|
|
||||
insert into fixmeactual
|
||||
select distinct fixme from fixmeactualview
|
||||
|]
|
||||
updateFixmeJson
|
||||
-- FIXME: delete-table-grows
|
||||
-- надо добавлять статус в fixmedeleted
|
||||
-- только если он отличается от последнего
|
||||
-- известного статуса
|
||||
update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|]
|
||||
|
||||
|
||||
insertProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
|
||||
=> w
|
||||
-> DBPipeM m ()
|
||||
insertProcessed what = do
|
||||
insert [qc| insert into fixmeprocessed (hash) values(?)
|
||||
on conflict (hash) do nothing
|
||||
|] (Only (show $ pretty $ hashObject @HbSync what))
|
||||
|
||||
|
||||
isProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
|
||||
=> w
|
||||
-> DBPipeM m Bool
|
||||
isProcessed what = do
|
||||
let k = show $ pretty $ hashObject @HbSync what
|
||||
select @(Only (Maybe Int)) [qc| select null from fixmeprocessed where hash = ? limit 1 |] (Only k)
|
||||
<&> isJust . listToMaybe
|
||||
|
||||
selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m)
|
||||
=> m [HashRef]
|
||||
selectProcessed = withState do
|
||||
select_ [qc|select hash from fixmeprocessed|]
|
||||
<&> fmap fromOnly
|
||||
update_ [qc|delete from object|]
|
||||
update_ [qc|delete from scanned|]
|
||||
|
||||
scannedKey :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> m HashRef
|
||||
scannedKey fme = do
|
||||
magic <- asks fixmeEnvScanMagic >>= readTVarIO
|
||||
let file = fixmeAttr fme & HM.lookup "file"
|
||||
let w = fixmeTs fme
|
||||
pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef
|
||||
|
||||
scannedKeyForFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath-> m HashRef
|
||||
scannedKeyForFile file = do
|
||||
dir <- fixmeWorkDir
|
||||
magic <- asks fixmeEnvScanMagic >>= readTVarIO
|
||||
let fn = dir </> file
|
||||
w <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds
|
||||
pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef
|
||||
|
||||
selectIsAlreadyScanned :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> m Bool
|
||||
selectIsAlreadyScanned file = withState do
|
||||
k <- lift $ scannedKeyForFile file
|
||||
what <- select @(Only Int) [qc|select 1 from scanned where hash = ? limit 1|] (Only k)
|
||||
pure $ not $ List.null what
|
||||
|
||||
insertScanned :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m ()
|
||||
insertScanned file = do
|
||||
k <- lift $ scannedKeyForFile file
|
||||
insert [qc| insert into scanned (hash)
|
||||
values(?)
|
||||
on conflict (hash) do nothing|]
|
||||
(Only k)
|
||||
|
||||
insertFixme :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> DBPipeM m ()
|
||||
insertFixme fme = do
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
o <- fixmeKey fme & toMPlus
|
||||
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.v
|
||||
else object.w
|
||||
end
|
||||
|]
|
||||
|
||||
for_ (HM.toList attrs) $ \(k,v) -> do
|
||||
lift $ insert sql (o,w,k,v)
|
||||
|
||||
lift $ insert sql (o,w,"fixme-text",txt)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ newtype FixmeTimestamp = FixmeTimestamp Word64
|
|||
|
||||
|
||||
newtype FixmeKey = FixmeKey Text
|
||||
deriving newtype (Eq,Ord,Show,ToField,FromField)
|
||||
deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty)
|
||||
deriving stock (Data,Generic)
|
||||
|
||||
newtype FixmeOffset = FixmeOffset Word32
|
||||
|
|
@ -281,12 +281,14 @@ data FixmeEnv =
|
|||
, fixmeEnvDb :: TVar (Maybe DBPipeEnv)
|
||||
, fixmeEnvGitDir :: TVar (Maybe FilePath)
|
||||
, fixmeEnvFileMask :: TVar [FilePattern]
|
||||
, fixmeEnvFileExclude :: TVar [FilePattern]
|
||||
, fixmeEnvTags :: TVar (HashSet FixmeTag)
|
||||
, fixmeEnvAttribs :: TVar (HashSet FixmeAttrName)
|
||||
, fixmeEnvAttribValues :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
|
||||
, fixmeEnvDefComments :: TVar (HashSet Text)
|
||||
, fixmeEnvFileComments :: TVar (HashMap FilePath (HashSet Text))
|
||||
, fixmeEnvGitScanDays :: TVar (Maybe Integer)
|
||||
, fixmeEnvScanMagic :: TVar (Maybe HashRef)
|
||||
, fixmeEnvUpdateActions :: TVar [UpdateAction]
|
||||
, fixmeEnvReadLogActions :: TVar [ReadLogAction]
|
||||
, fixmeEnvCatAction :: TVar CatAction
|
||||
|
|
@ -345,8 +347,10 @@ fixmeEnvBare =
|
|||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO defCommentMap
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO mzero
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO (CatAction $ \_ _ -> pure ())
|
||||
|
|
@ -631,7 +635,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
|
|||
(_,_) -> b
|
||||
|
||||
fixmeDerivedFields :: Fixme -> Fixme
|
||||
fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
|
||||
fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
|
||||
where
|
||||
email = HM.lookup "commiter-email" (fixmeAttr fx)
|
||||
& maybe mempty (\x -> " <" <> x <> ">")
|
||||
|
|
@ -641,6 +645,10 @@ fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
|
|||
|
||||
tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx)) }
|
||||
|
||||
key = maybe mempty ( HM.singleton "fixme-key" . FixmeAttrVal . coerce) (fixmeKey fx)
|
||||
|
||||
fxKey = mempty { fixmeAttr = key }
|
||||
|
||||
lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show
|
||||
|
||||
fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
|
||||
|
|
|
|||
|
|
@ -193,11 +193,11 @@
|
|||
"rev": "5a55c22750589b357e50b759d2a754df058446d6",
|
||||
"revCount": 40,
|
||||
"type": "git",
|
||||
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
|
||||
"url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
|
||||
},
|
||||
"original": {
|
||||
"type": "git",
|
||||
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
|
||||
"url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
|
||||
}
|
||||
},
|
||||
"fuzzy_2": {
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ inputs = {
|
|||
lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls";
|
||||
lsm.inputs.nixpkgs.follows = "nixpkgs";
|
||||
|
||||
fuzzy.url = "git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
|
||||
fuzzy.url = "git+https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
|
||||
fuzzy.inputs.nixpkgs.follows = "nixpkgs";
|
||||
|
||||
saltine = {
|
||||
|
|
@ -105,8 +105,6 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
|||
|
||||
];
|
||||
|
||||
shellWithHoogle = true;
|
||||
|
||||
shell = {pkgs, ...}:
|
||||
pkgs.haskellPackages.shellFor {
|
||||
packages = _: pkgs.lib.attrsets.attrVals packageNames pkgs.haskellPackages;
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@ touch what = do
|
|||
pwd :: MonadIO m => m FilePath
|
||||
pwd = liftIO D.getCurrentDirectory
|
||||
|
||||
|
||||
doesPathExist :: MonadIO m => FilePath -> m Bool
|
||||
doesPathExist = liftIO . D.doesPathExist
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue