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   ]
   48 
   49 -- | The ONLY way to obtain a 'SafePath'. Canonicalizes the path (following
   50 -- symlinks), verifies it stays within the workspace, checks the blocked list,
   51 -- and verifies the path exists.
   52 --
   53 -- Checks run in order, each as an early return:
   54 --  1. Reject @..@ traversal (prevents workspace escape)
   55 --  2. Reject absolute paths outside workspace
   56 --  3. Reject blocked paths (@.env@, @.ssh@, etc.)
   57 --  4. Reject non-existent paths
   58 --  5. Reject symlinks that resolve outside workspace
   59 mkSafePath :: WorkspaceRoot -> FilePath -> IO (Either PathError SafePath)
   60 mkSafePath (WorkspaceRoot root) requested = do
   61   canonRoot <- canonicalizePath root
   62   let raw = if isAbsolute requested then requested else canonRoot </> requested
   63       relative = makeRelative canonRoot raw
   64   -- Pure checks first (no IO, no filesystem access)
   65   let pureCheck
   66         | hasParentTraversal requested = Just (PathEscapesWorkspace requested raw)
   67         | isAbsolute requested && not (canonRoot `isPrefixOf` raw) = Just (PathEscapesWorkspace requested raw)
   68         | isBlockedPath relative = Just (PathIsBlocked requested "blocked path")
   69         | otherwise = Nothing
   70   case pureCheck of
   71     Just err -> pure (Left err)
   72     Nothing -> do
   73       exists <- doesPathExist raw
   74       if not exists
   75         then pure $ Left (PathDoesNotExist requested)
   76         else do
   77           -- Canonicalize resolves symlinks — a symlink inside the workspace
   78           -- could point outside it, so we re-check containment.
   79           canonical <- canonicalizePath raw
   80           pure $ if canonRoot `isPrefixOf` canonical
   81             then Right (SafePath canonical)
   82             else Left (PathEscapesWorkspace requested canonical)
   83 
   84 -- | Check if a path contains ".." components that could traverse upward.
   85 hasParentTraversal :: FilePath -> Bool
   86 hasParentTraversal path = ".." `elem` splitDirectories path
   87 
   88 -- | Check if a relative path matches any blocked path.
   89 -- Matches on the first path component (e.g. ".env" matches ".env" and ".env/foo").
   90 isBlockedPath :: FilePath -> Bool
   91 isBlockedPath relative =
   92   let firstComponent = Prelude.takeWhile (\c -> c /= '/' && c /= '\\') relative
   93   in Set.member firstComponent blockedPaths
   94