From 6d4bc7847523f7a08eda0a71e63fe8702c16ebd8 Mon Sep 17 00:00:00 2001 From: hylodon Date: Fri, 19 Sep 2025 01:15:47 +0100 Subject: [PATCH] Add the DAG tagging operations to ca-store --- src/CAStore/Command.hs | 22 +++++++++------ src/CAStore/Command/Type.hs | 18 +++++++++++++ src/CAStore/Program/Storage.hs | 49 ++++++++++++++++++++++++++++++++++ 3 files changed, 81 insertions(+), 8 deletions(-) diff --git a/src/CAStore/Command.hs b/src/CAStore/Command.hs index 24643c3..9e2ea2d 100644 --- a/src/CAStore/Command.hs +++ b/src/CAStore/Command.hs @@ -10,14 +10,6 @@ import CAStore.Program (Program, storeFile, unstoreFile, getFileLocation) import CAStore.Program.IO import CAStore.Program.IO.Text import CAStore.Program.Storage - ( registerFiles - , unregisterFiles - , generateId - , registerTags - , assignTags - , unassignTags - , showTags - ) import CAStore.Type.Text import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) @@ -47,3 +39,17 @@ runCommand (TagRemove sid ts) = do unassignTags sid ts runCommand (TagShow sid) = do showTags sid +runCommand (TagSuperAdd sup subs) = do + registerTags $ sup : subs + relateTags $ flip (,) sup <$> subs +runCommand (TagSubAdd sub sups) = do + registerTags $ sub : sups + relateTags $ (,) sub <$> sups +runCommand (TagSuperRemove sup subs) = do + unrelateTags $ flip (,) sup <$> subs +runCommand (TagSubRemove sub sups) = do + unrelateTags $ (,) sub <$> sups +runCommand (TagSuperShow sup) = do + showRelationSuper sup +runCommand (TagSubShow sub) = do + showRelationSub sub diff --git a/src/CAStore/Command/Type.hs b/src/CAStore/Command/Type.hs index daad798..42f9409 100644 --- a/src/CAStore/Command/Type.hs +++ b/src/CAStore/Command/Type.hs @@ -13,6 +13,12 @@ data Command | TagAdd StoreId [Tag] | TagRemove StoreId [Tag] | TagShow StoreId + | TagSuperAdd Tag [Tag] + | TagSubAdd Tag [Tag] + | TagSuperRemove Tag [Tag] + | TagSubRemove Tag [Tag] + | TagSuperShow Tag + | TagSubShow Tag deriving (Show) parseCommand :: [String] -> Either Error Command @@ -28,4 +34,16 @@ parseCommand ("tag":"remove":x:xs) = pure $ TagRemove (StoreId x) (Tag <$> xs) parseCommand ("tag":"show":x:[]) = pure $ TagShow (StoreId x) +parseCommand ("tag":"super":"add":x:xs) + = pure $ TagSuperAdd (Tag x) (Tag <$> xs) +parseCommand ("tag":"sub":"add":x:xs) + = pure $ TagSubAdd (Tag x) (Tag <$> xs) +parseCommand ("tag":"super":"remove":x:xs) + = pure $ TagSuperRemove (Tag x) (Tag <$> xs) +parseCommand ("tag":"sub":"remove":x:xs) + = pure $ TagSubRemove (Tag x) (Tag <$> xs) +parseCommand ("tag":"super":"show":x:[]) + = pure $ TagSuperShow $ Tag x +parseCommand ("tag":"sub":"show":x:[]) + = pure $ TagSubShow $ Tag x parseCommand xs = Left $ ErrInvalidCommand xs diff --git a/src/CAStore/Program/Storage.hs b/src/CAStore/Program/Storage.hs index cff71bb..889bb82 100644 --- a/src/CAStore/Program/Storage.hs +++ b/src/CAStore/Program/Storage.hs @@ -10,6 +10,11 @@ module CAStore.Program.Storage , assignTags , unassignTags , showTags + , showTagsRaw + , relateTags + , unrelateTags + , showRelationSuper + , showRelationSub ) where @@ -32,6 +37,13 @@ initialise = do runSqlQ "CREATE TABLE tag (id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL UNIQUE) STRICT" unless ("is_tagged_with" `elem` tables) $ do runSqlQ "CREATE TABLE is_tagged_with (file INTEGER NOT NULL REFERENCES file(id), tag INTEGER NOT NULL REFERENCES tag(id), PRIMARY KEY (file, tag)) STRICT" + unless ("dag_tag" `elem` tables) $ do + runSqlQ "CREATE TABLE dag_tag (prev INTEGER NOT NULL REFERENCES tag(id), next INTEGER NOT NULL REFERENCES tag(id), PRIMARY KEY(prev, next)) STRICT" + views <- getAllDefinedViews + unless ("path_tag" `elem` views) $ do + runSqlQ "CREATE VIEW path_tag(start, end) AS WITH current(start, end) AS (SELECT tag.id, tag.id FROM tag UNION ALL SELECT start, next FROM current INNER JOIN dag_tag ON end == prev) SELECT start, end FROM current" + unless ("file_tag" `elem` views) $ do + runSqlQ "CREATE VIEW file_tag(hash, tag) AS SELECT DISTINCT f.hash, t.name FROM file AS f INNER JOIN is_tagged_with AS r ON f.id == r.file INNER JOIN path_tag AS p ON r.tag == p.start INNER JOIN tag AS t ON t.id == p.end" generateId :: FilePath -> Program StoreId generateId = fmap (StoreId . show . hash @SHA256) . liftIO . readFile @@ -85,10 +97,42 @@ unassignTags sid ts = do showTags :: StoreId -> Program () showTags sid = do + runSql $ \h -> + fold h "SELECT tag FROM file_tag WHERE hash = ? ORDER BY tag ASC" (Only sid) () + (\() (Only x) -> putStrLn x) + +showTagsRaw :: StoreId -> Program () +showTagsRaw sid = do runSql $ \h -> fold h "SELECT t.name FROM is_tagged_with AS r INNER JOIN file AS f ON r.file = f.id INNER JOIN tag AS t ON r.tag = t.id WHERE f.hash = ? ORDER BY t.name ASC" (Only sid) () (\() (Only x) -> putStrLn x) +relateTags :: [(Tag, Tag)] -> Program () +relateTags tts = do + runSqlQ "CREATE TEMP TABLE t_rel_tag (tag1 TEXT NOT NULL, tag2 TEXT NOT NULL) STRICT" + runSql $ \h -> executeMany h "INSERT INTO t_rel_tag (tag1, tag2) VALUES (?, ?)" tts + runSqlQ "INSERT OR IGNORE INTO dag_tag (prev, next) SELECT t1.id, t2.id FROM t_rel_tag AS r INNER JOIN tag AS t1 ON r.tag1 = t1.name INNER JOIN tag AS t2 ON r.tag2 = t2.name WHERE (t2.id, t1.id) NOT IN (SELECT * FROM path_tag)" + runSqlQ "DELETE FROM t_rel_tag" + +unrelateTags :: [(Tag, Tag)] -> Program () +unrelateTags tts = do + runSqlQ "CREATE TEMP TABLE t_unrel_tag (tag1 TEXT NOT NULL, tag2 TEXT NOT NULL) STRICT" + runSql $ \h -> executeMany h "INSERT INTO t_unrel_tag (tag1, tag2) VALUES (?, ?)" tts + runSqlQ "DELETE FROM dag_tag (prev, next) WHERE (prev, next) IN (SELECT t1.id, t2.id FROM t_unrel_tag AS r INNER JOIN tag AS t1 ON r.tag1 = t1.name INNER JOIN tag AS t2 ON r.tag2 = t2.name)" + runSqlQ "DELETE FROM t_unrel_tag" + +showRelationSuper :: Tag -> Program () +showRelationSuper t = do + runSql $ \h -> + fold h "SELECT t2.name FROM dag_tag AS r INNER JOIN tag AS t1 ON r.prev = t1.id INNER JOIN tag AS t2 ON r.next = t2.id WHERE t1.name = ? ORDER By t2.name ASC" (Only t) () + (\() (Only x) -> putStrLn x) + +showRelationSub :: Tag -> Program () +showRelationSub t = do + runSql $ \h -> + fold h "SELECT t1.name FROM dag_tag AS r INNER JOIN tag AS t1 ON r.prev = t1.id INNER JOIN tag AS t2 ON r.next = t2.id WHERE t2.name = ? ORDER By t1.name ASC" (Only t) () + (\() (Only x) -> putStrLn x) + runSql :: (Connection -> IO a) -> Program a runSql f = getConnectionHandle >>= (Program . liftIO . f) @@ -105,3 +149,8 @@ getAllDefinedTables :: Program [String] getAllDefinedTables = getConnectionHandle >>= \h -> liftIO $ fmap fromOnly <$> query_ h "SELECT name FROM SQLITE_SCHEMA where type = 'table' ORDER BY name" + +getAllDefinedViews :: Program [String] +getAllDefinedViews + = getConnectionHandle >>= \h -> + liftIO $ fmap fromOnly <$> query_ h "SELECT name FROM SQLITE_SCHEMA where type = 'view' ORDER BY name"