Support openTempFile and friends, fixes #2

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"
+

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
+