diff --git a/.gitignore b/.gitignore index 1bca659..4ea955f 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ !src/CAStore/Config/CLI.hs !src/CAStore/Program.hs !src/CAStore/Program/Internal.hs +!src/CAStore/Program/IO.hs !src/CAStore/Program/IO/Text.hs !src/CAStore/Program/Storage.hs !src/CAStore/Type.hs diff --git a/src/CAStore/Command.hs b/src/CAStore/Command.hs index e20a32d..24643c3 100644 --- a/src/CAStore/Command.hs +++ b/src/CAStore/Command.hs @@ -7,8 +7,17 @@ where import CAStore.Command.Type (Command(..), parseCommand) import CAStore.Program (Program, storeFile, unstoreFile, getFileLocation) +import CAStore.Program.IO import CAStore.Program.IO.Text -import CAStore.Program.Storage (registerFiles, unregisterFiles, generateId) +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) @@ -18,6 +27,7 @@ runCommand :: Command -> Program () runCommand (FileAdd fs) = do sids <- registerFiles fs forM_ (zip fs sids) $ \(file, sid) -> storeFile file sid + printStoreIds sids runCommand (FileRemove ss) = unregisterFiles ss *> forM_ ss unstoreFile @@ -30,3 +40,10 @@ runCommand (FileVerify ss) = forM_ ss $ \sid -> do True -> msg $ MsgArb $ show sid ++ " is valid." False -> err $ ErrArb $ show sid ++ " has been corrupted." False -> err $ ErrArb $ show sid ++ " does not exist in the store." +runCommand (TagAdd sid ts) = do + registerTags ts + assignTags sid ts +runCommand (TagRemove sid ts) = do + unassignTags sid ts +runCommand (TagShow sid) = do + showTags sid diff --git a/src/CAStore/Command/Type.hs b/src/CAStore/Command/Type.hs index b7a05bb..daad798 100644 --- a/src/CAStore/Command/Type.hs +++ b/src/CAStore/Command/Type.hs @@ -10,6 +10,9 @@ data Command = FileAdd [FilePath] | FileRemove [StoreId] | FileVerify [StoreId] + | TagAdd StoreId [Tag] + | TagRemove StoreId [Tag] + | TagShow StoreId deriving (Show) parseCommand :: [String] -> Either Error Command @@ -19,4 +22,10 @@ parseCommand ("file":"remove":xs) = pure $ FileRemove $ StoreId <$> xs parseCommand ("file":"verify":xs) = pure $ FileVerify $ StoreId <$> xs +parseCommand ("tag":"add":x:xs) + = pure $ TagAdd (StoreId x) (Tag <$> xs) +parseCommand ("tag":"remove":x:xs) + = pure $ TagRemove (StoreId x) (Tag <$> xs) +parseCommand ("tag":"show":x:[]) + = pure $ TagShow (StoreId x) parseCommand xs = Left $ ErrInvalidCommand xs diff --git a/src/CAStore/Program/IO.hs b/src/CAStore/Program/IO.hs new file mode 100644 index 0000000..0ea40b4 --- /dev/null +++ b/src/CAStore/Program/IO.hs @@ -0,0 +1,21 @@ +module CAStore.Program.IO + ( printStoreIds + , printTags + ) +where + +import CAStore.Type +import CAStore.Program.Internal (Program(..)) +import Control.Monad.IO.Class (liftIO) + +printStoreId :: StoreId -> Program () +printStoreId (StoreId x) = Program $ liftIO $ putStrLn x + +printStoreIds :: [StoreId] -> Program () +printStoreIds = mapM_ printStoreId + +printTag :: Tag -> Program () +printTag (Tag x) = Program $ liftIO $ putStrLn x + +printTags :: [Tag] -> Program () +printTags = mapM_ printTag diff --git a/src/CAStore/Program/Storage.hs b/src/CAStore/Program/Storage.hs index c808f94..cff71bb 100644 --- a/src/CAStore/Program/Storage.hs +++ b/src/CAStore/Program/Storage.hs @@ -5,11 +5,16 @@ module CAStore.Program.Storage , generateId , registerFiles , unregisterFiles + , registerTags + , unregisterTags + , assignTags + , unassignTags + , showTags ) where import CAStore.Program.Internal -import CAStore.Type (StoreId(..)) +import CAStore.Type import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Crypto.Hash (hash, SHA256) @@ -23,6 +28,10 @@ initialise = do tables <- getAllDefinedTables unless ("file" `elem` tables) $ do runSqlQ "CREATE TABLE file (id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, hash TEXT NOT NULL UNIQUE, insertion_date TEXT NOT NULL DEFAULT CURRENT_TIMESTAMP CHECK (insertion_date LIKE '____-__-__ __:__:__')) STRICT" + unless ("tag" `elem` tables) $ 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" generateId :: FilePath -> Program StoreId generateId = fmap (StoreId . show . hash @SHA256) . liftIO . readFile @@ -46,12 +55,49 @@ unregisterFiles ss = do runSqlQ "DELETE FROM file WHERE hash IN (SELECT * FROM t_unreg_file)" runSqlQ "DELETE FROM t_unreg_file" --- runSql :: (Connection -> IO a) -> Program a --- runSql f = getConnectionHandle >>= (liftIO . f) +registerTags :: [Tag] -> Program () +registerTags ts = do + runSqlQ "CREATE TEMP TABLE t_reg_tag (name TEXT NOT NULL) STRICT" + runSqlMany "INSERT INTO t_reg_tag (name) VALUES (?)" ts + runSqlQ "INSERT INTO tag (name) SELECT name FROM t_reg_tag EXCEPT SELECT name FROM tag" + runSqlQ "DELETE FROM t_reg_tag" + +unregisterTags :: [Tag] -> Program () +unregisterTags ts = do + runSqlQ "CREATE TEMP TABLE t_unreg_tag (name TEXT NOT NULL) STRICT" + runSqlMany "INSERT INTO t_unreg_tag (name) VALUES (?)" ts + runSqlQ "DELETE FROM tag WHERE name IN (SELECT * FROM t_unreg_tag)" + runSqlQ "DELETE FROM t_unreg_tag" + +assignTags :: StoreId -> [Tag] -> Program () +assignTags sid ts = do + runSqlQ "CREATE TEMP TABLE t_ass_tag (name TEXT NOT NULL) STRICT" + runSqlMany "INSERT INTO t_ass_tag (name) VALUES (?)" ts + runSqlQP "INSERT OR IGNORE INTO is_tagged_with (file, tag) SELECT (SELECT id FROM file WHERE hash = ?), t.id FROM t_ass_tag AS r INNER JOIN tag AS t ON r.name = t.name" sid + runSqlQ "DELETE FROM t_ass_tag" + +unassignTags :: StoreId -> [Tag] -> Program () +unassignTags sid ts = do + runSqlQ "CREATE TEMP TABLE t_unass_tag (name TEXT NOT NULL) STRICT" + runSqlMany "INSERT INTO t_unass_tag (name) VALUES (?)" ts + runSqlQP "DELETE FROM is_tagged_with WHERE file IN (SELECT id FROM file WHERE hash = ?) AND tag IN (SELECT id FROM tag WHERE name IN (SELECT * FROM t_unass_tag))" sid + runSqlQ "DELETE FROM t_unass_tag" + +showTags :: StoreId -> Program () +showTags 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) + +runSql :: (Connection -> IO a) -> Program a +runSql f = getConnectionHandle >>= (Program . liftIO . f) runSqlQ :: Query -> Program () runSqlQ q = getConnectionHandle >>= (liftIO . flip execute_ q) +runSqlQP :: ToField a => Query -> a -> Program () +runSqlQP q x = getConnectionHandle >>= \h -> (liftIO $ execute h q $ Only x) + runSqlMany :: ToField a => Query -> [a] -> Program () runSqlMany q xs = getConnectionHandle >>= \h -> (liftIO $ executeMany h q (Only <$> xs))