never executed always true always false

    1 module PureClaw.Security.Path
    2   ( -- * Safe path type (constructor intentionally NOT exported)
    3     SafePath
    4     -- * Path errors
    5   , PathError (..)
    6     -- * Construction (the ONLY way to obtain a SafePath)
    7   , mkSafePath
    8     -- * Read-only accessor
    9   , getSafePath
   10   ) where
   11 
   12 import Data.List
   13 import Data.Set (Set)
   14 import Data.Set qualified as Set
   15 import Data.Text (Text)
   16 import System.Directory
   17 import System.FilePath
   18 
   19 import PureClaw.Core.Types
   20 
   21 -- | A filesystem path that has been validated to be within the workspace
   22 -- and not on the blocked list. Constructor is intentionally NOT exported —
   23 -- the only way to obtain a 'SafePath' is through 'mkSafePath'.
   24 newtype SafePath = SafePath { getSafePath :: FilePath }
   25   deriving stock (Eq, Ord)
   26 
   27 instance Show SafePath where
   28   show sp = "SafePath " ++ show (getSafePath sp)
   29 
   30 -- | Errors that can occur during path validation.
   31 data PathError
   32   = PathEscapesWorkspace FilePath FilePath  -- ^ requested, resolved
   33   | PathIsBlocked FilePath Text             -- ^ requested, reason
   34   | PathDoesNotExist FilePath               -- ^ the requested path does not exist
   35   deriving stock (Show, Eq)
   36 
   37 -- | Paths that must never be readable or writable, regardless of workspace.
   38 -- Checked against the first component of the relative path within the workspace.
   39 blockedPaths :: Set String
   40 blockedPaths = Set.fromList
   41   [ ".env"
   42   , ".env.local"
   43   , ".env.production"
   44   , ".ssh"
   45   , ".gnupg"
   46   , ".netrc"
   47   , ".pureclaw"  -- protects vault and config from agent file tools
   48   ]
   49 
   50 -- | The ONLY way to obtain a 'SafePath'. Canonicalizes the path (following
   51 -- symlinks), verifies it stays within the workspace, checks the blocked list,
   52 -- and verifies the path exists.
   53 --
   54 -- Checks run in order, each as an early return:
   55 --  1. Reject @..@ traversal (prevents workspace escape)
   56 --  2. Reject absolute paths outside workspace
   57 --  3. Reject blocked paths (@.env@, @.ssh@, etc.)
   58 --  4. Reject non-existent paths
   59 --  5. Reject symlinks that resolve outside workspace
   60 mkSafePath :: WorkspaceRoot -> FilePath -> IO (Either PathError SafePath)
   61 mkSafePath (WorkspaceRoot root) requested = do
   62   canonRoot <- canonicalizePath root
   63   let raw = if isAbsolute requested then requested else canonRoot </> requested
   64       relative = makeRelative canonRoot raw
   65   -- Pure checks first (no IO, no filesystem access)
   66   let pureCheck
   67         | hasParentTraversal requested = Just (PathEscapesWorkspace requested raw)
   68         | isAbsolute requested && not (canonRoot `isPrefixOf` raw) = Just (PathEscapesWorkspace requested raw)
   69         | isBlockedPath relative = Just (PathIsBlocked requested "blocked path")
   70         | otherwise = Nothing
   71   case pureCheck of
   72     Just err -> pure (Left err)
   73     Nothing -> do
   74       exists <- doesPathExist raw
   75       if not exists
   76         then pure $ Left (PathDoesNotExist requested)
   77         else do
   78           -- Canonicalize resolves symlinks — a symlink inside the workspace
   79           -- could point outside it, so we re-check containment.
   80           canonical <- canonicalizePath raw
   81           pure $ if canonRoot `isPrefixOf` canonical
   82             then Right (SafePath canonical)
   83             else Left (PathEscapesWorkspace requested canonical)
   84 
   85 -- | Check if a path contains ".." components that could traverse upward.
   86 hasParentTraversal :: FilePath -> Bool
   87 hasParentTraversal path = ".." `elem` splitDirectories path
   88 
   89 -- | Check if a relative path matches any blocked path.
   90 -- Matches on the first path component (e.g. ".env" matches ".env" and ".env/foo").
   91 isBlockedPath :: FilePath -> Bool
   92 isBlockedPath relative =
   93   let firstComponent = Prelude.takeWhile (\c -> c /= '/' && c /= '\\') relative
   94   in Set.member firstComponent blockedPaths
   95