From 9d2d5b5522dd5c9dc85b75b8c6d3c5c9c664b927 Mon Sep 17 00:00:00 2001 From: hylodon Date: Thu, 18 Sep 2025 12:11:39 +0100 Subject: [PATCH] Put program into a runnable state, and break the cycle that was discovered --- .gitignore | 2 + app/Main.hs | 12 +++++- package.yaml | 2 + src/CAStore/Command.hs | 20 +--------- src/CAStore/Command/Type.hs | 23 +++++++++++ src/CAStore/Program.hs | 55 ++------------------------- src/CAStore/Program/Internal.hs | 67 +++++++++++++++++++++++++++++++++ src/CAStore/Program/Storage.hs | 2 +- 8 files changed, 111 insertions(+), 72 deletions(-) create mode 100644 src/CAStore/Command/Type.hs create mode 100644 src/CAStore/Program/Internal.hs diff --git a/.gitignore b/.gitignore index 05ae63f..7f7b3e2 100644 --- a/.gitignore +++ b/.gitignore @@ -6,10 +6,12 @@ !package.yaml !app/Main.hs !src/CAStore/Command.hs +!src/CAStore/Command/Type.hs !src/CAStore/Config.hs !src/CAStore/Config/Type.hs !src/CAStore/Config/CLI.hs !src/CAStore/Program.hs +!src/CAStore/Program/Internal.hs !src/CAStore/Program/Storage.hs !src/CAStore/Type.hs !src/Data/List/Extra.hs diff --git a/app/Main.hs b/app/Main.hs index 700390e..17b056d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,17 @@ module Main(main) where +import CAStore.Command (runCommand) import CAStore.Config (finalConfig) -import CAStore.Program (runProgram, defaultProgram) +import CAStore.Program (Program, runProgram, getCommand) +import CAStore.Program.Storage (initialise) +import Control.Monad.IO.Class (liftIO) main :: IO () main = finalConfig >>= flip runProgram defaultProgram + +defaultProgram :: Program () +defaultProgram = do + initialise + getCommand >>= \case + Nothing -> liftIO $ putStrLn "ERROR: Invalid command" + Just cmd -> runCommand cmd diff --git a/package.yaml b/package.yaml index 1c1bbd1..05fa13d 100644 --- a/package.yaml +++ b/package.yaml @@ -47,10 +47,12 @@ library: - sqlite-simple exposed-modules: - CAStore.Command + - CAStore.Command.Type - CAStore.Config - CAStore.Config.CLI - CAStore.Config.Type - CAStore.Program + - CAStore.Program.Internal - CAStore.Program.Storage - CAStore.Type - Data.List.Extra diff --git a/src/CAStore/Command.hs b/src/CAStore/Command.hs index 34d0969..ddb35f1 100644 --- a/src/CAStore/Command.hs +++ b/src/CAStore/Command.hs @@ -1,31 +1,15 @@ module CAStore.Command ( Command(..) - , runCommand , parseCommand + , runCommand ) where +import CAStore.Command.Type (Command(..), parseCommand) import CAStore.Program (Program, storeFile, unstoreFile) import CAStore.Program.Storage (registerFile, unregisterFile) -import CAStore.Type import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Char8 (pack) - -data Command - = FileAdd [FilePath] - | FileRemove [StoreId] - | FileVerify [StoreId] - deriving (Show) - -parseCommand :: [String] -> Maybe Command -parseCommand ("file":"add":xs) - = Just $ FileAdd xs -parseCommand ("file":"remove":xs) - = Just $ FileRemove $ StoreId . pack <$> xs -parseCommand ("file":"verify":xs) - = Just $ FileVerify $ StoreId . pack <$> xs -parseCommand _ = Nothing runCommand :: Command -> Program () runCommand (FileAdd fs) = forM_ fs $ \x -> do diff --git a/src/CAStore/Command/Type.hs b/src/CAStore/Command/Type.hs new file mode 100644 index 0000000..81f5d7d --- /dev/null +++ b/src/CAStore/Command/Type.hs @@ -0,0 +1,23 @@ +module CAStore.Command.Type + ( Command(..) + , parseCommand + ) +where + +import CAStore.Type +import Data.ByteString.Char8 (pack) + +data Command + = FileAdd [FilePath] + | FileRemove [StoreId] + | FileVerify [StoreId] + deriving (Show) + +parseCommand :: [String] -> Maybe Command +parseCommand ("file":"add":xs) + = Just $ FileAdd xs +parseCommand ("file":"remove":xs) + = Just $ FileRemove $ StoreId . pack <$> xs +parseCommand ("file":"verify":xs) + = Just $ FileVerify $ StoreId . pack <$> xs +parseCommand _ = Nothing diff --git a/src/CAStore/Program.hs b/src/CAStore/Program.hs index f712863..a9d65f5 100644 --- a/src/CAStore/Program.hs +++ b/src/CAStore/Program.hs @@ -1,9 +1,9 @@ module CAStore.Program ( Program , runProgram - , defaultProgram , getConnectionHandle , getStoreRoot + , getCommand -- * File Operations , storeFile @@ -11,59 +11,10 @@ module CAStore.Program ) where -import CAStore.Config (Config(..)) +import CAStore.Program.Internal import CAStore.Type -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT(..), asks) -import Database.SQLite.Simple -import qualified Data.ByteString as B -import Data.ByteString.Char8 (unpack) -import Data.Functor.Identity (Identity(..)) +import Control.Monad.IO.Class (liftIO) import qualified System.Directory as D -import System.FilePath (()) - -newtype Program a = Program (ReaderT Env IO a) - deriving (Functor, Applicative, Monad, MonadIO) - via (ReaderT Env IO) - -runProgram :: Config Identity -> Program a -> IO a -runProgram cfg (Program x) = do - root <- defineStoreRoot $ runIdentity $ storeLocation cfg - D.createDirectoryIfMissing True root - let db = root "db.db" - withConnection db (runReaderT x . makeEnv cfg root) - -data Env = Env - { handle :: Connection - , storeRoot :: FilePath - } - -makeEnv :: Config Identity -> FilePath -> Connection -> Env -makeEnv _ root conn = Env - { handle = conn - , storeRoot = root - } - -defineStoreRoot :: StoreLocation -> IO FilePath -defineStoreRoot (StorePath p) = pure p -defineStoreRoot (StoreShort p) = do - dir <- D.getXdgDirectory D.XdgData $ "ca-store" p - pure dir - -defaultProgram :: Program () -defaultProgram = pure () - -getConnectionHandle :: Program Connection -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" (unpack $ B.take 2 x) (unpack x)) - <$> getStoreRoot -- | Add a file to the store -- You must already have a 'StoreId' to use this function. You get one by diff --git a/src/CAStore/Program/Internal.hs b/src/CAStore/Program/Internal.hs new file mode 100644 index 0000000..61552d6 --- /dev/null +++ b/src/CAStore/Program/Internal.hs @@ -0,0 +1,67 @@ +module CAStore.Program.Internal + ( Program + , runProgram + , Env(..) + , getConnectionHandle + , getStoreRoot + , getFileLocation + , getCommand + ) +where + +import CAStore.Command.Type (Command(..), parseCommand) +import CAStore.Config (Config(..)) +import CAStore.Type +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ReaderT(..), asks) +import Database.SQLite.Simple (Connection, withConnection) +import qualified System.Directory as D +import System.FilePath (()) +import qualified Data.ByteString as B (take) +import Data.ByteString.Char8 (unpack) +import Data.Functor.Identity (Identity(..)) + +newtype Program a = Program (ReaderT Env IO a) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT Env IO) + +runProgram :: Config Identity -> Program a -> IO a +runProgram cfg (Program x) = do + root <- defineStoreRoot $ runIdentity $ storeLocation cfg + D.createDirectoryIfMissing True root + let db = root "db.db" + withConnection db (runReaderT x . makeEnv cfg root) + +defineStoreRoot :: StoreLocation -> IO FilePath +defineStoreRoot (StorePath p) = pure p +defineStoreRoot (StoreShort p) = do + dir <- D.getXdgDirectory D.XdgData $ "ca-store" p + pure dir + +data Env = Env + { handle :: Connection + , storeRoot :: FilePath + , mCommand :: Maybe Command + } + +makeEnv :: Config Identity -> FilePath -> Connection -> Env +makeEnv cfg root conn = Env + { handle = conn + , storeRoot = root + , mCommand = parseCommand $ runIdentity $ arguments cfg + } + +getConnectionHandle :: Program Connection +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" (unpack $ B.take 2 x) (unpack x)) + <$> getStoreRoot + +getCommand :: Program (Maybe Command) +getCommand = Program $ asks mCommand diff --git a/src/CAStore/Program/Storage.hs b/src/CAStore/Program/Storage.hs index fd32d71..725d992 100644 --- a/src/CAStore/Program/Storage.hs +++ b/src/CAStore/Program/Storage.hs @@ -7,7 +7,7 @@ module CAStore.Program.Storage ) where -import CAStore.Program +import CAStore.Program.Internal import CAStore.Type (StoreId(..)) import Control.Monad (unless) import Control.Monad.IO.Class (liftIO)