Add basic tagging operations to ca-store

.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

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

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

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

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))