tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

Staging.hs (7636B)

      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 -- Same-filesystem staged publication, including cross-directory destinations. No digest, length, HTTP or artifact policy.
      3 module IO.Staging (openStage, openStageWith, StageOps(..), nativeOps) where
      4 
      5 import qualified IO.Resources as R
      6 import qualified Data.ByteString as BS
      7 import Control.Exception
      8 import Control.Monad (unless, when)
      9 import Data.List (isInfixOf)
     10 import Data.IORef
     11 import System.Directory (canonicalizePath, removeFile, renameFile)
     12 import System.FilePath (takeDirectory, takeFileName, (</>))
     13 import System.IO
     14 import System.IO.Error
     15 import System.Posix.Files (createLink)
     16 import System.Posix.IO (openFd, closeFd, handleToFd, defaultFileFlags, OpenMode(ReadOnly))
     17 import System.Posix.Types (Fd)
     18 import System.Posix.Unistd (fileSynchronise)
     19 
     20 -- Injectable OS dependencies, not production fault flags. The native backend
     21 -- has exactly the same transitions as deterministic failure/cancellation tests.
     22 data StageOps = StageOps
     23   { putBytes :: Handle -> BS.ByteString -> IO ()
     24   , syncFile :: Fd -> IO ()
     25   , closeDescriptor :: Fd -> IO ()
     26   , replaceName :: FilePath -> FilePath -> IO ()
     27   , linkName :: FilePath -> FilePath -> IO ()
     28   , removeName :: FilePath -> IO ()
     29   , openDirectory :: FilePath -> IO Fd
     30   , syncDirectory :: Fd -> IO ()
     31   }
     32 nativeOps :: StageOps
     33 nativeOps = StageOps BS.hPut fileSynchronise closeFd renameFile createLink removeFile
     34   (\path -> openFd path ReadOnly defaultFileFlags) fileSynchronise
     35 
     36 temporaryMarker :: String
     37 temporaryMarker = ".tricu-stage-"
     38 
     39 data Phase = Writing | Sealed | Failed | Published deriving Eq
     40 data Owned = OwnHandle Handle | OwnDescriptor Fd | Released
     41 newtype CleanupFault = CleanupFault String deriving Show
     42 instance Exception CleanupFault
     43 
     44 openStage :: R.Runtime -> R.Scope -> FilePath -> IO (Either R.Problem R.Token)
     45 openStage = openStageWith nativeOps
     46 openStageWith :: StageOps -> R.Runtime -> R.Scope -> FilePath -> IO (Either R.Problem R.Token)
     47 openStageWith _ _ _ "" = pure (Left (R.Problem "invalid-argument" "stage-open" "empty directory" "none"))
     48 openStageWith ops runtime scope directory = R.acquire runtime scope $ mask_ $ do
     49   canonical <- canonicalizePath directory
     50   (path, handle) <- openBinaryTempFile canonical temporaryMarker
     51   -- No user evaluation between allocation and installing cleanup bookkeeping.
     52   phase <- newIORef Writing
     53   owned <- newIORef (OwnHandle handle)
     54   privateName <- newIORef True
     55   let removePrivate = do
     56         exists <- readIORef privateName
     57         when exists $ do
     58           removeName ops path `catch` (\e -> unless (isDoesNotExistError e) (throwIO (e :: IOException)))
     59           writeIORef privateName False
     60       closeOwned = do
     61         current <- readIORef owned
     62         case current of
     63           Released -> pure ()
     64           OwnHandle h -> hClose h >> writeIORef owned Released
     65           OwnDescriptor fd -> do
     66             -- A failed close can already have closed the descriptor. Never
     67             -- retry a numeric descriptor that the OS may have reused.
     68             writeIORef owned Released
     69             closeDescriptor ops fd
     70       cleanup = mask_ $ do
     71         closed <- try closeOwned
     72         removed <- try removePrivate
     73         let failures = [e | Left e <- [closed, removed]] :: [SomeException]
     74             asynchronous e = case fromException e :: Maybe SomeAsyncException of
     75               Just _ -> True
     76               Nothing -> False
     77         -- Preserve interruption so the registry retains the closing entry for
     78         -- later settlement, but still attempt private-name removal here.
     79         case filter asynchronous failures of
     80           first:_ -> throwIO first
     81           [] -> case (closed, removed) of
     82             (Left first, Left second) -> case fromException first of
     83               Just ioe -> throwIO (ioeSetErrorString ioe
     84                 (take 240 (ioeGetErrorString ioe) ++ "; removal: " ++ take 240 (displayException second)))
     85               Nothing -> throwIO (CleanupFault
     86                 (take 240 (displayException first) ++ "; removal: " ++ take 240 (displayException second)))
     87             (Left first, _) -> throwIO first
     88             (_, Left second) -> throwIO second
     89             _ -> pure ()
     90       require expected operation = do
     91         actual <- readIORef phase
     92         unless (actual == expected) (R.resourceFault (R.Problem "invalid-state" operation "stage is not in the required phase" "none"))
     93       poison = writeIORef phase Failed
     94       write bytes = do
     95         require Writing "write"
     96         (putBytes ops handle bytes >> pure (BS.length bytes)) `onException` poison
     97       seal = mask_ $ do
     98         require Writing "seal"
     99         (do
    100           hFlush handle
    101           fd <- handleToFd handle
    102           writeIORef owned (OwnDescriptor fd)
    103           -- On sync failure/cancellation the scope still owns this descriptor.
    104           -- Its later release cannot mask the primary operation failure.
    105           syncFile ops fd
    106           closeOwned
    107           writeIORef phase Sealed) `onException` poison
    108       publish replace destination = mask_ $ do
    109         require Sealed "publish"
    110         progress <- newIORef "not-published"
    111         let action = do
    112               targetDirectory <- canonicalizePath (takeDirectory destination)
    113               let name = takeFileName destination
    114               unless (name `notElem` ["", ".", ".."] && not (temporaryMarker `isInfixOf` name)) $
    115                 R.resourceFault (R.Problem "invalid-destination" "publish" "destination must name a file outside the private staging namespace" "not-published")
    116               let target = targetDirectory </> name
    117               -- Syscall failure can be ambiguous on remote filesystems. Never
    118               -- turn it into permission to retry or delete the destination.
    119               writeIORef progress "unknown"
    120               linked <- if replace then replaceName ops path target >> pure True
    121                 else (linkName ops path target >> pure True) `catch`
    122                   (\e -> if isAlreadyExistsError e then pure False else throwIO (e :: IOException))
    123               if not linked then pure "exists" else do
    124                 writeIORef progress "published"
    125                 writeIORef phase Published
    126                 if replace then writeIORef privateName False else removePrivate
    127                 -- These are atomic namespace syscalls, never copy fallbacks.
    128                 -- Synchronize destination visibility before source-name removal durability;
    129                 -- distinct directories both need synchronization. Failure remains
    130                 -- published and cleanup cannot remove the destination. Do not open
    131                 -- a second descriptor until the first has been settled.
    132                 let syncParent directoryPath = do
    133                       fd <- openDirectory ops directoryPath
    134                       writeIORef owned (OwnDescriptor fd)
    135                       syncDirectory ops fd
    136                       closeOwned
    137                 syncParent targetDirectory
    138                 when (targetDirectory /= canonical) (syncParent canonical)
    139                 pure "published"
    140         action `catch` (\(e :: IOException) -> do
    141           poison
    142           visibility <- readIORef progress
    143           R.resourceFault ((R.ioProblem "publish" e) { R.progress = visibility }))
    144           `onException` (do
    145             state <- readIORef phase
    146             -- In particular, cancellation after link/rename never rolls back
    147             -- visibility. Cleanup only ever touches our private temporary name.
    148             unless (state == Published) poison)
    149   (hSetBuffering handle NoBuffering >> pure (R.Staged write seal publish cleanup)) `onException` cleanup