diff --git a/.gitignore b/.gitignore index 3e6e0c9..95134a9 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ !src/CAStore/Config.hs !src/CAStore/Config/Type.hs !src/CAStore/Config/CLI.hs +!src/CAStore/FileStore.hs !src/CAStore/Program.hs !src/CAStore/Program/Internal.hs !src/CAStore/Program/IO.hs diff --git a/package.yaml b/package.yaml index 30f6112..d671e46 100644 --- a/package.yaml +++ b/package.yaml @@ -13,6 +13,7 @@ default-extensions: - DerivingVia - ScopedTypeVariables - TypeApplications +- TypeFamilies ghc-options: - -Wall @@ -45,10 +46,12 @@ library: - optparse-applicative - recursion-schemes - sqlite-simple + - transformers exposed-modules: - CAStore.Command - CAStore.Command.Autocomplete - CAStore.Command.Type + - CAStore.FileStore - CAStore.Config - CAStore.Config.CLI - CAStore.Config.Type diff --git a/src/CAStore/Command.hs b/src/CAStore/Command.hs index debf4a3..e9a22dc 100644 --- a/src/CAStore/Command.hs +++ b/src/CAStore/Command.hs @@ -6,19 +6,18 @@ module CAStore.Command where import CAStore.Command.Type (Command(..), parseCommand) -import CAStore.Program (Program, storeFile, unstoreFile, getFileLocation) +import CAStore.FileStore (storeFile, unstoreFile, verifyFile) +import CAStore.Program (Program) import CAStore.Program.IO import CAStore.Program.IO.Text import CAStore.Program.Storage import CAStore.Type import Control.Monad (forM_, filterM, (<=<)) -import Control.Monad.IO.Class (liftIO) -import System.Directory (doesFileExist) runCommand :: Command -> Program () runCommand (FileAdd fs) = do - sids <- registerFiles fs - forM_ (zip fs sids) $ \(file, sid) -> storeFile file sid + sids <- traverse storeFile fs + registerFiles sids printStoreIds sids runCommand (FileRemove ss) = unregisterFiles ss @@ -48,11 +47,3 @@ runCommand (TagSuperShow sup) = do showRelationSuper sup runCommand (TagSubShow sub) = do showRelationSub sub - --- | Recalculate the store id of a file and check to see if it matches. -verifyFile :: StoreId -> Program Bool -verifyFile sid = do - file <- getFileLocation sid - liftIO (doesFileExist file) >>= \case - True -> ((==) sid) <$> generateId file - False -> pure True diff --git a/src/CAStore/Command/Type.hs b/src/CAStore/Command/Type.hs index 98ac4d9..7af2ea0 100644 --- a/src/CAStore/Command/Type.hs +++ b/src/CAStore/Command/Type.hs @@ -33,15 +33,15 @@ parseCommand :: [String] -> Either Error Command parseCommand ("file":"add":xs) = pure $ FileAdd xs parseCommand ("file":"remove":xs) = - pure $ FileRemove $ StoreId <$> xs + pure $ FileRemove $ storeId <$> xs parseCommand ("file":"verify":xs) = - pure $ FileVerify $ StoreId <$> xs + pure $ FileVerify $ storeId <$> xs parseCommand ("tag":"add":x:xs) = - pure $ TagAdd (StoreId x) (Tag <$> xs) + pure $ TagAdd (storeId x) (Tag <$> xs) parseCommand ("tag":"remove":x:xs) = - pure $ TagRemove (StoreId x) (Tag <$> xs) + pure $ TagRemove (storeId x) (Tag <$> xs) parseCommand ("tag":"show":x:[]) = - pure $ TagShow (StoreId x) + pure $ TagShow (storeId x) parseCommand ("tag":"super":"add":x:xs) = pure $ TagSuperAdd (Tag x) (Tag <$> xs) parseCommand ("tag":"super":"remove":x:xs) = diff --git a/src/CAStore/FileStore.hs b/src/CAStore/FileStore.hs new file mode 100644 index 0000000..66f2387 --- /dev/null +++ b/src/CAStore/FileStore.hs @@ -0,0 +1,113 @@ +{-| + Module: CAStore.FileStore +-} + +module CAStore.FileStore + ( MonadFileStore + , Id + , storeFile + , unstoreFile + , verifyFile + , StoreId + , storeId + ) +where + +import Crypto.Hash (hash, SHA256) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, reader) +import Data.ByteString (ByteString, readFile) +import Data.Kind (Type) +import Database.SQLite.Simple.FromField (FromField) +import Database.SQLite.Simple.ToField (ToField) +import System.Directory + ( doesFileExist + , createDirectoryIfMissing + , copyFile + , setPermissions + , setOwnerReadable + , emptyPermissions + , removeFile + ) +import System.FilePath ((), takeDirectory) +import Prelude hiding (readFile) + +{-| + A monad that represents a store in which files can be + added and removed. Each file will be given an 'Id' + which you can use to refer to the file later. + + [Laws] + * 'storeFile' gives the same 'Id' for the same file. + @(==) <$> storeFile x <*> storeFile x@ + * 'storeFile' is idempotent. + @storeFile x *> storeFile x ≡ storeFile x@ + * 'unstoreFile' is idempotent. + @unstoreFile x *> unstoreFile x ≡ unstoreFile x@ + * 'unstoreFile' reverses 'storeFile'. + @storeFile x >>= unstoreFile ≡ pure ()@ +-} +class MonadFileStore m where + -- | An ID to reference files after they have been added + -- to the store. + type Id m :: Type + + -- | Add a file to the store, and return the 'Id' that + -- refers to this file + storeFile :: FilePath -> m (Id m) + + -- | Remove a file from the store if the file exists. + unstoreFile :: Id m -> m () + + -- | Recalculate the 'Id' of a file and check to see if it matches. + verifyFile :: Id m -> m Bool + +-- | ID a file by its SHA256 hash +newtype StoreId = StoreId String + deriving (Eq, Ord) + deriving (Show, FromField, ToField) + via String + +-- | Turn a SHA256 hash you already have (e.g. from command line) +-- into a t'StoreId'. +storeId :: String -> StoreId +storeId = StoreId + +-- | SHA256 hash an arbitrary sequence of bytes +generateStoreId :: ByteString -> StoreId +generateStoreId = StoreId . show . hash @SHA256 + +-- | Turn a t'StoreId' into a path relative to the store root. +toRelPath :: StoreId -> FilePath +toRelPath (StoreId x) = "files" (take 2 x) x + +-- | Turn a t'StoreId' into an absolute path, using the +-- environment as the store root. +toAbsPath :: StoreId -> ReaderT FilePath IO FilePath +toAbsPath sid = reader ( toRelPath sid) + +instance MonadFileStore (ReaderT FilePath IO) where + type Id (ReaderT FilePath IO) = StoreId + + storeFile file = do + sid <- liftIO $ fmap generateStoreId $ readFile file + loc <- toAbsPath sid + liftIO $ doesFileExist loc >>= \case + True -> pure () + False -> do + createDirectoryIfMissing True $ takeDirectory loc + copyFile file loc + setPermissions loc $ setOwnerReadable True emptyPermissions + pure sid + + unstoreFile sid = do + loc <- toAbsPath sid + liftIO $ doesFileExist loc >>= \case + True -> removeFile loc + False -> pure () + + verifyFile sid = do + file <- toAbsPath sid + liftIO $ doesFileExist file >>= \case + True -> (==) sid . generateStoreId <$> readFile file + False -> pure True diff --git a/src/CAStore/Program.hs b/src/CAStore/Program.hs index fb7bfca..5a63656 100644 --- a/src/CAStore/Program.hs +++ b/src/CAStore/Program.hs @@ -4,44 +4,14 @@ module CAStore.Program , getConnectionHandle , getStoreRoot , getCommand - , getFileLocation , getAutocomplete - - -- * File Operations - , storeFile - , unstoreFile ) where import CAStore.Command.Type (Command, parseCommand) import CAStore.Program.Internal import CAStore.Type -import Control.Monad.IO.Class (liftIO) -import qualified System.Directory as D -import System.FilePath (takeDirectory) -- | Parse the command line arguments and (hopefully) get the command. getCommand :: Program (Either Error Command) getCommand = parseCommand <$> getArguments - --- | Add a file to the store --- You must already have a 'StoreId' to use this function. You get one by --- adding the file to the database. -storeFile :: FilePath -> StoreId -> Program () -storeFile file sid = do - fileLocation <- getFileLocation sid - liftIO (D.doesFileExist fileLocation) >>= \case - True -> pure () - False -> liftIO $ do - D.createDirectoryIfMissing True (takeDirectory fileLocation) - D.copyFile file fileLocation - D.setPermissions file $ D.setOwnerReadable True D.emptyPermissions - --- | Remove a file from the store --- This will not alert the database that the file has been removed. -unstoreFile :: StoreId -> Program () -unstoreFile sid = do - fileLocation <- getFileLocation sid - liftIO (D.doesFileExist fileLocation) >>= \case - True -> liftIO $ D.removeFile fileLocation - False -> pure () diff --git a/src/CAStore/Program/IO.hs b/src/CAStore/Program/IO.hs index 0ea40b4..1eacced 100644 --- a/src/CAStore/Program/IO.hs +++ b/src/CAStore/Program/IO.hs @@ -9,7 +9,7 @@ import CAStore.Program.Internal (Program(..)) import Control.Monad.IO.Class (liftIO) printStoreId :: StoreId -> Program () -printStoreId (StoreId x) = Program $ liftIO $ putStrLn x +printStoreId = Program . liftIO . putStrLn . show printStoreIds :: [StoreId] -> Program () printStoreIds = mapM_ printStoreId diff --git a/src/CAStore/Program/IO/Text.hs b/src/CAStore/Program/IO/Text.hs index 2247f48..e53f576 100644 --- a/src/CAStore/Program/IO/Text.hs +++ b/src/CAStore/Program/IO/Text.hs @@ -21,8 +21,8 @@ err (ErrInvalidCommand []) = display $ "ERROR: No command specified" err (ErrInvalidCommand (x:xs)) = display $ "ERROR: Invalid command '" ++ intercalate1 " " (x :| xs) ++ "'" -err (ErrCorruptStoreId (StoreId x)) - = display x +err (ErrCorruptStoreId x) + = display $ show x warn :: Warning -> Program () warn (WarnArb x) = display $ "WARN: " ++ x diff --git a/src/CAStore/Program/Internal.hs b/src/CAStore/Program/Internal.hs index 9153959..c76983d 100644 --- a/src/CAStore/Program/Internal.hs +++ b/src/CAStore/Program/Internal.hs @@ -4,16 +4,17 @@ module CAStore.Program.Internal , Env(..) , getConnectionHandle , getStoreRoot - , getFileLocation , getArguments , getAutocomplete ) where import qualified CAStore.Config as C -import CAStore.Type +import CAStore.FileStore (MonadFileStore, Id, storeFile, unstoreFile, verifyFile, StoreId) +import CAStore.Type (StoreLocation(..)) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (ReaderT(..), asks) +import Control.Monad.Trans.Reader (withReaderT) import Database.SQLite.Simple (Connection, withConnection) import qualified System.Directory as D import System.FilePath (()) @@ -23,6 +24,12 @@ newtype Program a = Program (ReaderT Env IO a) deriving (Functor, Applicative, Monad, MonadIO) via (ReaderT Env IO) +instance MonadFileStore Program where + type Id Program = StoreId + storeFile = Program . withReaderT storeRoot . storeFile + unstoreFile = Program . withReaderT storeRoot . unstoreFile + verifyFile = Program . withReaderT storeRoot . verifyFile + runProgram :: C.Config Identity -> Program a -> IO a runProgram cfg (Program x) = do root <- defineStoreRoot $ runIdentity $ C.storeLocation cfg @@ -57,12 +64,6 @@ getConnectionHandle = Program $ asks handle getStoreRoot :: Program FilePath getStoreRoot = Program $ asks storeRoot --- | Determine the final location for a file inside the store -getFileLocation :: StoreId -> Program FilePath -getFileLocation (StoreId x) - = (\root -> root "files" (take 2 x) x) - <$> getStoreRoot - getArguments :: Program [String] getArguments = Program $ asks arguments diff --git a/src/CAStore/Program/Storage.hs b/src/CAStore/Program/Storage.hs index 889bb82..ac4ac2a 100644 --- a/src/CAStore/Program/Storage.hs +++ b/src/CAStore/Program/Storage.hs @@ -2,7 +2,6 @@ module CAStore.Program.Storage ( initialise - , generateId , registerFiles , unregisterFiles , registerTags @@ -22,11 +21,8 @@ import CAStore.Program.Internal import CAStore.Type import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) -import Crypto.Hash (hash, SHA256) -import Data.ByteString (readFile) import Database.SQLite.Simple import Database.SQLite.Simple.ToField (ToField) -import Prelude hiding (readFile) initialise :: Program () initialise = do @@ -45,18 +41,13 @@ initialise = do 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 - registerFiles - :: [FilePath] -> Program [StoreId] -registerFiles fs = do - sids <- traverse generateId fs + :: [StoreId] -> Program () +registerFiles sids = do runSqlQ "CREATE TEMP TABLE t_reg_file (hash TEXT NOT NULL) STRICT" runSqlMany "INSERT INTO t_reg_file (hash) VALUES (?)" sids runSqlQ "INSERT INTO file (hash) SELECT hash FROM t_reg_file EXCEPT SELECT hash FROM file" runSqlQ "DELETE FROM t_reg_file" - pure sids unregisterFiles :: [StoreId] diff --git a/src/CAStore/Type.hs b/src/CAStore/Type.hs index d9dc252..5b550cb 100644 --- a/src/CAStore/Type.hs +++ b/src/CAStore/Type.hs @@ -2,7 +2,8 @@ module CAStore.Type ( Error(..) , Warning(..) , Message(..) - , StoreId(..) + , StoreId + , storeId , Tag(..) , StoreLocation(..) , parseStoreLocation @@ -10,21 +11,10 @@ module CAStore.Type ) where +import CAStore.FileStore (StoreId, storeId) import Database.SQLite.Simple.FromField (FromField, fromField) import Database.SQLite.Simple.ToField (ToField, toField) -newtype StoreId = StoreId String - deriving (Eq) - -instance Show StoreId where - show (StoreId x) = show x - -instance FromField StoreId where - fromField = fmap StoreId . fromField - -instance ToField StoreId where - toField (StoreId x) = toField x - newtype Tag = Tag String deriving (Show, Eq)