Purify file operations

Factor out storeFile, unstoreFile, and verifyFile into a MTL
style class. This class can provide its own Id type, and never
returns FilePaths directly, which should allow a memory-only
variant for testing purposes later.

Control of storage ids now belongs to MonadFileStore. It was not
really the place of the data layer (which is currently a set of
SQL queries) to suddenly do one arbitrary file IO operation.

.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

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

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

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

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

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

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

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

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
 

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]

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)