Support openTempFile and friends, fixes #2

.cirrus.yml

@@ -1,7 +1,7 @@
 task:
   name: FreeBSD
   freebsd_instance:
-    image_family: freebsd-13-2
+    image_family: freebsd-14-0
   install_script: pkg install -y ghc hs-cabal-install git autoconf
   script:
     - cabal update
@@ -26,7 +26,7 @@ task:
   name: NetBSD
   compute_engine_instance:
     image_project: pg-ci-images
-    image: family/pg-ci-netbsd-vanilla-9-3
+    image: family/pg-ci-netbsd-vanilla-10-0
     platform: netbsd
   install_script:
     - export PKG_PATH="http://cdn.NetBSD.org/pub/pkgsrc/packages/NetBSD/$(uname -p)/$(uname -r|cut -f '1 2' -d.)/All/"

.github/workflows/test.yaml

@@ -16,7 +16,7 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc: ['8.6', '8.8', '8.10', '9.0', '9.2', '9.4', '9.6', '9.8']
+        ghc: ['8.8', '8.10', '9.0', '9.2', '9.4', '9.6', '9.8']
         include:
           - os: macOS-latest
             ghc: '9.4'
@@ -49,11 +49,13 @@ jobs:
       run: |
         set -eux
         [ -e ~/.ghcup/env ] && . ~/.ghcup/env
+        ghcup install ghc --set ${{ matrix.ghc }}
         echo ${{ matrix.ghc }}
         echo $(ghc --numeric-version)
         cabal update
-        cabal build --enable-tests
-        cabal test --test-show-details=direct
+        cabal configure --enable-tests --test-show-details=direct
+        cabal build
+        cabal test
         cabal haddock
         cabal check
         cabal sdist

CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history for file-io
 
+## 0.1.3 -- 2024-??-??
+
+* add `openTempFile` , `openBinaryTempFile` , `openTempFileWithDefaultPermissions` and `openBinaryTempFileWithDefaultPermissions` wrt [#2](https://github.com/hasufell/file-io/issues/2)
+
 ## 0.1.2 -- 2024-05-27
 
 * expose internals via `.Internal` modules

System/File/OsPath.hs

@@ -23,6 +23,10 @@ module System.File.OsPath (
 , appendFile'
 , openFile
 , openExistingFile
+, openTempFile
+, openBinaryTempFile
+, openTempFileWithDefaultPermissions
+, openBinaryTempFileWithDefaultPermissions
 ) where
 
 

System/File/OsPath/Internal.hs

@@ -1,12 +1,15 @@
+{-# LANGUAGE CPP #-}
 {-# 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, userError)
 import GHC.IO (catchException)
 import GHC.IO.Exception (IOException(..))
 import GHC.IO.Handle (hClose_help)
@@ -15,14 +18,20 @@ import GHC.IO.Handle.Types (Handle__, Handle(..))
 import Control.Concurrent.MVar
 import Control.Monad (void, when)
 import Control.DeepSeq (force)
-import Control.Exception (SomeException, try, evaluate, mask, onException)
+import Control.Exception (SomeException, try, evaluate, mask, onException, throwIO)
 import System.IO (IOMode(..), hSetBinaryMode, hClose)
 import System.IO.Unsafe (unsafePerformIO)
 import System.OsPath as OSP
 import System.OsString.Internal.Types
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
+import System.Posix.Types (CMode)
+#if MIN_VERSION_filepath(1, 5, 0)
+import qualified System.OsString as OSS
+#else
+import Data.Coerce
+#endif
 
 -- | Like 'openFile', but open the file in binary mode.
 -- On Windows, reading a file in text mode (which is the default)
@@ -127,6 +136,56 @@ 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
 
+
+-- | The function creates a temporary file in ReadWrite mode.
+-- The created file isn\'t deleted automatically, so you need to delete it manually.
+--
+-- The file is created with permissions such that only the current
+-- user can read\/write it.
+--
+-- With some exceptions (see below), the file will be created securely
+-- in the sense that an attacker should not be able to cause
+-- openTempFile to overwrite another file on the filesystem using your
+-- credentials, by putting symbolic links (on Unix) in the place where
+-- the temporary file is to be created.  On Unix the @O_CREAT@ and
+-- @O_EXCL@ flags are used to prevent this attack, but note that
+-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
+-- rely on this behaviour it is best to use local filesystems only.
+--
+-- @since 0.1.3
+openTempFile :: OsPath     -- ^ Directory in which to create the file
+             -> OsString   -- ^ File name template. If the template is \"foo.ext\" then
+                           -- the created file will be \"fooXXX.ext\" where XXX is some
+                           -- random number. Note that this should not contain any path
+                           -- separator characters. On Windows, the template prefix may
+                           -- be truncated to 3 chars, e.g. \"foobar.ext\" will be
+                           -- \"fooXXX.ext\".
+             -> IO (OsPath, Handle)
+openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False 0o600
+
+-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
+--
+-- @since 0.1.3
+openBinaryTempFile :: OsPath -> OsString -> IO (OsPath, Handle)
+openBinaryTempFile tmp_dir template
+    = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
+
+-- | Like 'openTempFile', but uses the default file permissions
+--
+-- @since 0.1.3
+openTempFileWithDefaultPermissions :: OsPath -> OsString
+                                   -> IO (OsPath, Handle)
+openTempFileWithDefaultPermissions tmp_dir template
+    = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666
+
+-- | Like 'openBinaryTempFile', but uses the default file permissions
+--
+-- @since 0.1.3
+openBinaryTempFileWithDefaultPermissions :: OsPath -> OsString
+                                         -> IO (OsPath, Handle)
+openBinaryTempFileWithDefaultPermissions tmp_dir template
+    = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666
+
 -- ---------------------------------------------------------------------------
 -- Internals
 
@@ -173,3 +232,29 @@ 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
+    | any_ (== OSP.pathSeparator) template
+    = throwIO $ userError $ "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) = OSP.splitExtension template
+
+#if MIN_VERSION_filepath(1, 5, 0)
+any_ :: (OsChar -> Bool) -> OsString -> Bool
+any_ = OSS.any
+
+#else
+any_ :: (OsChar -> Bool) -> OsString -> Bool
+any_ = coerce P.any_
+
+#endif
+

file-io.cabal

@@ -1,6 +1,6 @@
 cabal-version:      2.4
 name:               file-io
-version:            0.1.2
+version:            0.1.3
 synopsis:           Basic file IO operations via 'OsPath'
 description:        Basic file IO operations like Prelude, but for 'OsPath'.
 homepage:           https://github.com/hasufell/file-io
@@ -17,8 +17,7 @@ tested-with:    GHC==9.8.1,
                 GHC==9.2.8,
                 GHC==9.0.2,
                 GHC==8.10.7,
-                GHC==8.8.4,
-                GHC==8.6.5
+                GHC==8.8.4
 
 source-repository head
   type:     git
@@ -42,7 +41,7 @@ library
 
   hs-source-dirs: .
   build-depends:
-    , base        >=4.12      && <5
+    , base        >=4.13.0.0 && <5
     , bytestring  >=0.11.3.0
     , deepseq
 
@@ -66,7 +65,7 @@ test-suite T15
     main-is: T15.hs
     type: exitcode-stdio-1.0
     default-language: Haskell2010
-    build-depends: base, tasty, tasty-hunit, file-io, filepath, temporary
+    build-depends: base >=4.13.0.0 && <5, tasty, tasty-hunit, file-io, filepath, temporary
     ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10"
     if os(windows)
       build-depends: Win32 >=2.13.3.0
@@ -77,40 +76,40 @@ test-suite T15Win
     type: exitcode-stdio-1.0
     default-language: Haskell2010
     if os(windows)
-      build-depends: base, tasty, tasty-hunit, file-io, filepath, temporary, Win32 >=2.13.3.0
+      build-depends: base >=4.13.0.0 && <5, tasty, tasty-hunit, file-io, filepath, temporary, Win32 >=2.13.3.0
     else
-      build-depends: base
+      build-depends: base >=4.13.0.0 && <5
     ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10"
 
 test-suite T14
     hs-source-dirs: tests
     main-is: T14.hs
     type: exitcode-stdio-1.0
     default-language: Haskell2010
-    build-depends: base, file-io, filepath, temporary
+    build-depends: base >=4.13.0.0 && <5, file-io, filepath, temporary
     ghc-options: -Wall
 
 test-suite T8
     hs-source-dirs: tests
     main-is: T8.hs
     type: exitcode-stdio-1.0
     default-language: Haskell2010
-    build-depends: base, bytestring, file-io, filepath, temporary
+    build-depends: base >=4.13.0.0 && <5, bytestring, file-io, filepath, temporary
     ghc-options: -Wall -threaded
 
 test-suite CLC237
     hs-source-dirs: tests
     main-is: CLC237.hs
     type: exitcode-stdio-1.0
     default-language: Haskell2010
-    build-depends: base, file-io, filepath, temporary
+    build-depends: base >=4.13.0.0 && <5, file-io, filepath, temporary
     ghc-options: -Wall
 
 test-suite Properties
     hs-source-dirs: tests
     main-is: Properties.hs
     type: exitcode-stdio-1.0
     default-language: Haskell2010
-    build-depends: base, bytestring, tasty, tasty-hunit, file-io, filepath, temporary
+    build-depends: base >=4.13.0.0 && <5, bytestring, tasty, tasty-hunit, file-io, filepath, temporary
     ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10"
 

posix/System/File/Platform.hs

@@ -1,7 +1,11 @@
+{-# LANGUAGE CPP              #-}
+{-# LANGUAGE TupleSections    #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PackageImports   #-}
 
 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 +14,28 @@ 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)
+
+#if MIN_VERSION_filepath(1, 5, 0)
+import "os-string" System.OsString.Internal.Types (PosixString(..), PosixChar(..))
+import qualified "os-string" System.OsString.Data.ByteString.Short as BC
+#else
+import Data.Coerce (coerce)
+import "filepath" System.OsString.Internal.Types (PosixString(..), PosixChar(..))
+import qualified "filepath" System.OsPath.Data.ByteString.Short as BC
+#endif
+import System.CPUTime (cpuTimePrecision, getCPUTime)
+import Text.Printf (printf)
 
 -- | Open a file and return the 'Handle'.
 openFile :: PosixPath -> IOMode -> IO Handle
@@ -43,7 +65,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 +80,55 @@ 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 <- fromIntegral @_ @Int <$> c_getpid
+  (r2, _) <- atomicModifyIORef'_ tempCounter (+1)
+  r3 <- (`quot` cpuTimePrecision) <$> getCPUTime
+  return $ PS.pack $ fmap (PS.unsafeFromChar) (printf "%x-%x-%x" r1 r2 r3)
+
+lenientDecode :: PosixString -> String
+lenientDecode ps = let utf8' = PS.decodeWith utf8 ps
+                       latin1' = PS.decodeWith latin1 ps
+                   in case (utf8', latin1') of
+                        (Right s, ~_) -> s
+                        (_, Right s) -> s
+                        (Left _, Left _) -> error "lenientDecode: failed to decode"
+
+#if !MIN_VERSION_filepath(1, 5, 0)
+
+any_ :: (PosixChar -> Bool) -> PosixString -> Bool
+any_ = coerce BC.any
+
+#endif
+