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

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

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

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
+}

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;
+        };
+      };
+    };
+}

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

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"

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
+

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"))
+  }

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 []
+  }

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

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"

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)

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)