diff --git a/gachi-plan.cabal b/gachi-plan.cabal new file mode 100644 --- /dev/null +++ b/gachi-plan.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.0 +name: gachi-plan +version: 0.1.0.0 +synopsis: Isolated detached Git store architecture and snapshot ledger for ecosystem plan governance +description: + Implements Milestone 5.1 of Phase 5 (Ecosystem Plan Governance & Rollback per ~/src/PLAN.md §1.A). + Establishes an isolated, detached Git store tracking ecosystem-wide governance documents + (PLAN.md, STATE.md, INDEX.md, and docs/INDEX.md) across ~/src/ without interfering with child git checkouts. +license: EUPL-1.2 +author: Nadia Yvette Chambers +maintainer: nadia.yvette.chambers@ik.me +category: Development, VersionControl, Tools +build-type: Simple +tested-with: + GHC == 9.10.3, + GHC == 9.12.4, + GHC == 9.14.1 + +common commons + default-language: Haskell2010 + default-extensions: + OverloadedStrings + DerivingStrategies + ScopedTypeVariables + ghc-options: + -Wall + -Wcompat + -Wredundant-constraints + +library + import: commons + exposed-modules: + Gachi.Plan + Gachi.Plan.Rollback + Gachi.Plan.Snapshot + Gachi.Plan.Store + Gachi.Plan.Types + hs-source-dirs: src + build-depends: + base >= 4.14 && < 5, + bytestring >= 0.10, + text >= 2.0, + containers >= 0.6, + directory >= 1.3, + filepath >= 1.4, + process >= 1.6, + time >= 1.9, + gachi-sync >= 0.1 + +test-suite tests + import: commons + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + ghc-options: + -threaded + build-depends: + base >= 4.14 && < 5, + gachi-plan, + bytestring >= 0.10, + text >= 2.0, + containers >= 0.6, + directory >= 1.3, + filepath >= 1.4, + process >= 1.6, + time >= 1.9, + hspec >= 2.10 diff --git a/src/Gachi/Plan.hs b/src/Gachi/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Plan.hs @@ -0,0 +1,32 @@ +-- | Module: Gachi.Plan +-- Description: Unified facade for ecosystem plan governance and detached Git store operations +-- +-- This module serves as the primary entry point for @gachi-plan@, re-exporting +-- the detached Git store lifecycle operations and algebraic data models. +-- +-- = Architectural Context & Invariants +-- +-- In accordance with Note [Plan Governance and Rollback Mechanics] +-- [ref:note-plan-governance-rollback] and Note [Append-Only Plan Snapshot Invariants] +-- [ref:note-plan-snapshots], the detached Git store architecture and snapshot +-- ledger manage strategic ecosystem governance documents (@PLAN.md@, @STATE.md@, +-- @INDEX.md@, and @docs/INDEX.md@) in an isolated Git repository and append-only +-- directory without creating nested @.git@ roots or interfering with child repository checkouts. +module Gachi.Plan + ( -- * Core Store Lifecycle & Operations + module Gachi.Plan.Store + + -- * Append-Only Snapshot Ledger Engine + , module Gachi.Plan.Snapshot + + -- * Atomic Rollback & Differential History Engine + , module Gachi.Plan.Rollback + + -- * Algebraic Data Models & Types + , module Gachi.Plan.Types + ) where + +import Gachi.Plan.Rollback +import Gachi.Plan.Snapshot +import Gachi.Plan.Store +import Gachi.Plan.Types diff --git a/src/Gachi/Plan/Rollback.hs b/src/Gachi/Plan/Rollback.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Plan/Rollback.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Plan.Rollback +-- Description: Atomic rollback engine, pre-mutation safety snapshots, and differential history +-- +-- This module implements Milestone 5.3 of Phase 5 (Ecosystem Plan Governance & Rollback +-- per ~/src/PLAN.md §1.A). It delivers atomic rollback mechanics, pre-mutation safety +-- snapshots, unified diff computation, structured git log queries, and checkpoint commits. +-- +-- = Architectural Context & Invariants +-- +-- Note [Deterministic Plan Rollback Invariants] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- [tag:note-plan-rollback-invariants] +-- The plan rollback engine guarantees deterministic, reversible state transitions +-- across ecosystem planning and governance documents (PLAN.md, STATE.md, INDEX.md, +-- and docs/INDEX.md). +-- +-- Core Invariants: +-- 1. __Pre-Mutation Safety Invariant:__ +-- Prior to executing any destructive mutation or checkout of working tree files, +-- the rollback engine MUST record immutable pre-mutation safety snapshots of all +-- governed files currently on disk in the snapshot ledger (~/src/plans/snapshots/). +-- This ensures that uncommitted progress or interim state is never permanently lost. +-- +-- 2. __Hermetic Object Store Restoration:__ +-- Restoration checks out objects exclusively from the detached Git store +-- using explicit tree pathspecs (@git checkout -- @). +-- No ambient child repository checkouts or working files outside the governed +-- set are inspected or modified. +-- +-- 3. __Byte-Level Verification Invariant:__ +-- Every restored file is verified post-checkout by comparing its raw disk bytes +-- against the cryptographic blob stored in the Git object database at the target +-- revision (@git cat-file -p :@). Any mismatch immediately reports +-- an integrity verification failure. +-- +-- 4. __Audit Trail & Attribution Preservation:__ +-- Checkpoints recorded during plan governance preserve Sarutahiko RFC 2822 +-- attribution trailers (@Assisted-by:@, @Orchestrated-by:@). Rollback queries +-- expose structured log history and semantic diffs without losing provenance. +-- +-- 5. __Zero Partial Functions Invariant:__ +-- All parsing, string splitting, path manipulation, and tree queries are +-- strictly total. No partial functions (such as unsafe indexing or extraction) +-- are permitted in the rollback or CLI governance pipelines. +module Gachi.Plan.Rollback + ( -- * Atomic Rollback & Verification + rollbackToCheckpoint + , verifyFilesIntegrity + , verifySingleFile + + -- * Differential Analysis & Log Queries + , computePlanDiff + , queryPlanLog + + -- * Checkpoint Creation & Attribution + , createPlanCheckpoint + , formatSarutahikoCommitMessage + , extractTrailers + + -- * Path & Snapshot Resolution + , resolveSnapshotDirForStore + ) where + +import Control.Exception (SomeException, catch) +import Control.Monad (filterM) +import qualified Data.ByteString as BS +import Data.Char (isAsciiLower, isAsciiUpper) +import Data.Foldable (for_) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import GHC.IO.Exception (ExitCode(..)) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , makeAbsolute + ) +import System.Environment (lookupEnv) +import System.FilePath (()) +import System.IO (hClose, hGetContents) +import System.Process + ( CreateProcess(..) + , StdStream(..) + , createProcess + , proc + , waitForProcess + ) +import Text.Read (readMaybe) + +import Gachi.Plan.Snapshot + ( createSnapshot + , resolvePlanSnapshotDir + ) +import Gachi.Plan.Store + ( commitStore + , runGitInStore + , trackGovernedFiles + ) +import Gachi.Plan.Types + ( CheckpointResult(..) + , PlanCommit(..) + , PlanDiff(..) + , PlanError(..) + , PlanStore(..) + , RollbackResult(..) + , SnapshotMeta(..) + , defaultSnapshotDirName + , planSnapshotDirEnvVar + ) + +-- | Resolves the snapshot ledger directory for a given 'PlanStore'. +-- +-- Precedence: +-- 1. Environment variable @PLAN_SNAPSHOT_DIR@ (if set and non-empty). +-- 2. @plans/snapshots@ relative to 'planWorkTree' (if exists or if @plans@ dir exists). +-- 3. Canonical default snapshot directory via 'resolvePlanSnapshotDir'. +resolveSnapshotDirForStore :: PlanStore -> IO FilePath +resolveSnapshotDirForStore store = do + mEnv <- lookupEnv planSnapshotDirEnvVar + case mEnv of + Just envPath | not (null envPath) -> makeAbsolute envPath + _ -> do + let workSnapDir = planWorkTree store defaultSnapshotDirName + workSnapExists <- doesDirectoryExist workSnapDir + if workSnapExists + then makeAbsolute workSnapDir + else do + let workPlansDir = planWorkTree store "plans" + workPlansExists <- doesDirectoryExist workPlansDir + if workPlansExists + then makeAbsolute workSnapDir + else resolvePlanSnapshotDir Nothing + +-- | Executes low-level git invocation hermetically inside detached store, capturing raw bytes. +runGitInStoreBytes :: PlanStore -> [String] -> IO (ExitCode, BS.ByteString, Text) +runGitInStoreBytes store args = do + let storeArgs = + [ "--git-dir=" ++ planGitDir store + , "--work-tree=" ++ planWorkTree store + ] ++ args + let p = (proc "git" storeArgs) + { std_out = CreatePipe + , std_err = CreatePipe + } + catch + (do (mIn, mOut, mErr, ph) <- createProcess p + for_ mIn hClose + outBytes <- case mOut of + Just outh -> BS.hGetContents outh + Nothing -> pure BS.empty + errStr <- case mErr of + Just errh -> hGetContents errh + Nothing -> pure "" + exitCode <- waitForProcess ph + pure (exitCode, outBytes, T.pack errStr) + ) + (\(err :: SomeException) -> pure (ExitFailure 127, BS.empty, T.pack (show err))) + +-- | Verifies a single restored file on disk against the raw blob stored in the detached Git store. +verifySingleFile :: PlanStore -> Text -> FilePath -> IO (Either PlanError Bool) +verifySingleFile store commitSha relPath = do + let fullPath = planWorkTree store relPath + diskExists <- doesFileExist fullPath + if not diskExists + then pure (Right False) + else do + diskBytes <- BS.readFile fullPath + let gitObjSpec = T.unpack commitSha ++ ":" ++ relPath + (code, blobBytes, _) <- runGitInStoreBytes store ["cat-file", "-p", gitObjSpec] + case code of + ExitSuccess -> pure (Right (diskBytes == blobBytes)) + ExitFailure _ -> pure (Right False) + +-- | Verifies bitwise integrity for a collection of restored files against the target commit. +verifyFilesIntegrity :: PlanStore -> Text -> [FilePath] -> IO (Either PlanError Bool) +verifyFilesIntegrity _ _ [] = pure (Right True) +verifyFilesIntegrity store commitSha files = do + results <- mapM (verifySingleFile store commitSha) files + case sequence results of + Left err -> pure (Left err) + Right bools -> pure (Right (and bools)) + +-- | Deterministically rolls back ecosystem planning state to a specified checkpoint reference. +-- +-- In accordance with Note [Deterministic Plan Rollback Invariants] +-- [ref:note-plan-rollback-invariants]: +-- 1. Validates that the target revision exists in the detached Git repository. +-- 2. Records pre-mutation safety snapshots of all governed files currently existing on disk. +-- 3. Restores governed files from the Git object store (@git checkout -- @). +-- 4. Verifies byte-level integrity by comparing restored disk contents with Git blob objects. +rollbackToCheckpoint :: PlanStore -> Text -> IO (Either PlanError RollbackResult) +rollbackToCheckpoint store targetRef = do + -- 1. Validate target ref in store + (revCode, revOut, revErr) <- runGitInStore store ["rev-parse", "--verify", T.unpack targetRef ++ "^{commit}"] + case revCode of + ExitFailure _ -> pure (Left (PlanGitError ("Target ref does not exist: " <> targetRef <> " (" <> revErr <> ")"))) + ExitSuccess -> do + let resolvedSha = T.strip revOut + + -- 2. Identify governed files present in target revision + (treeCode, treeOut, _) <- runGitInStore store ["ls-tree", "-r", "--name-only", T.unpack resolvedSha] + let filesInCommit = + case treeCode of + ExitSuccess -> + let treeLines = map T.unpack (T.lines treeOut) + in filter (`elem` planGovernedFiles store) treeLines + ExitFailure _ -> [] + filesToCheckout = + if null filesInCommit + then planGovernedFiles store + else filesInCommit + + -- 3. Take pre-mutation safety snapshots of all existing governed files on disk + snapDir <- resolveSnapshotDirForStore store + createDirectoryIfMissing True snapDir + let workRoot = planWorkTree store + existingWorkFiles <- filterM (\f -> doesFileExist (workRoot f)) (planGovernedFiles store) + safetySnapsEither <- mapM (\f -> createSnapshot snapDir (workRoot f) False) existingWorkFiles + case sequence safetySnapsEither of + Left err -> pure (Left err) + Right safetySnaps -> do + -- 4. Restore target files via git checkout + (checkoutCode, _, checkoutErr) <- + runGitInStore store (["checkout", T.unpack resolvedSha, "--"] ++ filesToCheckout) + case checkoutCode of + ExitFailure _ -> pure (Left (PlanGitError ("Git checkout failed: " <> checkoutErr))) + ExitSuccess -> do + -- 5. Verify byte-level integrity + verifyRes <- verifyFilesIntegrity store resolvedSha filesToCheckout + case verifyRes of + Left err -> pure (Left err) + Right verified -> + pure (Right RollbackResult + { rollbackTargetRef = resolvedSha + , rollbackSafetySnapshots = safetySnaps + , rollbackRestoredFiles = filesToCheckout + , rollbackVerified = verified + }) + +-- | Computes unified diff of governed documents between working tree and a Git revision. +computePlanDiff :: PlanStore -> Maybe Text -> IO (Either PlanError PlanDiff) +computePlanDiff store mTargetRevision = do + let baseDiffArgs = + case mTargetRevision of + Just rev -> ["diff", T.unpack rev, "--"] + Nothing -> ["diff", "HEAD", "--"] + diffArgs = baseDiffArgs ++ planGovernedFiles store + (code, stdoutTxt, stderrTxt) <- runGitInStore store diffArgs + case code of + ExitFailure _ -> pure (Left (PlanGitError stderrTxt)) + ExitSuccess -> do + let nameArgs = + (case mTargetRevision of + Just rev -> ["diff", "--name-only", T.unpack rev, "--"] + Nothing -> ["diff", "--name-only", "HEAD", "--"]) + ++ planGovernedFiles store + (nameCode, nameOut, _) <- runGitInStore store nameArgs + let changed = + case nameCode of + ExitSuccess -> filter (not . null) (map T.unpack (T.lines nameOut)) + ExitFailure _ -> [] + + diffLines = T.lines stdoutTxt + isAdd l = "+" `T.isPrefixOf` l && not ("+++" `T.isPrefixOf` l) + isDel l = "-" `T.isPrefixOf` l && not ("---" `T.isPrefixOf` l) + addCount = length (filter isAdd diffLines) + delCount = length (filter isDel diffLines) + + pure (Right PlanDiff + { diffTargetRef = mTargetRevision + , diffRawContent = stdoutTxt + , diffChangedFiles = changed + , diffAdditions = addCount + , diffDeletions = delCount + }) + +-- | Parses a single commit record emitted with delimiter bytes. +parseCommitRecord :: Text -> PlanCommit +parseCommitRecord rawRecord = + let fields = T.splitOn "\x1f" rawRecord + getFld idx = case drop idx fields of + (val:_) -> val + [] -> "" + cHash = T.strip (getFld 0) + cShortHash = T.strip (getFld 1) + cAuthor = T.strip (getFld 2) + cTimeSec = T.strip (getFld 3) + cSubject = T.strip (getFld 4) + cBody = T.strip (getFld 5) + cTimestamp = + case (readMaybe (T.unpack cTimeSec) :: Maybe Integer) of + Just s -> posixSecondsToUTCTime (fromIntegral s) + Nothing -> posixSecondsToUTCTime 0 + trailers = extractTrailers cBody + in PlanCommit + { commitHash = cHash + , commitShortHash = cShortHash + , commitAuthor = cAuthor + , commitTimestamp = cTimestamp + , commitSubject = cSubject + , commitBody = cBody + , commitTrailers = trailers + } + +-- | Extracts RFC 2822 git trailers from a commit body. +extractTrailers :: Text -> [(Text, Text)] +extractTrailers bodyText = + let bodyLines = map T.strip (T.lines bodyText) + parseTrailerLine line = + case T.breakOn ":" line of + (k, rest) + | not (T.null rest) && isTrailerKey k -> + let val = T.strip (T.drop 1 rest) + in Just (k, val) + _ -> Nothing + isTrailerKey k = + not (T.null k) && T.all (\c -> c == '-' || isAsciiLower c || isAsciiUpper c) k + in mapMaybe parseTrailerLine bodyLines + +-- | Queries the chronological commit log of plan governance history. +queryPlanLog :: PlanStore -> Int -> IO (Either PlanError [PlanCommit]) +queryPlanLog store limit = do + let n = if limit <= 0 then 20 else limit + logFormat = "--format=%H%x1f%h%x1f%an <%ae>%x1f%ct%x1f%s%x1f%b%x1e" + args = ["log", "-n", show n, logFormat, "--"] ++ planGovernedFiles store + (code, stdoutTxt, stderrTxt) <- runGitInStore store args + case code of + ExitFailure _ -> + if "does not have any commits yet" `T.isInfixOf` stderrTxt + || "fatal: your current branch 'master' does not have any commits yet" `T.isInfixOf` stderrTxt + || "fatal: your current branch 'main' does not have any commits yet" `T.isInfixOf` stderrTxt + then pure (Right []) + else pure (Left (PlanGitError stderrTxt)) + ExitSuccess -> do + let rawRecords = T.splitOn "\x1e" stdoutTxt + nonEmptyRecords = filter (not . T.null . T.strip) rawRecords + parsedCommits = map parseCommitRecord nonEmptyRecords + pure (Right parsedCommits) + +-- | Formats a commit message with canonical Sarutahiko RFC 2822 commit attribution trailers. +formatSarutahikoCommitMessage :: Text -> Text +formatSarutahikoCommitMessage rawMsg = + let msg = T.strip rawMsg + effectiveMsg = if T.null msg then "Ecosystem plan governance checkpoint" else msg + hasAssisted = "Assisted-by:" `T.isInfixOf` effectiveMsg + hasOrchestrated = "Orchestrated-by:" `T.isInfixOf` effectiveMsg + trailers = case (hasAssisted, hasOrchestrated) of + (True, True) -> "" + (True, False) -> "\nOrchestrated-by: Sarutahiko" + (False, True) -> "\nAssisted-by: Antigravity" + (False, False) -> "\nAssisted-by: Antigravity\nOrchestrated-by: Sarutahiko" + in if T.null trailers + then effectiveMsg + else effectiveMsg <> "\n" <> trailers + +-- | Creates an atomic plan milestone checkpoint. +-- +-- 1. Takes pre-mutation snapshots marked as milestone checkpoints for all existing governed files. +-- 2. Stages all existing governed files in the detached Git store. +-- 3. Atomically commits them with Sarutahiko RFC 2822 commit attribution trailers. +createPlanCheckpoint :: PlanStore -> Maybe Text -> IO (Either PlanError CheckpointResult) +createPlanCheckpoint store mUserMsg = do + let workRoot = planWorkTree store + existingFiles <- filterM (\f -> doesFileExist (workRoot f)) (planGovernedFiles store) + if null existingFiles + then pure (Left (PlanIOError "No governed files found on disk to checkpoint")) + else do + snapDir <- resolveSnapshotDirForStore store + createDirectoryIfMissing True snapDir + snapsEither <- mapM (\f -> createSnapshot snapDir (workRoot f) True) existingFiles + case sequence snapsEither of + Left err -> pure (Left err) + Right snapshots -> do + stageRes <- trackGovernedFiles store + case stageRes of + Left err -> pure (Left err) + Right stagedPaths -> do + let rawMsg = fromMaybe "Ecosystem plan governance checkpoint" mUserMsg + formattedMsg = formatSarutahikoCommitMessage rawMsg + commitRes <- commitStore store formattedMsg + case commitRes of + Left err -> pure (Left err) + Right commitSha -> + pure (Right CheckpointResult + { checkpointCommitSha = commitSha + , checkpointSnapshots = snapshots + , checkpointStagedFiles = stagedPaths + , checkpointMessage = formattedMsg + }) diff --git a/src/Gachi/Plan/Snapshot.hs b/src/Gachi/Plan/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Plan/Snapshot.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Plan.Snapshot +-- Description: Append-only snapshot ledger engine with SHA-256 integrity verification +-- +-- This module implements Milestone 5.2 of Phase 5 (Ecosystem Plan Governance & Rollback +-- per ~/src/PLAN.md §1.A). It provides an append-only snapshot ledger engine writing +-- immutable pre-mutation backups to @~/src/plans/snapshots/@ (configurable via +-- @PLAN_SNAPSHOT_DIR@). +-- +-- = Architectural Context & Invariants +-- +-- Note [Append-Only Plan Snapshot Invariants] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- [tag:note-plan-snapshots] +-- The plan snapshot ledger operates as an immutable, append-only repository of +-- pre-mutation state backups and milestone checkpoints located in +-- @~/src/plans/snapshots/@ (configurable via @PLAN_SNAPSHOT_DIR@). +-- +-- Core Invariants: +-- 1. __Append-Only Immutability Invariant:__ +-- Snapshots are strictly write-once. Once written, snapshot files and their +-- associated sidecars are marked read-only on the filesystem (owner write permission +-- revoked). Pre-existing snapshot files are never overwritten in-place under any +-- circumstances. +-- +-- 2. __Cryptographic Sidecar Verification:__ +-- Every snapshot file is accompanied by a companion @.sha256@ digest sidecar +-- (e.g. @2026-10-28-174500-PLAN.md.sha256@) containing the NIST FIPS 180-2 +-- SHA-256 checksum calculated over the immutable snapshot bytes. Tamper detection +-- verifies bitwise equivalence between the sidecar digest and recomputed file hash. +-- +-- 3. __Deterministic Timestamped Naming:__ +-- Snapshot files follow the canonical timestamp format: +-- @YYYY-MM-DD-HHMMSS-@ for standard pre-mutation safety backups, and +-- @YYYY-MM-DD-HHMMSS-checkpoint-@ (with companion @.checkpoint@ sidecar) +-- for milestone checkpoints. +-- +-- 4. __Milestone Checkpoint Preservation:__ +-- Automated snapshot pruning enforces a retention window for ephemeral pre-mutation +-- snapshots while permanently preserving milestone checkpoints. Checkpoints marked +-- with semantic labels are strictly exempt from pruning regardless of age or +-- retention counts. +-- +-- 5. __Zero Partial Functions:__ +-- All filesystem discovery, path slicing, sidecar parsing, and timestamp extraction +-- routines are implemented using total pattern matching and safe combinators. +-- No unsafe partial functions or partial list indexing operations are permitted. +module Gachi.Plan.Snapshot + ( -- * Snapshot Creation & Verification + createSnapshot + , createSnapshotAt + , verifySnapshotIntegrity + + -- * Ledger Querying & Pruning + , listSnapshots + , pruneSnapshots + + -- * Path & Environment Resolution + , resolvePlanSnapshotDir + + -- * Low-Level Hashing & Sidecars + , computeFileSha256 + , writeSha256Sidecar + ) where + +import Control.Exception (SomeException, catch) +import Control.Monad (forM_, when) +import qualified Data.ByteString as BS +import Data.Char (isHexDigit, toLower) +import Data.List (isPrefixOf, isSuffixOf, sortOn) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time + ( UTCTime + , defaultTimeLocale + , formatTime + , getCurrentTime + , parseTimeM + ) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getHomeDirectory + , getPermissions + , listDirectory + , makeAbsolute + , removeFile + , setOwnerWritable + , setPermissions + ) +import System.Environment (lookupEnv) +import System.FilePath ((<.>), (), takeFileName) + +import Gachi.Plan.Types + ( PlanError(..) + , SnapshotMeta(..) + , defaultSnapshotDirName + , planSnapshotDirEnvVar + ) +import Gachi.Sync.Hash (sha256ByteString) + +-- | Resolves the target snapshot ledger directory. +-- +-- Precedence: +-- 1. Explicitly provided 'FilePath' argument (if 'Just'). +-- 2. Environment variable @PLAN_SNAPSHOT_DIR@ (if set and non-empty). +-- 3. Canonical default at @~/src/plans/snapshots@ relative to the user's home directory. +resolvePlanSnapshotDir :: Maybe FilePath -> IO FilePath +resolvePlanSnapshotDir (Just p) = makeAbsolute p +resolvePlanSnapshotDir Nothing = do + mEnv <- lookupEnv planSnapshotDirEnvVar + case mEnv of + Just envPath | not (null envPath) -> makeAbsolute envPath + _ -> do + home <- getHomeDirectory + let srcPlansDir = home "src" defaultSnapshotDirName + srcPlansExists <- doesDirectoryExist (home "src") + if srcPlansExists + then makeAbsolute srcPlansDir + else makeAbsolute (home defaultSnapshotDirName) + +-- | Computes the hexadecimal SHA-256 digest of a target file. +computeFileSha256 :: FilePath -> IO (Either PlanError Text) +computeFileSha256 path = do + exists <- doesFileExist path + if not exists + then pure (Left (PlanIOError ("Cannot compute hash: file does not exist: " <> T.pack path))) + else catch + (do bytes <- BS.readFile path + pure (Right (sha256ByteString bytes))) + (\(err :: SomeException) -> + pure (Left (PlanIOError ("Error reading file for hash: " <> T.pack (show err))))) + +-- | Writes a companion @.sha256@ sidecar file adjacent to the target snapshot file. +-- +-- Sets the resulting sidecar to read-only mode to enforce immutability. +writeSha256Sidecar :: FilePath -> Text -> IO (Either PlanError FilePath) +writeSha256Sidecar snapshotFile digest = do + let sidecarFile = snapshotFile <.> "sha256" + sidecarContent = digest <> "\n" + catch + (do BS.writeFile sidecarFile (TE.encodeUtf8 sidecarContent) + perms <- getPermissions sidecarFile + setPermissions sidecarFile (setOwnerWritable False perms) + pure (Right sidecarFile)) + (\(err :: SomeException) -> + pure (Left (PlanIOError ("Failed to write sha256 sidecar: " <> T.pack (show err))))) + +-- | Creates an immutable, timestamped snapshot of a target file in the snapshot directory. +-- +-- In accordance with Note [Append-Only Plan Snapshot Invariants] [ref:note-plan-snapshots], +-- this operation: +-- 1. Copies target governance file into snapshot directory with a @YYYY-MM-DD-HHMMSS-@ prefix. +-- 2. If 'isCheckpoint' is 'True', inserts a @-checkpoint-@ infix and writes a @.checkpoint@ marker. +-- 3. Computes the cryptographic SHA-256 digest and writes a companion @.sha256@ sidecar. +-- 4. Revokes owner write permissions on both files, enforcing the append-only invariant. +-- +-- Accepts parameters in either order: @(snapshotDir, targetFile)@ or @(targetFile, snapshotDir)@. +createSnapshot :: FilePath -> FilePath -> Bool -> IO (Either PlanError SnapshotMeta) +createSnapshot p1 p2 isCheckpoint = do + now <- getCurrentTime + createSnapshotAt now p1 p2 isCheckpoint + +-- | Deterministic snapshot creation at a designated 'UTCTime' timestamp. +createSnapshotAt :: UTCTime -> FilePath -> FilePath -> Bool -> IO (Either PlanError SnapshotMeta) +createSnapshotAt timestamp p1 p2 isCheckpoint = do + -- Resolve arguments: detect if caller passed (targetFile, snapshotDir) or (snapshotDir, targetFile) + p1IsFile <- doesFileExist p1 + p2IsFile <- doesFileExist p2 + let (snapshotDir, targetFile) = + if p1IsFile && not p2IsFile + then (p2, p1) + else (p1, p2) + + targetExists <- doesFileExist targetFile + if not targetExists + then pure (Left (PlanIOError ("Target file does not exist: " <> T.pack targetFile))) + else do + createDirectoryIfMissing True snapshotDir + let timePrefix = formatTime defaultTimeLocale "%Y-%m-%d-%H%M%S" timestamp + baseName = takeFileName targetFile + snapshotFileName = + if isCheckpoint + then timePrefix ++ "-checkpoint-" ++ baseName + else timePrefix ++ "-" ++ baseName + targetSnapshotPath = snapshotDir snapshotFileName + sidecarPath = targetSnapshotPath <.> "sha256" + checkpointMarkerPath = targetSnapshotPath <.> "checkpoint" + + alreadyExists <- doesFileExist targetSnapshotPath + if alreadyExists + then pure (Left (PlanIOError ("Snapshot file already exists (append-only invariant): " <> T.pack targetSnapshotPath))) + else catch + (do -- 1. Read source bytes + contentBytes <- BS.readFile targetFile + let digest = sha256ByteString contentBytes + + -- 2. Write snapshot file + BS.writeFile targetSnapshotPath contentBytes + + -- 3. Write sidecar file + BS.writeFile sidecarPath (TE.encodeUtf8 (digest <> "\n")) + + -- 4. Write checkpoint marker if checkpoint + when isCheckpoint $ + BS.writeFile checkpointMarkerPath (TE.encodeUtf8 "checkpoint\n") + + -- 5. Revoke write permissions to ensure immutability + perms1 <- getPermissions targetSnapshotPath + setPermissions targetSnapshotPath (setOwnerWritable False perms1) + + perms2 <- getPermissions sidecarPath + setPermissions sidecarPath (setOwnerWritable False perms2) + + when isCheckpoint $ do + perms3 <- getPermissions checkpointMarkerPath + setPermissions checkpointMarkerPath (setOwnerWritable False perms3) + + absSnapshotPath <- makeAbsolute targetSnapshotPath + let meta = SnapshotMeta + { snapshotId = T.pack snapshotFileName + , snapshotPath = absSnapshotPath + , snapshotTimestamp = timestamp + , snapshotSha256 = digest + , snapshotSourceFile = baseName + , snapshotIsCheckpoint = isCheckpoint + } + pure (Right meta)) + (\(err :: SomeException) -> + pure (Left (PlanIOError ("Failed to create snapshot: " <> T.pack (show err))))) + +-- | Verifies the cryptographic integrity of a snapshot against its @.sha256@ sidecar. +-- +-- Recomputes the SHA-256 digest of the snapshot file and verifies equality with the +-- digest recorded in the companion sidecar file. Returns 'True' if matching, 'False' +-- if corrupted or tampered with. +verifySnapshotIntegrity :: FilePath -> IO (Either PlanError Bool) +verifySnapshotIntegrity snapshotPath = do + snapshotExists <- doesFileExist snapshotPath + if not snapshotExists + then pure (Left (PlanIOError ("Snapshot file missing: " <> T.pack snapshotPath))) + else do + let sidecarPath = snapshotPath <.> "sha256" + sidecarExists <- doesFileExist sidecarPath + if not sidecarExists + then pure (Left (PlanIOError ("Sidecar checksum file missing: " <> T.pack sidecarPath))) + else catch + (do snapshotBytes <- BS.readFile snapshotPath + sidecarBytes <- BS.readFile sidecarPath + let computedDigest = sha256ByteString snapshotBytes + rawSidecarText = TE.decodeUtf8Lenient sidecarBytes + expectedDigest = extractDigestText rawSidecarText + pure (Right (computedDigest == expectedDigest))) + (\(err :: SomeException) -> + pure (Left (PlanIOError ("Error reading files for integrity verification: " <> T.pack (show err))))) + where + -- Extracts first 64-character hex sequence from sidecar content + extractDigestText :: Text -> Text + extractDigestText t = + let candidateWords = T.words t + in case candidateWords of + [] -> "" + (w:_) -> + let hexChars = filter isHexDigit (map toLower (T.unpack w)) + in T.pack (take 64 hexChars) + +-- | Lists all snapshots recorded in the snapshot ledger in ordered chronological sequence. +-- +-- Discovers all timestamped snapshot files in @snapshotDir@, excluding @.sha256@ and +-- @.checkpoint@ sidecars, and parses their metadata. +listSnapshots :: FilePath -> IO [SnapshotMeta] +listSnapshots snapshotDir = do + dirExists <- doesDirectoryExist snapshotDir + if not dirExists + then pure [] + else do + entries <- listDirectory snapshotDir + absDir <- makeAbsolute snapshotDir + let candidateFiles = filter isSnapshotFile entries + metas <- mapMaybeM (parseSnapshotEntry absDir) candidateFiles + pure (sortOn snapshotTimestamp metas) + where + isSnapshotFile :: FilePath -> Bool + isSnapshotFile name = + not ("." `isPrefixOf` name) + && not (".sha256" `isSuffixOf` name) + && not (".checkpoint" `isSuffixOf` name) + && not (".tmp" `isSuffixOf` name) + + mapMaybeM :: (a -> IO (Maybe b)) -> [a] -> IO [b] + mapMaybeM _ [] = pure [] + mapMaybeM f (x:xs) = do + mRes <- f x + rest <- mapMaybeM f xs + case mRes of + Nothing -> pure rest + Just val -> pure (val : rest) + + parseSnapshotEntry :: FilePath -> FilePath -> IO (Maybe SnapshotMeta) + parseSnapshotEntry dir name = do + let fullPath = dir name + isFile <- doesFileExist fullPath + if not isFile + then pure Nothing + else do + -- Filename format: YYYY-MM-DD-HHMMSS-[checkpoint-] + -- Prefix length: 17 chars (e.g. "2026-10-28-174500") + let prefixStr = take 17 name + case parseTimeM True defaultTimeLocale "%Y-%m-%d-%H%M%S" prefixStr of + Nothing -> pure Nothing + Just (parsedTime :: UTCTime) -> do + let remaining = drop 18 name -- skip prefix and hyphen + (isCpByName, sourceName) = + if "checkpoint-" `isPrefixOf` remaining + then (True, drop 11 remaining) + else (False, remaining) + + cpMarkerExists <- doesFileExist (fullPath <.> "checkpoint") + let isCheckpoint = isCpByName || cpMarkerExists + + -- Read sha256 from sidecar if present, otherwise compute + let sidecarFile = fullPath <.> "sha256" + hasSidecar <- doesFileExist sidecarFile + shaText <- + if hasSidecar + then catch + (do raw <- BS.readFile sidecarFile + let rawText = TE.decodeUtf8Lenient raw + wordsList = T.words rawText + case wordsList of + [] -> pure "" + (w:_) -> pure (T.pack (take 64 (filter isHexDigit (map toLower (T.unpack w)))))) + (\(_ :: SomeException) -> pure "") + else catch + (do bytes <- BS.readFile fullPath + pure (sha256ByteString bytes)) + (\(_ :: SomeException) -> pure "") + + pure (Just (SnapshotMeta + { snapshotId = T.pack name + , snapshotPath = fullPath + , snapshotTimestamp = parsedTime + , snapshotSha256 = shaText + , snapshotSourceFile = sourceName + , snapshotIsCheckpoint = isCheckpoint + })) + +-- | Prunes older non-checkpoint snapshots beyond the designated retention count threshold. +-- +-- In accordance with Note [Append-Only Plan Snapshot Invariants] [ref:note-plan-snapshots], +-- milestone checkpoints are permanently preserved and never pruned. Only non-checkpoint +-- snapshots exceeding the retention limit are removed. +-- +-- Returns the count of pruned snapshots. +pruneSnapshots :: FilePath -> Int -> IO Int +pruneSnapshots snapshotDir retentionCount = do + allSnaps <- listSnapshots snapshotDir + let nonCheckpoints = filter (not . snapshotIsCheckpoint) allSnaps + retention = max 0 retentionCount + totalNonCp = length nonCheckpoints + + if totalNonCp <= retention + then pure 0 + else do + let pruneCount = totalNonCp - retention + toPrune = take pruneCount nonCheckpoints + forM_ toPrune $ \s -> deleteSnapshotFiles (snapshotPath s) + pure pruneCount + where + deleteSnapshotFiles :: FilePath -> IO () + deleteSnapshotFiles path = do + let shaPath = path <.> "sha256" + cpPath = path <.> "checkpoint" + forM_ [path, shaPath, cpPath] $ \p -> do + exists <- doesFileExist p + when exists $ + catch + (do perms <- getPermissions p + setPermissions p (setOwnerWritable True perms) + removeFile p) + (\(_ :: SomeException) -> + catch (removeFile p) (\(_ :: SomeException) -> pure ())) diff --git a/src/Gachi/Plan/Store.hs b/src/Gachi/Plan/Store.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Plan/Store.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Plan.Store +-- Description: Detached Git store lifecycle, probing, status, and tracking operations +-- +-- This module implements the detached Git store architecture for ecosystem plan +-- governance (~/src/PLAN.md §1.A, Phase 5, Milestone 5.1). +-- +-- = Architectural Context & Invariants +-- +-- Note [Plan Governance and Rollback Mechanics] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- [tag:note-plan-governance-rollback] +-- Ecosystem planning and operational frontier documents (@PLAN.md@, @STATE.md@, +-- @INDEX.md@, and @docs/INDEX.md@) across @~/src/@ are version-controlled via an +-- isolated, detached Git repository (@--git-dir= --work-tree=@) +-- and an append-only pre-mutation snapshot ledger per ~/src/PLAN.md §1.A. +-- +-- Core Invariants: +-- 1. __Non-Interference Invariant:__ Strictly avoids nested @.git@ collisions by +-- never writing @.git@ directories or metadata into child repository workspaces +-- (@~/src/gachi/.git@, @~/src/polytropos/.git@, etc.). The store is maintained +-- as a bare repository in an external directory (default @~/.plan.git@ or +-- @~/src/.plan.git@). +-- 2. __Governed Documents Invariant:__ Exclusively tracks top-level ecosystem +-- planning files and roadmap indexes, ignoring child directory workspaces +-- via explicit pathspec scoping (@-- @). Child project repositories +-- remain completely autonomous. +-- 3. __Hermetic Store Execution:__ All git operations are executed with explicit +-- @--git-dir@ and @--work-tree@ arguments, guaranteeing total independence +-- from ambient directory state or parent repository discovery. +-- 4. __Zero Partial Functions:__ Invariant enforcement and parsing strictly use +-- total pattern matching, eliminating any risk of runtime partial function crashes. +module Gachi.Plan.Store + ( -- * Store Lifecycle + initPlanStore + , isStoreInitialized + , resolvePlanStorePath + + -- * Status & Tracking Operations + , queryPlanStore + , listTrackedFiles + , trackGovernedFiles + , stageFiles + , commitStore + , getPlanStoreDiff + , governedFilesExist + + -- * Low-Level Execution + , runGitInStore + , runGitRaw + ) where + +import Control.Exception (SomeException, catch) +import Control.Monad (filterM) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import GHC.IO.Exception (ExitCode(..)) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getHomeDirectory + , makeAbsolute + ) +import System.Environment (lookupEnv) +import System.FilePath (()) +import System.Process (proc, readCreateProcessWithExitCode) +import Text.Read (readMaybe) + +import Gachi.Plan.Types + ( PlanError(..) + , PlanStore(..) + , PlanStoreStatus(..) + , defaultGovernedFiles + , defaultStoreName + , planGitDirEnvVar + ) + +-- | Resolves the target detached Git store directory. +-- +-- Precedence: +-- 1. Explicitly provided 'FilePath' argument (if 'Just'). +-- 2. Environment variable @PLAN_GIT_DIR@ (if set and non-empty). +-- 3. Canonical default at @~/.plan.git@ relative to the user's home directory. +resolvePlanStorePath :: Maybe FilePath -> IO FilePath +resolvePlanStorePath (Just p) = makeAbsolute p +resolvePlanStorePath Nothing = do + mEnv <- lookupEnv planGitDirEnvVar + case mEnv of + Just envPath | not (null envPath) -> makeAbsolute envPath + _ -> do + home <- getHomeDirectory + makeAbsolute (home defaultStoreName) + +-- | Low-level executor invoking git with specified arguments. +-- Safely catches execution exceptions (such as missing git binary). +runGitRaw :: [String] -> IO (ExitCode, Text, Text) +runGitRaw args = do + let processSpec = proc "git" args + (code, stdoutStr, stderrStr) <- + catch + (readCreateProcessWithExitCode processSpec "") + (\(err :: SomeException) -> pure (ExitFailure 127, "", show err)) + pure (code, T.pack stdoutStr, T.pack stderrStr) + +-- | Executes a git command hermetically inside the detached store context. +-- Explicitly prepends @--git-dir=@ and @--work-tree=@ to all invocations. +runGitInStore :: PlanStore -> [String] -> IO (ExitCode, Text, Text) +runGitInStore store args = do + let storeArgs = + [ "--git-dir=" ++ planGitDir store + , "--work-tree=" ++ planWorkTree store + ] ++ args + runGitRaw storeArgs + +-- | Checks whether a directory exists and constitutes a valid bare Git repository. +isStoreInitialized :: FilePath -> IO Bool +isStoreInitialized storePath = do + absPath <- makeAbsolute storePath + exists <- doesDirectoryExist absPath + if not exists + then pure False + else do + (code, _, _) <- runGitRaw ["--git-dir=" ++ absPath, "rev-parse", "--git-dir"] + pure (code == ExitSuccess) + +-- | Initializes or opens an isolated detached Git store. +-- +-- If the bare git repository at the given store directory does not yet exist, +-- this function creates the directory and executes @git init --bare@. +-- Ensures that the governed work tree root directory also exists. +-- +-- Returns a configured 'PlanStore' handle or a 'PlanError' upon initialization failure. +initPlanStore :: FilePath -> FilePath -> IO (Either PlanError PlanStore) +initPlanStore rawStorePath rawWorkTree = do + absStore <- makeAbsolute rawStorePath + absWork <- makeAbsolute rawWorkTree + createDirectoryIfMissing True absWork + + storeExists <- doesDirectoryExist absStore + if not storeExists + then do + createDirectoryIfMissing True absStore + (code, _, stderrTxt) <- runGitRaw ["init", "--bare", absStore] + case code of + ExitSuccess -> pure (Right (PlanStore absStore absWork defaultGovernedFiles)) + ExitFailure _ -> pure (Left (PlanGitError stderrTxt)) + else do + alreadyInit <- isStoreInitialized absStore + if alreadyInit + then pure (Right (PlanStore absStore absWork defaultGovernedFiles)) + else do + (code, _, stderrTxt) <- runGitRaw ["init", "--bare", absStore] + case code of + ExitSuccess -> pure (Right (PlanStore absStore absWork defaultGovernedFiles)) + ExitFailure _ -> pure (Left (PlanGitError stderrTxt)) + +-- | Lists all governed files currently tracked in the detached Git store index. +-- Runs @git ls-files@ against the detached store. +listTrackedFiles :: PlanStore -> IO [FilePath] +listTrackedFiles store = do + (code, stdoutTxt, _) <- runGitInStore store ["ls-files"] + case code of + ExitSuccess -> + let nonBlank = filter (not . null) (map T.unpack (T.lines stdoutTxt)) + in pure nonBlank + ExitFailure _ -> pure [] + +-- | Queries the status of the detached Git plan store. +-- +-- Inspects: +-- 1. Current HEAD commit SHA hash (or 'Nothing' if the repository is newly initialized). +-- 2. Last commit timestamp parsed from POSIX commit seconds. +-- 3. Currently tracked files via 'listTrackedFiles'. +-- 4. Dirty tracking status exclusively across governed files using pathspec scoping. +queryPlanStore :: PlanStore -> IO PlanStoreStatus +queryPlanStore store = do + -- 1. Query current HEAD commit SHA + (revCode, revOut, _) <- runGitInStore store ["rev-parse", "--verify", "HEAD"] + let currentHeadSha = + case revCode of + ExitSuccess -> + let stripped = T.strip revOut + in if T.null stripped then Nothing else Just stripped + ExitFailure _ -> Nothing + + -- 2. Query last commit timestamp (POSIX timestamp format via %ct) + commitTime <- + case currentHeadSha of + Nothing -> pure Nothing + Just _ -> do + (timeCode, timeOut, _) <- runGitInStore store ["log", "-1", "--format=%ct"] + case timeCode of + ExitSuccess -> + let s = T.unpack (T.strip timeOut) + in case (readMaybe s :: Maybe Integer) of + Just sec -> pure (Just (posixSecondsToUTCTime (fromIntegral sec))) + Nothing -> pure Nothing + ExitFailure _ -> pure Nothing + + -- 3. Query tracked files + trackedList <- listTrackedFiles store + + -- 4. Query dirty state restricted exclusively to governed files + let governed = planGovernedFiles store + (statusCode, statusOut, _) <- + if null governed + then runGitInStore store ["status", "--porcelain"] + else runGitInStore store (["status", "--porcelain", "--"] ++ governed) + + let porcelainLines = + case statusCode of + ExitSuccess -> map T.unpack (T.lines statusOut) + ExitFailure _ -> [] + + -- Extract path from porcelain status output "XY " + extractDirtyPath :: String -> Maybe FilePath + extractDirtyPath lineStr + | length lineStr > 3 = Just (drop 3 lineStr) + | otherwise = Nothing + + dirtyPaths = mapMaybe extractDirtyPath porcelainLines + dirtyFlag = not (null dirtyPaths) + + pure PlanStoreStatus + { statusStorePath = planGitDir store + , statusWorkTree = planWorkTree store + , statusHeadCommit = currentHeadSha + , statusIsDirty = dirtyFlag + , statusLastCommitTime = commitTime + , statusDirtyFiles = dirtyPaths + , statusTrackedFiles = trackedList + } + +-- | Stages specified relative file paths into the detached Git store index. +stageFiles :: PlanStore -> [FilePath] -> IO (Either PlanError ()) +stageFiles _ [] = pure (Right ()) +stageFiles store paths = do + (code, _, stderrTxt) <- runGitInStore store (["add", "--"] ++ paths) + case code of + ExitSuccess -> pure (Right ()) + ExitFailure _ -> pure (Left (PlanGitError stderrTxt)) + +-- | Automatically stages all canonical governed planning files that exist on disk in the worktree. +trackGovernedFiles :: PlanStore -> IO (Either PlanError [FilePath]) +trackGovernedFiles store = do + let workRoot = planWorkTree store + existingFiles <- filterM (\f -> doesFileExist (workRoot f)) (planGovernedFiles store) + case existingFiles of + [] -> pure (Right []) + filesToStage -> do + stageResult <- stageFiles store filesToStage + case stageResult of + Right () -> pure (Right filesToStage) + Left err -> pure (Left err) + +-- | Commits staged changes to the detached Git store with a given commit message. +-- Injects hermetic user identity configuration to prevent failures in unconfigured environments. +commitStore :: PlanStore -> Text -> IO (Either PlanError Text) +commitStore store message = do + let commitArgs = + [ "-c", "user.name=Gachi Plan Governance" + , "-c", "user.email=gachi-plan@ecosystem.local" + , "commit" + , "-m", T.unpack message + ] + (code, _, stderrTxt) <- runGitInStore store commitArgs + case code of + ExitSuccess -> do + (revCode, revOut, revErr) <- runGitInStore store ["rev-parse", "HEAD"] + case revCode of + ExitSuccess -> pure (Right (T.strip revOut)) + ExitFailure _ -> pure (Left (PlanGitError revErr)) + ExitFailure _ -> pure (Left (PlanGitError stderrTxt)) + +-- | Retrieves the Git diff of governed planning documents against HEAD or a specified revision. +getPlanStoreDiff :: PlanStore -> Maybe Text -> IO (Either PlanError Text) +getPlanStoreDiff store mTargetRevision = do + let baseArgs = + case mTargetRevision of + Just rev -> ["diff", T.unpack rev, "--"] + Nothing -> ["diff", "HEAD", "--"] + diffArgs = baseArgs ++ planGovernedFiles store + (code, stdoutTxt, stderrTxt) <- runGitInStore store diffArgs + case code of + ExitSuccess -> pure (Right stdoutTxt) + ExitFailure _ -> pure (Left (PlanGitError stderrTxt)) + +-- | Checks which governed planning files physically exist in the worktree directory on disk. +governedFilesExist :: PlanStore -> IO [(FilePath, Bool)] +governedFilesExist store = do + let root = planWorkTree store + mapM (\relPath -> do + exists <- doesFileExist (root relPath) + pure (relPath, exists) + ) (planGovernedFiles store) diff --git a/src/Gachi/Plan/Types.hs b/src/Gachi/Plan/Types.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Plan/Types.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Module: Gachi.Plan.Types +-- Description: Core types, models, and data structures for ecosystem plan governance +-- +-- This module defines the foundational algebraic data models for the isolated +-- detached Git store architecture (~/src/PLAN.md §1.A, Phase 5, Milestone 5.1). +-- +-- = Architectural Context & Invariants +-- +-- In accordance with Note [Plan Governance and Rollback Mechanics] +-- [ref:note-plan-governance-rollback], planning files across @~/src/@ are +-- tracked in an isolated detached Git repository without interfering with +-- child repository checkouts. This module formalizes the data models representing +-- the detached store configuration, execution errors, status queries, snapshot +-- ledger metadata, and governed document invariants. +-- +-- See also Note [Append-Only Plan Snapshot Invariants] [ref:note-plan-snapshots]. +module Gachi.Plan.Types + ( -- * Store Configuration + PlanStore(..) + , defaultGovernedFiles + , defaultStoreName + , planGitDirEnvVar + + -- * Snapshot Ledger Configuration & Metadata + , SnapshotMeta(..) + , planSnapshotDirEnvVar + , defaultSnapshotDirName + + -- * Store Status & Metadata + , PlanStoreStatus(..) + , isPlanStoreClean + + -- * Rollback, Diff & Log Models + , RollbackResult(..) + , PlanDiff(..) + , PlanCommit(..) + , CheckpointResult(..) + + -- * Failure Conditions + , PlanError(..) + ) where + +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +-- | Configuration and runtime handle for a detached Git plan store. +-- +-- The detached store separates the repository metadata directory (@--git-dir@) +-- from the working directory root (@--work-tree@). This architecture guarantees +-- that no nested @.git@ directory is created in @~/src/@, completely avoiding +-- collisions with child repository checkouts. +data PlanStore = PlanStore + { planGitDir :: !FilePath + -- ^ Absolute path to the detached bare Git repository directory + -- (e.g. @/home/nyc/.plan.git@ or @/home/nyc/src/.plan.git@). + , planWorkTree :: !FilePath + -- ^ Absolute path to the governed working tree root directory + -- (e.g. @/home/nyc/src@). + , planGovernedFiles :: ![FilePath] + -- ^ Canonical relative paths of governance documents tracked by the store. + } + deriving stock (Eq, Show, Generic) + +-- | Canonical ecosystem planning and governance files tracked by the detached store. +-- +-- Per Note [Plan Governance and Rollback Mechanics] [ref:note-plan-governance-rollback], +-- the detached Git store exclusively tracks top-level planning documents and roadmap +-- indexes across @~/src/@. +defaultGovernedFiles :: [FilePath] +defaultGovernedFiles = + [ "PLAN.md" + , "STATE.md" + , "INDEX.md" + , "docs/INDEX.md" + ] + +-- | Default name of the bare Git store directory relative to the home directory. +defaultStoreName :: FilePath +defaultStoreName = ".plan.git" + +-- | Standard environment variable name for overriding the detached Git store path. +planGitDirEnvVar :: String +planGitDirEnvVar = "PLAN_GIT_DIR" + +-- | Standard environment variable name for overriding the snapshot ledger directory. +planSnapshotDirEnvVar :: String +planSnapshotDirEnvVar = "PLAN_SNAPSHOT_DIR" + +-- | Default snapshot ledger directory relative to workspace root or home directory. +defaultSnapshotDirName :: FilePath +defaultSnapshotDirName = "plans/snapshots" + +-- | Metadata record describing an immutable snapshot within the snapshot ledger. +-- +-- In accordance with Note [Append-Only Plan Snapshot Invariants] [ref:note-plan-snapshots], +-- each snapshot preserves a byte-for-byte replica of a governed planning document +-- prior to mutation or at an explicit milestone checkpoint. +data SnapshotMeta = SnapshotMeta + { snapshotId :: !Text + -- ^ Unique snapshot identifier (typically matching the snapshot file name). + , snapshotPath :: !FilePath + -- ^ Absolute filesystem path to the immutable snapshot file. + , snapshotTimestamp :: !UTCTime + -- ^ Timestamp when the snapshot was recorded in UTC. + , snapshotSha256 :: !Text + -- ^ Cryptographic SHA-256 digest of the snapshot file contents. + , snapshotSourceFile :: !FilePath + -- ^ Original governed file name or relative path that was snapshotted (e.g. @"PLAN.md"@). + , snapshotIsCheckpoint :: !Bool + -- ^ Whether this snapshot marks an immutable milestone checkpoint exempt from automated pruning. + } + deriving stock (Eq, Show, Generic) + +-- | Observed runtime status, commit metadata, and dirty state of a detached Git plan store. +-- +-- Captures the current HEAD commit hash, dirty tracking state of governed files, +-- commit timestamp, and tracked file inventory. +data PlanStoreStatus = PlanStoreStatus + { statusStorePath :: !FilePath + -- ^ Absolute path to the detached Git store directory. + , statusWorkTree :: !FilePath + -- ^ Absolute path to the governed working tree root directory. + , statusHeadCommit :: !(Maybe Text) + -- ^ Full 40-character SHA-1 commit hash of the current HEAD revision, + -- or 'Nothing' if the repository is newly initialized without commits (unborn HEAD). + , statusIsDirty :: !Bool + -- ^ 'True' if any governed document has unstaged modifications, staged changes, + -- or exists untracked in the worktree. + , statusLastCommitTime :: !(Maybe UTCTime) + -- ^ Timestamp of the most recent commit in UTC, or 'Nothing' if unborn. + , statusDirtyFiles :: ![FilePath] + -- ^ Canonical relative paths of governed files that have uncommitted or untracked changes. + , statusTrackedFiles :: ![FilePath] + -- ^ Canonical relative paths of governed files currently tracked in the Git index. + } + deriving stock (Eq, Show, Generic) + +-- | Predicate checking whether a plan store has zero uncommitted or untracked changes. +isPlanStoreClean :: PlanStoreStatus -> Bool +isPlanStoreClean status = not (statusIsDirty status) + +-- | Outcome of an atomic rollback operation. +-- +-- In accordance with Note [Deterministic Plan Rollback Invariants] +-- [ref:note-plan-rollback-invariants], records the target commit hash, safety pre-mutation +-- snapshots taken prior to modifying disk state, list of restored governed files, +-- and bitwise integrity verification status. +data RollbackResult = RollbackResult + { rollbackTargetRef :: !Text + -- ^ The target commit hash or git reference to which the store was rolled back. + , rollbackSafetySnapshots :: ![SnapshotMeta] + -- ^ Pre-mutation safety snapshots recorded in the ledger prior to destructive checkout. + , rollbackRestoredFiles :: ![FilePath] + -- ^ Canonical relative paths of governed files successfully restored from the object store. + , rollbackVerified :: !Bool + -- ^ 'True' if restored file contents were verified for byte-level integrity against the git object store. + } + deriving stock (Eq, Show, Generic) + +-- | Structured diff report comparing working planning documents against a Git revision. +data PlanDiff = PlanDiff + { diffTargetRef :: !(Maybe Text) + -- ^ Target git reference compared against ('Nothing' indicates HEAD). + , diffRawContent :: !Text + -- ^ Raw unified diff text output from git diff. + , diffChangedFiles :: ![FilePath] + -- ^ Relative file paths of governed files exhibiting modifications. + , diffAdditions :: !Int + -- ^ Total number of added lines (+). + , diffDeletions :: !Int + -- ^ Total number of deleted lines (-). + } + deriving stock (Eq, Show, Generic) + +-- | Historical commit record retrieved from the detached Git plan store. +data PlanCommit = PlanCommit + { commitHash :: !Text + -- ^ Full 40-character SHA-1 commit hash. + , commitShortHash :: !Text + -- ^ Abbreviated commit hash (7 characters). + , commitAuthor :: !Text + -- ^ Author name and email stanza. + , commitTimestamp :: !UTCTime + -- ^ Commit timestamp in UTC. + , commitSubject :: !Text + -- ^ First line of commit message. + , commitBody :: !Text + -- ^ Commit message explanatory body. + , commitTrailers :: ![(Text, Text)] + -- ^ Parsed RFC 2822 git trailers (e.g. ("Assisted-by", "Antigravity")). + } + deriving stock (Eq, Show, Generic) + +-- | Outcome of creating a milestone checkpoint in the plan store. +data CheckpointResult = CheckpointResult + { checkpointCommitSha :: !Text + -- ^ Commit hash of the created checkpoint in the detached store. + , checkpointSnapshots :: ![SnapshotMeta] + -- ^ Immutable milestone snapshots recorded in the ledger. + , checkpointStagedFiles :: ![FilePath] + -- ^ Governed files staged and committed. + , checkpointMessage :: !Text + -- ^ Final commit message including attribution trailers. + } + deriving stock (Eq, Show, Generic) + +-- | Error conditions encountered during detached Git store lifecycle or operations. +data PlanError + = PlanGitError !Text + -- ^ An underlying git command exited with a non-zero exit code. + -- Contains the captured standard error output. + | PlanStoreMissing !FilePath + -- ^ The specified detached Git store directory does not exist or is not a valid bare Git repository. + | PlanWorkTreeMissing !FilePath + -- ^ The specified working tree root directory does not exist. + | PlanIOError !Text + -- ^ A filesystem or I/O failure occurred during store operations. + | PlanInvalidPath !FilePath + -- ^ A provided filesystem path is malformed or invalid. + deriving stock (Eq, Show, Generic) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Main (gachi-plan test suite) +-- Description: Unit and integration tests for detached Git plan store architecture +-- +-- Validates Milestone 5.1 of Phase 5 (Ecosystem Plan Governance & Rollback per ~/src/PLAN.md §1.A). +-- Tests detached bare Git repository lifecycle, non-interference invariants, +-- governed document tracking, dirty status detection, and commit metadata. +module Main (main) where + +import Control.Exception (SomeException, bracket, catch) +import Control.Monad (forM_) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time.Clock.POSIX (getPOSIXTime) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , getTemporaryDirectory + , removeDirectoryRecursive + ) +import System.FilePath (()) +import Test.Hspec + +import Gachi.Plan + ( PlanStore(..) + , PlanStoreStatus(..) + , commitStore + , defaultGovernedFiles + , getPlanStoreDiff + , governedFilesExist + , initPlanStore + , isPlanStoreClean + , isStoreInitialized + , listTrackedFiles + , queryPlanStore + , resolvePlanStorePath + , stageFiles + , trackGovernedFiles + ) + +-- | Helper executing an action within an isolated temporary directory. +withTempDir :: String -> (FilePath -> IO a) -> IO a +withTempDir prefix action = do + base <- getTemporaryDirectory + t <- getPOSIXTime + let dirPath = base (prefix ++ "-" ++ show (round (t * 1000) :: Integer)) + bracket + (createDirectoryIfMissing True dirPath >> pure dirPath) + (\p -> catch (removeDirectoryRecursive p) (\(_ :: SomeException) -> pure ())) + action + +main :: IO () +main = hspec $ do + describe "Gachi.Plan.Store (Detached Git Store Lifecycle)" $ do + it "initializes a fresh bare Git store in a temporary directory" $ do + withTempDir "gachi-plan-init" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + res <- initPlanStore storePath workPath + case res of + Left err -> expectationFailure ("initPlanStore failed: " ++ show err) + Right store -> do + planGitDir store `shouldBe` storePath + planWorkTree store `shouldBe` workPath + planGovernedFiles store `shouldBe` defaultGovernedFiles + isInit <- isStoreInitialized storePath + isInit `shouldBe` True + + it "idempotently re-initializes an already existing bare store" $ do + withTempDir "gachi-plan-reinit" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + res1 <- initPlanStore storePath workPath + case res1 of + Left err -> expectationFailure ("First init failed: " ++ show err) + Right _ -> do + res2 <- initPlanStore storePath workPath + case res2 of + Left err -> expectationFailure ("Second init failed: " ++ show err) + Right store2 -> do + isInit <- isStoreInitialized (planGitDir store2) + isInit `shouldBe` True + + it "resolves explicit store path to an absolute path" $ do + withTempDir "gachi-plan-resolve" $ \tmpDir -> do + let explicitPath = tmpDir "custom.git" + resolved <- resolvePlanStorePath (Just explicitPath) + resolved `shouldBe` explicitPath + + it "reports false for non-existent store directory" $ do + withTempDir "gachi-plan-missing" $ \tmpDir -> do + let bogusPath = tmpDir "does-not-exist.git" + isInit <- isStoreInitialized bogusPath + isInit `shouldBe` False + + describe "Gachi.Plan.Store (Non-Interference & Worktree Isolation Invariants)" $ do + it "strictly avoids creating .git in worktree root" $ do + withTempDir "gachi-plan-isolation" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + createDirectoryIfMissing True workPath + _ <- initPlanStore storePath workPath + -- Verify no .git directory or file was created in workPath + hasDotGit <- doesDirectoryExist (workPath ".git") + hasDotGit `shouldBe` False + + it "preserves child repository .git checkouts without interference" $ do + withTempDir "gachi-plan-children" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + childA = workPath "gachi" + childB = workPath "polytropos" + -- Simulate pre-existing child repository workspaces + createDirectoryIfMissing True (childA ".git") + createDirectoryIfMissing True (childB ".git") + TIO.writeFile (childA "Main.hs") "module Main where" + TIO.writeFile (childB "Lib.hs") "module Lib where" + + -- Initialize detached plan store at worktree root + res <- initPlanStore storePath workPath + case res of + Left err -> expectationFailure ("init failed: " ++ show err) + Right store -> do + -- Create top-level ecosystem plan files + TIO.writeFile (workPath "PLAN.md") "# Ecosystem Plan" + TIO.writeFile (workPath "STATE.md") "# Ecosystem State" + + -- Stage and commit governed files + stageRes <- trackGovernedFiles store + case stageRes of + Left err -> expectationFailure ("trackGovernedFiles failed: " ++ show err) + Right staged -> length staged `shouldBe` 2 + + commitRes <- commitStore store "Initial plan commit" + case commitRes of + Left err -> expectationFailure ("commitStore failed: " ++ show err) + Right commitSha -> T.length commitSha `shouldBe` 40 + + -- Child repo .git directories MUST remain intact + childAExists <- doesDirectoryExist (childA ".git") + childBExists <- doesDirectoryExist (childB ".git") + childAExists `shouldBe` True + childBExists `shouldBe` True + + -- Worktree root MUST NOT have a .git directory + rootDotGit <- doesDirectoryExist (workPath ".git") + rootDotGit `shouldBe` False + + describe "Gachi.Plan.Store (Governed File Tracking & Dirty Detection)" $ do + it "reports empty tracked files and clean state on fresh store" $ do + withTempDir "gachi-plan-empty" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + Right store <- initPlanStore storePath workPath + status <- queryPlanStore store + statusHeadCommit status `shouldBe` Nothing + statusLastCommitTime status `shouldBe` Nothing + statusTrackedFiles status `shouldBe` [] + statusDirtyFiles status `shouldBe` [] + statusIsDirty status `shouldBe` False + isPlanStoreClean status `shouldBe` True + + it "detects untracked governed planning files as dirty" $ do + withTempDir "gachi-plan-dirty" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + Right store <- initPlanStore storePath workPath + + -- Create mock governed planning files + TIO.writeFile (workPath "PLAN.md") "# Master Plan\n" + TIO.writeFile (workPath "STATE.md") "# Operational Frontier\n" + + status <- queryPlanStore store + statusIsDirty status `shouldBe` True + isPlanStoreClean status `shouldBe` False + statusDirtyFiles status `shouldContain` ["PLAN.md"] + statusDirtyFiles status `shouldContain` ["STATE.md"] + + it "ignores untracked files in child directories during dirty queries" $ do + withTempDir "gachi-plan-ignore-child" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + childDir = workPath "some-child-package" + createDirectoryIfMissing True childDir + Right store <- initPlanStore storePath workPath + + -- Write untracked file in child package + TIO.writeFile (childDir "SomeCode.hs") "module SomeCode where" + + -- Status should remain clean because governed files do not exist and child files are ignored + status <- queryPlanStore store + statusIsDirty status `shouldBe` False + statusDirtyFiles status `shouldBe` [] + + it "transitions from dirty to clean upon staging and committing" $ do + withTempDir "gachi-plan-commit" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + Right store <- initPlanStore storePath workPath + + -- Create all four canonical governed files + createDirectoryIfMissing True (workPath "docs") + TIO.writeFile (workPath "PLAN.md") "# Plan\n" + TIO.writeFile (workPath "STATE.md") "# State\n" + TIO.writeFile (workPath "INDEX.md") "# Index\n" + TIO.writeFile (workPath "docs" "INDEX.md") "# Docs Index\n" + + -- Check physical file presence + existList <- governedFilesExist store + length existList `shouldBe` 4 + forM_ existList $ \(_, exists) -> exists `shouldBe` True + + -- Stage governed files + stageRes <- stageFiles store ["PLAN.md", "STATE.md", "INDEX.md", "docs/INDEX.md"] + case stageRes of + Left err -> expectationFailure ("stageFiles failed: " ++ show err) + Right () -> pure () + + -- Files should now be tracked + tracked <- listTrackedFiles store + tracked `shouldContain` ["PLAN.md"] + tracked `shouldContain` ["STATE.md"] + tracked `shouldContain` ["INDEX.md"] + tracked `shouldContain` ["docs/INDEX.md"] + + -- Commit changes + commitRes <- commitStore store "Initial ecosystem governance checkpoint" + case commitRes of + Left err -> expectationFailure ("commitStore failed: " ++ show err) + Right commitSha -> do + T.length commitSha `shouldBe` 40 + + -- Query updated status: should be clean with HEAD commit and timestamp + status <- queryPlanStore store + statusHeadCommit status `shouldBe` Just commitSha + statusIsDirty status `shouldBe` False + isPlanStoreClean status `shouldBe` True + statusDirtyFiles status `shouldBe` [] + statusLastCommitTime status `shouldSatisfy` (/= Nothing) + + it "detects modifications to tracked planning documents and provides diff" $ do + withTempDir "gachi-plan-diff" $ \tmpDir -> do + let storePath = tmpDir "store.git" + workPath = tmpDir "work" + Right store <- initPlanStore storePath workPath + + -- Initialize and commit a plan + TIO.writeFile (workPath "PLAN.md") "# Version 1.0\n" + _ <- stageFiles store ["PLAN.md"] + _ <- commitStore store "Baseline commit" + + -- Verify clean + status1 <- queryPlanStore store + statusIsDirty status1 `shouldBe` False + + -- Modify PLAN.md + TIO.appendFile (workPath "PLAN.md") "Added Phase 5 milestone details.\n" + + -- Verify dirty + status2 <- queryPlanStore store + statusIsDirty status2 `shouldBe` True + statusDirtyFiles status2 `shouldContain` ["PLAN.md"] + + -- Inspect diff + diffRes <- getPlanStoreDiff store Nothing + case diffRes of + Left err -> expectationFailure ("diff failed: " ++ show err) + Right diffText -> do + T.isInfixOf "Added Phase 5 milestone details." diffText `shouldBe` True