Types.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Clod.Types
-- Description : Core types for the Clod application
-- Copyright   : (c) Fuzz Leonard, 2025
-- License     : MIT
-- Maintainer  : ink@fuzz.ink
-- Stability   : experimental
--
-- This module defines the core types used throughout the Clod application.
-- Clod is a utility for preparing and uploading files to Claude AI's Project Knowledge
-- feature. It tracks file changes, respects .gitignore and .clodignore patterns, and
-- optimizes filenames for Claude's UI.
--
-- The primary types include:
--
-- * 'ClodConfig' - Configuration for file processing and staging
-- * 'ClodM' - A monad for handling errors during file operations
-- * 'ClodError' - Various error types that can occur during operation
-- * 'FileResult' - Result of processing a file (success or skipped)

module Clod.Types
  ( -- * Core Types
    ClodConfig(..)
  , FileResult(..)
  , ClodError(..)
  , DatabaseErrorType(..)
  , ClodM
  , FileEntry(..)
  , ClodDatabase(..)
  , SerializableClodDatabase(..)
  , toSerializable
  , fromSerializable
  
    -- * Validation types and functions
  , Validated(..)
  , validatedToEither
  , eitherToValidated

    -- * Type conversions and runners
  , runClodM
  , throwError
  , catchError
  , liftIO
  , ask
  , asks
  , local
  , runReaderT
  , runExceptT
  
    -- * Newtypes for type safety
  , IgnorePattern(..)
  , OptimizedName(..)
  , OriginalPath(..)
  , Checksum(..)
  
    -- * Capability types
  , FileReadCap(..)
  , FileWriteCap(..)
  , fileReadCap
  , fileWriteCap
  
    -- * Path validation
  , isPathAllowed
    
    -- * Lens operators and accessors
  , (^.), (.~), (%~), (&)
    
    -- * Field lenses for ClodConfig
  , projectPath
  , stagingDir
  , configDir
  , databaseFile
  , timestamp
  , currentStaging
  , previousStaging
  , testMode
  , verbose
  , flushMode
  , lastMode
  , ignorePatterns
    
    -- * Field lenses for ClodDatabase
  , dbFiles
  , dbChecksums
  , dbLastStagingDir
  , dbLastRunTime
    
    -- * Field lenses for FileEntry
  , entryPath
  , entryChecksum
  , entryLastModified
  , entryOptimizedName
    
    -- * Field lenses for capability types
  , allowedReadDirs
  , allowedWriteDirs
  ) where

import Control.Monad.Except (ExceptT, runExceptT, throwError, catchError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
import Control.Lens (Lens', lens, (^.), (.~), (%~), (&), makePrisms)
import Data.String (IsString(..))
import GHC.Generics (Generic)
import Data.List (isPrefixOf)
import System.Directory (canonicalizePath)
import Data.Time.Clock (UTCTime)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Dhall (FromDhall, ToDhall)
import Data.Aeson (FromJSON, ToJSON)

-- | Newtype for ignore patterns to prevent mixing with other string types
newtype IgnorePattern = IgnorePattern { unIgnorePattern :: String }
  deriving (Show, Eq, Ord) via String
  deriving (IsString, Semigroup, Monoid) via String

-- | Newtype for optimized filename used in Claude's UI
newtype OptimizedName = OptimizedName { unOptimizedName :: String }
  deriving (Show, Eq, Ord) via String
  deriving (IsString, Semigroup, Monoid) via String
  deriving (Generic)

instance FromDhall OptimizedName
instance ToDhall OptimizedName
instance FromJSON OptimizedName
instance ToJSON OptimizedName

-- | Newtype for original filepath in the repository
newtype OriginalPath = OriginalPath { unOriginalPath :: String }
  deriving (Show, Eq, Ord) via String
  deriving (IsString, Semigroup, Monoid) via String
  deriving (Generic)

instance FromDhall OriginalPath
instance ToDhall OriginalPath
instance FromJSON OriginalPath
instance ToJSON OriginalPath

-- | Configuration for the clod program
data ClodConfig = ClodConfig
  { _projectPath    :: !FilePath      -- ^ Root path of the project
  , _stagingDir     :: !FilePath      -- ^ Directory where files will be staged for Claude
  , _configDir      :: !FilePath      -- ^ Directory for configuration files
  , _databaseFile   :: !FilePath      -- ^ Path to the checksums database file
  , _timestamp      :: !String        -- ^ Timestamp for the current run
  , _currentStaging :: !FilePath      -- ^ Path to the current staging directory
  , _previousStaging :: !(Maybe FilePath) -- ^ Path to the previous staging directory, if any
  , _testMode       :: !Bool          -- ^ Whether we're running in test mode
  , _verbose        :: !Bool          -- ^ Whether to print verbose output
  , _flushMode      :: !Bool          -- ^ Whether to flush stale entries from the database
  , _lastMode       :: !Bool          -- ^ Whether to use the previous staging directory
  , _ignorePatterns :: ![IgnorePattern] -- ^ Patterns from .gitignore and .clodignore
  } deriving stock (Show, Eq, Generic)

-- | Lens for projectPath field
projectPath :: Lens' ClodConfig FilePath
projectPath = lens _projectPath (\c v -> c { _projectPath = v })

-- | Lens for stagingDir field
stagingDir :: Lens' ClodConfig FilePath
stagingDir = lens _stagingDir (\c v -> c { _stagingDir = v })

-- | Lens for configDir field
configDir :: Lens' ClodConfig FilePath
configDir = lens _configDir (\c v -> c { _configDir = v })

-- | Lens for databaseFile field
databaseFile :: Lens' ClodConfig FilePath
databaseFile = lens _databaseFile (\c v -> c { _databaseFile = v })

-- | Lens for timestamp field
timestamp :: Lens' ClodConfig String
timestamp = lens _timestamp (\c v -> c { _timestamp = v })

-- | Lens for currentStaging field
currentStaging :: Lens' ClodConfig FilePath
currentStaging = lens _currentStaging (\c v -> c { _currentStaging = v })

-- | Lens for previousStaging field
previousStaging :: Lens' ClodConfig (Maybe FilePath)
previousStaging = lens _previousStaging (\c v -> c { _previousStaging = v })

-- | Lens for testMode field
testMode :: Lens' ClodConfig Bool
testMode = lens _testMode (\c v -> c { _testMode = v })

-- | Lens for verbose field
verbose :: Lens' ClodConfig Bool
verbose = lens _verbose (\c v -> c { _verbose = v })

-- | Lens for flushMode field
flushMode :: Lens' ClodConfig Bool
flushMode = lens _flushMode (\c v -> c { _flushMode = v })

-- | Lens for lastMode field
lastMode :: Lens' ClodConfig Bool
lastMode = lens _lastMode (\c v -> c { _lastMode = v })

-- | Lens for ignorePatterns field
ignorePatterns :: Lens' ClodConfig [IgnorePattern]
ignorePatterns = lens _ignorePatterns (\c v -> c { _ignorePatterns = v })

-- | Result of processing a file
-- 
-- * 'Success' indicates the file was successfully processed and included
-- * 'Skipped' indicates the file was skipped with a reason (matched ignore pattern, binary file, etc.)
data FileResult 
  = Success              -- ^ File was successfully processed
  | Skipped !String      -- ^ File was skipped with the given reason
  deriving stock (Show, Eq, Generic)

-- | Database error types for more specific error reporting
data DatabaseErrorType 
  = DBFileNotFound      -- ^ Database file could not be found
  | DBCorrupted String  -- ^ Database file is corrupted with details
  | DBVersionMismatch   -- ^ Database version is incompatible
  | DBOtherError String -- ^ Other database error with description
  deriving stock (Show, Eq, Generic)

-- | Errors that can occur during Clod operation
--
-- These represent the different categories of errors that can occur during
-- file processing, allowing for specific error handling for each case.
data ClodError 
  = FileSystemError !FilePath !IOError        -- ^ Error related to filesystem operations
  | ConfigError !String                       -- ^ Error related to configuration (e.g., invalid settings)
  | PatternError !String                      -- ^ Error related to pattern matching (e.g., invalid pattern)
  | CapabilityError !FilePath !String         -- ^ Error related to capability validation with the path
  | DatabaseError !FilePath !DatabaseErrorType -- ^ Error related to checksums database with file and type
  | ChecksumError !FilePath !String           -- ^ Error related to checksum calculation with the file
  deriving stock (Show, Eq, Generic)

-- Generate prisms for ClodError
makePrisms ''ClodError

-- | Validation type for collecting multiple errors
-- This allows us to accumulate errors instead of stopping at the first one
data Validated a = Invalid [ClodError] | Valid a
  deriving stock (Functor, Show, Eq)

instance Applicative Validated where
  pure = Valid
  Invalid errs1 <*> Invalid errs2 = Invalid (errs1 ++ errs2)
  Invalid errs <*> _ = Invalid errs
  _ <*> Invalid errs = Invalid errs
  Valid f <*> Valid a = Valid (f a)

-- | Convert from Validated to Either for compatibility
validatedToEither :: Validated a -> Either ClodError a
validatedToEither (Valid a) = Right a
validatedToEither (Invalid []) = Left (ConfigError "Unknown error")
validatedToEither (Invalid (e:_)) = Left e  -- Return first error for simplicity

-- | Convert from Either to Validated for integration
eitherToValidated :: Either ClodError a -> Validated a
eitherToValidated (Right a) = Valid a
eitherToValidated (Left e) = Invalid [e]

-- | Newtype for file checksums to prevent mixing with other string types
newtype Checksum = Checksum { unChecksum :: String }
  deriving (Show, Eq, Ord) via String
  deriving (IsString, Semigroup, Monoid) via String
  deriving (Generic)

instance FromDhall Checksum
instance ToDhall Checksum
instance FromJSON Checksum
instance ToJSON Checksum

-- | File entry in the checksum database
data FileEntry = FileEntry
  { _entryPath         :: !FilePath       -- ^ Original path
  , _entryChecksum     :: !Checksum       -- ^ File content checksum
  , _entryLastModified :: !UTCTime        -- ^ Last modified time
  , _entryOptimizedName :: !OptimizedName -- ^ Name in staging directory
  } deriving stock (Show, Eq, Generic)
    deriving anyclass (FromDhall, ToDhall, FromJSON, ToJSON)

-- | Lens for entryPath field
entryPath :: Lens' FileEntry FilePath
entryPath = lens _entryPath (\e v -> e { _entryPath = v })

-- | Lens for entryChecksum field
entryChecksum :: Lens' FileEntry Checksum
entryChecksum = lens _entryChecksum (\e v -> e { _entryChecksum = v })

-- | Lens for entryLastModified field
entryLastModified :: Lens' FileEntry UTCTime
entryLastModified = lens _entryLastModified (\e v -> e { _entryLastModified = v })

-- | Lens for entryOptimizedName field
entryOptimizedName :: Lens' FileEntry OptimizedName
entryOptimizedName = lens _entryOptimizedName (\e v -> e { _entryOptimizedName = v }) 

-- | Main database structure
data ClodDatabase = ClodDatabase
  { _dbFiles          :: !(Map FilePath FileEntry)  -- ^ All tracked files by path
  , _dbChecksums      :: !(Map String FilePath)     -- ^ Mapping from checksum to path (for rename detection)
  , _dbLastStagingDir :: !(Maybe FilePath)          -- ^ Previous staging directory
  , _dbLastRunTime    :: !UTCTime                  -- ^ Time of last run
  } deriving stock (Show, Eq, Generic)

-- | Lens for dbFiles field
dbFiles :: Lens' ClodDatabase (Map FilePath FileEntry)
dbFiles = lens _dbFiles (\d v -> d { _dbFiles = v })

-- | Lens for dbChecksums field
dbChecksums :: Lens' ClodDatabase (Map String FilePath)
dbChecksums = lens _dbChecksums (\d v -> d { _dbChecksums = v })

-- | Lens for dbLastStagingDir field
dbLastStagingDir :: Lens' ClodDatabase (Maybe FilePath)
dbLastStagingDir = lens _dbLastStagingDir (\d v -> d { _dbLastStagingDir = v })

-- | Lens for dbLastRunTime field
dbLastRunTime :: Lens' ClodDatabase UTCTime
dbLastRunTime = lens _dbLastRunTime (\d v -> d { _dbLastRunTime = v })

-- | Serialization-friendly version of ClodDatabase
data SerializableClodDatabase = SerializableClodDatabase
  { serializedFiles          :: ![(FilePath, FileEntry)]  -- ^ All tracked files as pairs
  , serializedChecksums      :: ![(String, FilePath)]     -- ^ Checksums as pairs
  , serializedLastStagingDir :: !(Maybe FilePath)          -- ^ Previous staging directory
  , serializedLastRunTime    :: !UTCTime                  -- ^ Time of last run
  } deriving stock (Show, Eq, Generic)
    deriving anyclass (FromDhall, ToDhall, FromJSON, ToJSON)

-- | Convert to serializable form
toSerializable :: ClodDatabase -> SerializableClodDatabase
toSerializable db = SerializableClodDatabase
  { serializedFiles = Map.toList (db ^. dbFiles)
  , serializedChecksums = Map.toList (db ^. dbChecksums)
  , serializedLastStagingDir = db ^. dbLastStagingDir
  , serializedLastRunTime = db ^. dbLastRunTime
  }

-- | Convert from serializable form
fromSerializable :: SerializableClodDatabase -> ClodDatabase
fromSerializable sdb = ClodDatabase
  { _dbFiles = Map.fromList (serializedFiles sdb)
  , _dbChecksums = Map.fromList (serializedChecksums sdb)
  , _dbLastStagingDir = serializedLastStagingDir sdb
  , _dbLastRunTime = serializedLastRunTime sdb
  }

-- | The Clod monad
--
-- This monad stack combines:
--
-- * Reader for dependency injection of ClodConfig
-- * Error handling with ExceptT for 'ClodError'
-- * IO for filesystem, git, and other side effects
--
-- This replaces the previous effects-based approach with a simpler,
-- more traditional monad stack.
type ClodM a = ReaderT ClodConfig (ExceptT ClodError IO) a

-- | Run a ClodM computation, returning either an error or a result
runClodM :: ClodConfig -> ClodM a -> IO (Either ClodError a)
runClodM config action = runExceptT (runReaderT action config)

-- | Capability for reading files within certain directories
data FileReadCap = FileReadCap 
  { _allowedReadDirs :: [FilePath] -- ^ Directories where reading is permitted
  } deriving (Show, Eq)

-- | Lens for allowedReadDirs field
allowedReadDirs :: Lens' FileReadCap [FilePath]
allowedReadDirs = lens _allowedReadDirs (\c v -> c { _allowedReadDirs = v })

-- | Capability for writing files within certain directories
data FileWriteCap = FileWriteCap 
  { _allowedWriteDirs :: [FilePath] -- ^ Directories where writing is permitted
  } deriving (Show, Eq)

-- | Lens for allowedWriteDirs field
allowedWriteDirs :: Lens' FileWriteCap [FilePath]
allowedWriteDirs = lens _allowedWriteDirs (\c v -> c { _allowedWriteDirs = v })

-- | Create a file read capability for specified directories
fileReadCap :: [FilePath] -> FileReadCap
fileReadCap dirs = FileReadCap { _allowedReadDirs = dirs }

-- | Create a file write capability for specified directories
fileWriteCap :: [FilePath] -> FileWriteCap
fileWriteCap dirs = FileWriteCap { _allowedWriteDirs = dirs }

-- | Check if a path is within allowed directories
-- This improved version handles path traversal attacks by comparing canonical paths
isPathAllowed :: [FilePath] -> FilePath -> IO Bool
isPathAllowed allowedDirs path = do
  -- Get canonical paths to resolve any `.`, `..`, or symlinks
  canonicalPath <- canonicalizePath path
  -- Check if the canonical path is within any of the allowed directories
  checks <- mapM (\dir -> do
                   canonicalDir <- canonicalizePath dir
                   -- A path is allowed if:
                   -- 1. It equals an allowed directory exactly, or
                   -- 2. It's a proper subdirectory (dir is a prefix and has a path separator)
                   let isAllowed = canonicalDir == canonicalPath || 
                                  (canonicalDir `isPrefixOf` canonicalPath && 
                                   length canonicalPath > length canonicalDir &&
                                   isPathSeparator (canonicalPath !! length canonicalDir))
                   return isAllowed) allowedDirs
  -- Return result
  return (or checks)
  where
    isPathSeparator c = c == '/' || c == '\\'