From c504f85a2d89a619fa8a5434c4698b63a898dc6a Mon Sep 17 00:00:00 2001 From: hylodon Date: Fri, 12 Sep 2025 16:16:51 +0100 Subject: [PATCH] Rough structure of the program ca-store is planned to work as follows: 1) A monad (currently IO) will generate the configuration, read the command line, parse the config files, and create the environment the program should run in. 2) This environment will be passed to the main monad (currently Program) to do the work. Currently everything will be directly coded with little to no abstraction. Once ca-store is up and running, we will begin regaining purity by pulling major features into small testable units. --- .gitignore | 15 ++++++ app/Main.hs | 7 +++ flake.lock | 27 +++++++++++ flake.nix | 27 +++++++++++ package.yaml | 67 ++++++++++++++++++++++++++ src/CAStore/Command.hs | 36 ++++++++++++++ src/CAStore/Config.hs | 17 +++++++ src/CAStore/Config/CLI.hs | 24 ++++++++++ src/CAStore/Config/Type.hs | 38 +++++++++++++++ src/CAStore/Program.hs | 87 ++++++++++++++++++++++++++++++++++ src/CAStore/Program/Storage.hs | 47 ++++++++++++++++++ src/CAStore/Type.hs | 29 ++++++++++++ src/Data/List/Extra.hs | 13 +++++ 13 files changed, 434 insertions(+) create mode 100644 .gitignore create mode 100644 app/Main.hs create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 package.yaml create mode 100644 src/CAStore/Command.hs create mode 100644 src/CAStore/Config.hs create mode 100644 src/CAStore/Config/CLI.hs create mode 100644 src/CAStore/Config/Type.hs create mode 100644 src/CAStore/Program.hs create mode 100644 src/CAStore/Program/Storage.hs create mode 100644 src/CAStore/Type.hs create mode 100644 src/Data/List/Extra.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..05ae63f --- /dev/null +++ b/.gitignore @@ -0,0 +1,15 @@ +* +!*/ +!.gitignore +!flake.nix +!flake.lock +!package.yaml +!app/Main.hs +!src/CAStore/Command.hs +!src/CAStore/Config.hs +!src/CAStore/Config/Type.hs +!src/CAStore/Config/CLI.hs +!src/CAStore/Program.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 new file mode 100644 index 0000000..700390e --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main(main) where + +import CAStore.Config (finalConfig) +import CAStore.Program (runProgram, defaultProgram) + +main :: IO () +main = finalConfig >>= flip runProgram defaultProgram diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..f695441 --- /dev/null +++ b/flake.lock @@ -0,0 +1,27 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1757408970, + "narHash": "sha256-aSgK4BLNFFGvDTNKPeB28lVXYqVn8RdyXDNAvgGq+k0=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "d179d77c139e0a3f5c416477f7747e9d6b7ec315", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-25.05", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..1d9afac --- /dev/null +++ b/flake.nix @@ -0,0 +1,27 @@ +{ + description = "ca-store: A simple content-addressed store"; + + inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-25.05"; + + outputs = { self, nixpkgs }: + let + forAllSystems = nixpkgs.lib.genAttrs [ "x86_64-linux" ]; + in { + packages = forAllSystems (system: + let + np = import nixpkgs { + inherit system; + overlays = [ self.overlays.default ]; + }; + in { ca-store = np.ca-store; default = np.ca-store; } + ); + + overlays.default = final: prev: { + ca-store = final.haskellPackages.developPackage { + root = ./.; + name = "ca-store"; + withHoogle = false; + }; + }; + }; +} diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..1c1bbd1 --- /dev/null +++ b/package.yaml @@ -0,0 +1,67 @@ +name: ca-store +version: 0.0.0 +license: GPL-3.0-or-later +category: Text + +language: GHC2021 + +default-extensions: +- LambdaCase +- DeriveAnyClass +- DeriveGeneric +- DerivingStrategies +- DerivingVia +- ScopedTypeVariables +- TypeApplications + +ghc-options: +- -Wall +- -Wcompat +- -Werror +- -fshow-warning-groups +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wredundant-constraints +- -O2 +- -optc-O3 +- -optc-ffast-math +- -fexcess-precision +- -j +- -fPIC + +library: + when: + - condition: false + other-modules: Paths_ca_store + source-dirs: "src" + dependencies: + - barbies + - base + - bytestring + - cryptohash + - directory + - filepath + - mtl + - optparse-applicative + - recursion-schemes + - sqlite-simple + exposed-modules: + - CAStore.Command + - CAStore.Config + - CAStore.Config.CLI + - CAStore.Config.Type + - CAStore.Program + - CAStore.Program.Storage + - CAStore.Type + - Data.List.Extra + +executables: + ca-store: + main: "Main.hs" + source-dirs: "app" + dependencies: + - base + - ca-store + ghc-options: + - -threaded + - -rtsopts=ignoreAll diff --git a/src/CAStore/Command.hs b/src/CAStore/Command.hs new file mode 100644 index 0000000..34d0969 --- /dev/null +++ b/src/CAStore/Command.hs @@ -0,0 +1,36 @@ +module CAStore.Command + ( Command(..) + , runCommand + , parseCommand + ) +where + +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 + registerFile x >>= storeFile x +runCommand (FileRemove ss) = forM_ ss $ \x -> do + unregisterFile x *> unstoreFile x +runCommand (FileVerify ss) = forM_ ss $ \_ -> do + liftIO $ putStrLn $ "STUB" diff --git a/src/CAStore/Config.hs b/src/CAStore/Config.hs new file mode 100644 index 0000000..19283ca --- /dev/null +++ b/src/CAStore/Config.hs @@ -0,0 +1,17 @@ +module CAStore.Config + ( Config(..) + , finalConfig + ) +where + +import CAStore.Config.CLI (parseCLI) +import CAStore.Config.Type + ( Config(..) ) +import Data.Functor.Identity (Identity(..)) + +allConfigs :: IO (Config Identity) +allConfigs = parseCLI + +finalConfig :: IO (Config Identity) +finalConfig = allConfigs + diff --git a/src/CAStore/Config/CLI.hs b/src/CAStore/Config/CLI.hs new file mode 100644 index 0000000..0c42ef2 --- /dev/null +++ b/src/CAStore/Config/CLI.hs @@ -0,0 +1,24 @@ +{-| + Module: CAStore.Config.CLI + Description: Processes the command line of ca-store +-} + +module CAStore.Config.CLI + ( parseCLI + ) +where + +import CAStore.Config.Type (Config(..)) +import CAStore.Type +import Data.Functor.Barbie (bsequence') +import Data.Functor.Identity (Identity(..)) +import Options.Applicative hiding (command) + +parseCLI :: IO (Config Identity) +parseCLI = execParser $ info (bsequence' parser) mempty + +parser :: Config Parser +parser = Config + { storeLocation = argument (maybeReader parseStoreLocation) (metavar "STORE") + , arguments = some (strArgument (metavar "COMMAND")) + } diff --git a/src/CAStore/Config/Type.hs b/src/CAStore/Config/Type.hs new file mode 100644 index 0000000..a03d9cb --- /dev/null +++ b/src/CAStore/Config/Type.hs @@ -0,0 +1,38 @@ +{-| + Module: CAStore.Config.Type + Description: Define the basic type used by CAStore.Config.*, and + functions for manipulating it +-} + +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module CAStore.Config.Type + ( Config(..) + , defaultConfig + , StoreLocation(..) + , OutputType(..) + ) +where + +import Data.Functor.Barbie +import CAStore.Type +import GHC.Generics (Generic) + +-- | A HKD that contains every option the program can take as input +data Config f = Config + { storeLocation :: f StoreLocation + , arguments :: f [String] + } + deriving stock (Generic) + deriving anyclass (FunctorB, TraversableB, ApplicativeB, ConstraintsB) + +deriving instance AllBF Show f Config => Show (Config f) + +-- | The default values for the configuration, or Nothing if +-- the value must be specified +defaultConfig :: Config Maybe +defaultConfig = Config + { storeLocation = Nothing + , arguments = Just [] + } diff --git a/src/CAStore/Program.hs b/src/CAStore/Program.hs new file mode 100644 index 0000000..f712863 --- /dev/null +++ b/src/CAStore/Program.hs @@ -0,0 +1,87 @@ +module CAStore.Program + ( Program + , runProgram + , defaultProgram + , getConnectionHandle + , getStoreRoot + + -- * File Operations + , storeFile + , unstoreFile + ) +where + +import CAStore.Config (Config(..)) +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 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 +-- 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.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/Storage.hs b/src/CAStore/Program/Storage.hs new file mode 100644 index 0000000..fd32d71 --- /dev/null +++ b/src/CAStore/Program/Storage.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CAStore.Program.Storage + ( initialise + , registerFile + , unregisterFile + ) +where + +import CAStore.Program +import CAStore.Type (StoreId(..)) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Crypto.Hash.SHA256 (hash) +import Data.ByteString (readFile) +import Database.SQLite.Simple +import Prelude hiding (readFile) + +initialise :: Program () +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" + +registerFile :: FilePath -> Program StoreId +registerFile file = do + sid <- fmap hash $ liftIO $ readFile file + runSqlQP "INSERT INTO file (hash) VALUES (?)" (Only sid) + pure $ StoreId sid + +unregisterFile :: StoreId -> Program () +unregisterFile (StoreId sid) = do + runSqlQP "DELETE FROM file WHERE hash = ?" (Only sid) + +-- runSql :: (Connection -> IO a) -> Program a +-- runSql f = getConnectionHandle >>= (liftIO . f) + +runSqlQ :: Query -> Program () +runSqlQ q = getConnectionHandle >>= (liftIO . flip execute_ q) + +runSqlQP :: ToRow q => Query -> q -> Program () +runSqlQP q p = getConnectionHandle >>= \h -> (liftIO $ execute h q p) + +getAllDefinedTables :: Program [String] +getAllDefinedTables + = getConnectionHandle >>= \h -> + liftIO $ fmap fromOnly <$> query_ h "SELECT name FROM SQLITE_SCHEMA where type = 'table' ORDER BY name" diff --git a/src/CAStore/Type.hs b/src/CAStore/Type.hs new file mode 100644 index 0000000..d45e82d --- /dev/null +++ b/src/CAStore/Type.hs @@ -0,0 +1,29 @@ +module CAStore.Type + ( StoreId(..) + , Tag(..) + , StoreLocation(..) + , parseStoreLocation + , OutputType(..) + ) +where + +import Data.ByteString (ByteString) + +newtype StoreId = StoreId ByteString + deriving (Show) + +newtype Tag = Tag String + deriving (Show) + +data StoreLocation + = StoreShort String + | StorePath FilePath + deriving (Show) + +parseStoreLocation :: String -> Maybe StoreLocation +parseStoreLocation x@('/':_) = Just $ StorePath x +parseStoreLocation x@('.':'/':_) = Just $ StorePath x +parseStoreLocation x = Just $ StoreShort x + +data OutputType = OutputId | OutputFilename + deriving (Show) diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs new file mode 100644 index 0000000..6d6673a --- /dev/null +++ b/src/Data/List/Extra.hs @@ -0,0 +1,13 @@ +module Data.List.Extra + ( takeWhile1M + ) +where + +import Data.Functor.Foldable (ListF(..), transverse) + +-- Get the longest prefix of a list that satisfies the predicate, +-- and the first element that fails the predicate. +takeWhile1M :: Monad m => (a -> Bool) -> [m a] -> m [a] +takeWhile1M p = transverse $ \case + Nil -> pure Nil + Cons a b -> a >>= (\x -> if p x then Cons x <$> b else pure Nil)