tricu

Filesystem.hs (5713B)

---

 {-# LANGUAGE ScopedTypeVariables #-}
 -- Path operations are observations/mutations, not authorization or transactions.
 -- Directory cursors never materialize a listing or retain previously returned names.
 module IO.Filesystem
   ( Status(..), statPath, createDirectory, removeDirectory, removeFile, renamePath
   , syncDirectory
   , openDirectory, directoryBackend, nameLimit
   ) where
 import qualified IO.Descriptor as Descriptor
 import System.Posix.IO (openFd, OpenMode(ReadOnly), defaultFileFlags, nonBlock)
 import System.Posix.Unistd (fileSynchronise)
 import qualified IO.Resources as R
 import qualified System.Posix.Files as F
 import qualified System.Posix.Directory as D
 import Control.Exception
 import Control.Monad (when, unless)
 import Data.IORef
 import Data.Char (ord)
 
 data Status = Regular Integer | Directory | Symlink | Other deriving (Eq, Show)
 nameLimit :: Int
 nameLimit = 4096
 
 pathOperation :: String -> Bool -> [FilePath] -> IO a -> IO (Either R.Problem a)
 pathOperation op mutating paths action
   | any (\p -> null p || '\0' `elem` p) paths =
       pure (Left (R.Problem "invalid-argument" op "empty or NUL-containing path" "none"))
   | otherwise = (Right <$> action) `catch` \(e :: IOException) -> do
       let problem = R.ioProblem op e
       pure (Left (problem {R.progress=if mutating then "unknown" else "none"}))
 
 -- Following the final symlink is an explicit choice; intermediate components
 -- always follow the host path resolver. Neither form pins later path operations.
 statPath :: Bool -> FilePath -> IO (Either R.Problem Status)
 statPath follow path = pathOperation op False [path] $ do
   status <- (if follow then F.getFileStatus else F.getSymbolicLinkStatus) path
   if F.isRegularFile status then do
     let size = toInteger (F.fileSize status)
     if size >= 0 && size <= R.positionLimit then pure (Regular size)
       else ioError (userError "file size outside supported range")
   else pure (if F.isDirectory status then Directory
              else if F.isSymbolicLink status then Symlink else Other)
   where op = if follow then "stat" else "lstat"
 
 createDirectory, removeDirectory, removeFile :: FilePath -> IO (Either R.Problem ())
 createDirectory path = pathOperation "create" True [path] (D.createDirectory path 0o777)
 removeDirectory path = pathOperation "remove" True [path] (D.removeDirectory path)
 removeFile path = pathOperation "remove-file" True [path] (F.removeLink path)
 renamePath :: FilePath -> FilePath -> IO (Either R.Problem ())
 renamePath old new = pathOperation "rename" True [old,new] (F.rename old new)
 
 -- Synchronize an opened directory, not an unchecked path after verification.
 -- Nonblocking open avoids hanging on a FIFO supplied where a directory belongs.
 syncDirectory :: R.Runtime -> R.Scope -> FilePath -> IO (Either R.Problem ())
 syncDirectory runtime scope path
   | null path || '\0' `elem` path = pure (Left (R.Problem "invalid-argument" "sync" "empty or NUL-containing path" "none"))
   | otherwise = R.withTemporary runtime scope "sync" (do
       fd <- openFd path ReadOnly (defaultFileFlags {nonBlock=True})
       release <- Descriptor.closeOnce fd
       pure (fd,release)) $ \fd -> do
         status <- F.getFdStatus fd
         unless (F.isDirectory status) (R.resourceFault (R.Problem "not-directory" "sync" "path is not a directory" "none"))
         fileSynchronise fd
 
 openDirectory :: R.Runtime -> R.Scope -> FilePath -> IO (Either R.Problem R.Token)
 openDirectory runtime scope path
   | null path || '\0' `elem` path = pure (Left (R.Problem "invalid-argument" "open" "empty or NUL-containing path" "none"))
   | otherwise = R.acquire runtime scope $
       bracketOnError (D.openDirStream path) D.closeDirStream $ \stream ->
         directoryBackend (D.readDirStream stream) (D.closeDirStream stream)
 
 data Cursor = Active | Ended | Poisoned
 -- Injectable backend callbacks exercise failure/cancellation at the actual cursor
 -- boundary. The registry supplies the lease; these callbacks are not standalone
 -- concurrent iterators. An uncertain advance cannot be implicitly retried.
 directoryBackend :: IO FilePath -> IO () -> IO R.Backend
 directoryBackend readName close = do
   state <- newIORef Active
   owned <- newIORef True
   let fault category detail = R.resourceFault (R.Problem category "next" detail "unknown")
       validName = walk nameLimit
         where
           walk _ [] = pure ()
           walk 0 _ = fault "invalid-name" "directory name exceeds scalar limit"
           walk n (c:rest)
             | c == '/' || c == '\0' = fault "invalid-name" "invalid directory component"
             | ord c > 0x10ffff || (ord c >= 0xd800 && ord c <= 0xdfff) = fault "invalid-encoding" "directory name is not Unicode scalar text"
             | otherwise = walk (n-1) rest
       advance budget = do
         name <- readName
         case name of
           "" -> writeIORef state Ended >> pure Nothing
           "." -> skip budget
           ".." -> skip budget
           _ -> validName name >> pure (Just name)
       skip 0 = fault "invalid-state" "directory dot-entry scan exceeded bound"
       skip n = advance (n-1)
       next = mask $ \restore -> do
         phase <- readIORef state
         case phase of
           Ended -> pure Nothing
           Poisoned -> fault "invalid-state" "directory cursor failed; reopen explicitly"
           Active -> restore (advance (2 :: Int)) `onException` writeIORef state Poisoned
       release = mask_ $ do
         -- closedir owns a raw pointer: never retry an uncertain close against a
         -- potentially freed DIR*. Registry teardown can revisit async failures.
         wasOwned <- atomicModifyIORef' owned (\old -> (False,old))
         when wasOwned close
   pure (R.Directory next release)