diff --git a/.fixme-new/config b/.fixme-new/config index 548ded0e..51db0bd4 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -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" ";" diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs index db93590a..bbae5f67 100644 --- a/fixme-new/lib/Fixme/Config.hs +++ b/fixme-new/lib/Fixme/Config.hs @@ -5,7 +5,7 @@ import Fixme.Types import HBS2.System.Dir import System.Environment -import System.Directory +import System.Directory (getXdgDirectory, XdgDirectory(..)) binName :: FixmePerks m => m FilePath binName = liftIO getProgName @@ -16,6 +16,9 @@ localConfigDir = do b <- binName pure (p ("." <> b)) +fixmeWorkDir :: FixmePerks m => m FilePath +fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath + localConfig:: FixmePerks m => m FilePath localConfig = localConfigDir <&> ( "config") diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 430d8d91..e05d7d5f 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -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" diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index a333bdc7..0d12f778 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -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) - diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index 386cad6b..c9e23814 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/fixme-new/lib/Fixme/Scan.hs @@ -1,5 +1,5 @@ {-# Language MultiWayIf #-} -module Fixme.Scan (scanBlob,scanMagic) where +module Fixme.Scan (scanBlob,scanMagic,updateScanMagic) where import Fixme.Prelude hiding (indent) import Fixme.Types @@ -57,16 +57,23 @@ scanMagic :: FixmePerks m => FixmeM m HashRef scanMagic = do env <- ask w <- atomically do - tagz <- fixmeEnvTags env & readTVar - co <- fixmeEnvDefComments env & readTVar + tagz <- fixmeEnvTags env & readTVar + co <- fixmeEnvDefComments env & readTVar fco <- fixmeEnvFileComments env & readTVar m <- fixmeEnvFileMask env & readTVar + e <- fixmeEnvFileExclude env & readTVar a <- fixmeEnvAttribs env & readTVar v <- fixmeEnvAttribValues env & readTVar - pure $ serialise (tagz, co, fco, m, a, v) + pure $ serialise (tagz, co, fco, m, e, a, v) pure $ HashRef $ hashObject w +updateScanMagic :: (FixmePerks m) => FixmeM m () +updateScanMagic = do + t <- asks fixmeEnvScanMagic + magic <- scanMagic + atomically $ writeTVar t (Just magic) + scanBlob :: forall m . FixmePerks m => Maybe FilePath -- ^ filename to detect type -> ByteString -- ^ content diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index ce635c70..92f71769 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -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) diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 0709a09b..2f1e186a 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -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) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 0c427f11..a6fd8c10 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -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 } diff --git a/flake.lock b/flake.lock index 29dd091f..4b5088ab 100644 --- a/flake.lock +++ b/flake.lock @@ -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": { diff --git a/flake.nix b/flake.nix index 5e5c5adf..cf709339 100644 --- a/flake.nix +++ b/flake.nix @@ -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; diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index c9bc2c58..25e44bd5 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -57,6 +57,7 @@ touch what = do pwd :: MonadIO m => m FilePath pwd = liftIO D.getCurrentDirectory + doesPathExist :: MonadIO m => FilePath -> m Bool doesPathExist = liftIO . D.doesPathExist