From 5576936884d394f0466905bcfb669615a4d662c9 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 21 Jul 2024 18:42:38 +0800 Subject: [PATCH] Support openTempFile and friends, fixes #2 --- System/File/OsPath/Internal.hs | 43 ++++++++++++++++++++++++- posix/System/File/Platform.hs | 59 ++++++++++++++++++++++++++++++++-- 2 files changed, 98 insertions(+), 4 deletions(-) diff --git a/System/File/OsPath/Internal.hs b/System/File/OsPath/Internal.hs index f7e9cce..3b8da94 100644 --- a/System/File/OsPath/Internal.hs +++ b/System/File/OsPath/Internal.hs @@ -1,12 +1,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} module System.File.OsPath.Internal where import qualified System.File.Platform as P -import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=)) +import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=), (==), otherwise, errorWithoutStackTrace) import GHC.IO (catchException) import GHC.IO.Exception (IOException(..)) import GHC.IO.Handle (hClose_help) @@ -18,11 +20,15 @@ import Control.DeepSeq (force) import Control.Exception (SomeException, try, evaluate, mask, onException) import System.IO (IOMode(..), hSetBinaryMode, hClose) import System.IO.Unsafe (unsafePerformIO) +import System.OsString (osstr) import System.OsPath as OSP import System.OsString.Internal.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import qualified System.OsString as OSS +import System.Posix (CMode) +import GHC.Base (failIO) -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -127,6 +133,11 @@ openFileWithCloseOnExec osfp iomode = augmentError "openFileWithCloseOnExec" osf openExistingFileWithCloseOnExec :: OsPath -> IOMode -> IO Handle openExistingFileWithCloseOnExec osfp iomode = augmentError "openExistingFileWithCloseOnExec" osfp $ withOpenFile' osfp iomode False True True pure False + +openTempFile :: OsPath -> OsString -> IO (OsPath, Handle) +openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False 0o600 + + -- --------------------------------------------------------------------------- -- Internals @@ -173,3 +184,33 @@ addFilePathToIOError fun fp ioe = unsafePerformIO $ do augmentError :: String -> OsPath -> IO a -> IO a augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) + +openTempFile' :: String -> OsPath -> OsString -> Bool -> CMode + -> IO (OsPath, Handle) +openTempFile' loc (OsString tmp_dir) template@(OsString tmpl) binary mode + | OSS.any (== OSP.pathSeparator) template + = failIO $ "openTempFile': Template string must not contain path separator characters: " ++ P.lenientDecode tmpl + | otherwise = do + (fp, hdl) <- P.findTempName (prefix, suffix) loc tmp_dir mode + when binary $ hSetBinaryMode hdl True + pure (OsString fp, hdl) + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (OsString prefix, OsString suffix) = + case OSS.break (== OSS.unsafeFromChar '.') $ OSS.reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, [osstr||]) -> (OSS.reverse rev_suffix, OSS.empty) + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, xs) + | (h:rest) <- OSS.unpack xs + , h == unsafeFromChar '.' -> (OSS.reverse (OSS.pack rest), OSS.cons (unsafeFromChar '.') $ OSS.reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> errorWithoutStackTrace "bug in System.IO.openTempFile" + diff --git a/posix/System/File/Platform.hs b/posix/System/File/Platform.hs index 760f22b..3f51bd8 100644 --- a/posix/System/File/Platform.hs +++ b/posix/System/File/Platform.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module System.File.Platform where +import Data.Either (fromRight) import Control.Exception (try, onException, SomeException) import GHC.IO.Handle.FD (fdToHandle') import System.IO (IOMode(..), Handle) @@ -10,10 +12,17 @@ import System.Posix.IO.PosixString ( defaultFileFlags, openFd, closeFd, - OpenFileFlags(noctty, nonBlock, creat, append, trunc, cloexec), + OpenFileFlags(noctty, nonBlock, creat, append, trunc, cloexec, exclusive), OpenMode(ReadWrite, ReadOnly, WriteOnly) ) -import System.OsPath.Posix ( PosixPath ) +import System.OsPath.Posix ( PosixPath, PosixString, () ) import qualified System.OsPath.Posix as PS +import Data.IORef (IORef, newIORef) +import System.Posix (CMode) +import System.IO (utf8, latin1) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Internals (c_getpid) +import GHC.IORef (atomicModifyIORef'_) +import Foreign.C (getErrno, eEXIST, errnoToIOError) -- | Open a file and return the 'Handle'. openFile :: PosixPath -> IOMode -> IO Handle @@ -43,7 +52,7 @@ openExistingFile_ df fp iomode = fdToHandle_ iomode fp =<< case iomode of fdToHandle_ :: IOMode -> PosixPath -> Fd -> IO Handle fdToHandle_ iomode fp (Fd fd) = (`onException` closeFd (Fd fd)) $ do - fp' <- either (const (fmap PS.toChar . PS.unpack $ fp)) id <$> try @SomeException (PS.decodeFS fp) + fp' <- fromRight (fmap PS.toChar . PS.unpack $ fp) <$> try @SomeException (PS.decodeFS fp) fdToHandle' fd Nothing False fp' iomode True openFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle @@ -58,3 +67,47 @@ defaultFileFlags' = defaultFileFlags { noctty = True, nonBlock = True } defaultExistingFileFlags :: OpenFileFlags defaultExistingFileFlags = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing } +findTempName :: (PosixString, PosixString) + -> String + -> PosixPath + -> CMode + -> IO (PosixPath, Handle) +findTempName (prefix, suffix) loc tmp_dir mode = go + where + go = do + rs <- rand_string + let filename = prefix <> rs <> suffix + filepath = tmp_dir filename + fd <- openTempFile_ filepath mode + if fd < 0 + then do + errno <- getErrno + case errno of + _ | errno == eEXIST -> go + _ -> do + let tmp_dir' = lenientDecode tmp_dir + ioError (errnoToIOError loc errno Nothing (Just tmp_dir')) + else fmap (filepath,) $ fdToHandle_ ReadWriteMode filepath fd + + openTempFile_ :: PosixPath -> CMode -> IO Fd + openTempFile_ fp cmode = openFd fp ReadWrite defaultFileFlags' { creat = Just cmode, nonBlock = True, noctty = True, exclusive = True } + +tempCounter :: IORef Int +tempCounter = unsafePerformIO $ newIORef 0 +{-# NOINLINE tempCounter #-} + +-- build large digit-alike number +rand_string :: IO PosixString +rand_string = do + r1 <- c_getpid + (r2, _) <- atomicModifyIORef'_ tempCounter (+1) + return $ PS.pack $ fmap (PS.unsafeFromChar) (show r1 ++ "-" ++ show r2) + +lenientDecode :: PosixString -> String +lenientDecode ps = let utf8' = PS.decodeWith utf8 ps + latin1' = PS.decodeWith latin1 ps + in case (utf8', latin1') of + (Left _, Left _) -> error "lenientDecode: failed to decode" + (Right s, _) -> s + (_, Right s) -> s +