diff --git a/.cirrus.yml b/.cirrus.yml index 5bf9e01..67238da 100644 --- a/.cirrus.yml +++ b/.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/" diff --git a/.github/workflows/test.yaml b/.github/workflows/test.yaml index d20f6db..ce1c268 100644 --- a/.github/workflows/test.yaml +++ b/.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 diff --git a/CHANGELOG.md b/CHANGELOG.md index 63ad789..1650470 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/System/File/OsPath.hs b/System/File/OsPath.hs index cfbc507..6d8057f 100644 --- a/System/File/OsPath.hs +++ b/System/File/OsPath.hs @@ -23,6 +23,10 @@ module System.File.OsPath ( , appendFile' , openFile , openExistingFile +, openTempFile +, openBinaryTempFile +, openTempFileWithDefaultPermissions +, openBinaryTempFileWithDefaultPermissions ) where diff --git a/System/File/OsPath/Internal.hs b/System/File/OsPath/Internal.hs index f7e9cce..e057d90 100644 --- a/System/File/OsPath/Internal.hs +++ b/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,7 +18,7 @@ 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 @@ -23,6 +26,12 @@ 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 + diff --git a/file-io.cabal b/file-io.cabal index ba341ec..c1091f6 100644 --- a/file-io.cabal +++ b/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,9 +76,9 @@ 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 @@ -87,7 +86,7 @@ test-suite T14 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 @@ -95,7 +94,7 @@ test-suite T8 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 @@ -103,7 +102,7 @@ test-suite CLC237 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 @@ -111,6 +110,6 @@ test-suite Properties 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" diff --git a/posix/System/File/Platform.hs b/posix/System/File/Platform.hs index 760f22b..2d1e3df 100644 --- a/posix/System/File/Platform.hs +++ b/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 + diff --git a/tests/Properties.hs b/tests/Properties.hs index 6c71131..e719b3d 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -10,7 +11,7 @@ import Control.Exception import qualified System.FilePath as FP import Test.Tasty import Test.Tasty.HUnit -import System.OsPath ((), osp) +import System.OsPath ((), osp, OsPath, OsString) import qualified System.OsPath as OSP import qualified System.File.OsPath as OSP import GHC.IO.Exception (IOErrorType(..), IOException(..)) @@ -40,6 +41,18 @@ main = defaultMain $ testGroup "All" , testCase "openExistingFile yes (Write)" existingFile2' , testCase "openExistingFile yes (Append)" existingFile3' , testCase "openExistingFile yes (ReadWrite)" existingFile4' + , testCase "openTempFile" (openTempFile2 OSP.openTempFile) + , testCase "openTempFile (reopen file)" (openTempFile1 OSP.openTempFile) + , testCase "openTempFile (filepaths different)" (openTempFile3 OSP.openTempFile) + , testCase "openBinaryTempFile" (openTempFile2 OSP.openBinaryTempFile) + , testCase "openBinaryTempFile (reopen file)" (openTempFile1 OSP.openBinaryTempFile) + , testCase "openBinaryTempFile (filepaths different)" (openTempFile3 OSP.openBinaryTempFile) + , testCase "openTempFileWithDefaultPermissions" (openTempFile2 OSP.openTempFileWithDefaultPermissions) + , testCase "openTempFileWithDefaultPermissions (reopen file)" (openTempFile1 OSP.openTempFileWithDefaultPermissions) + , testCase "openTempFileWithDefaultPermissions (filepaths different)" (openTempFile3 OSP.openTempFileWithDefaultPermissions) + , testCase "openBinaryTempFileWithDefaultPermissions" (openTempFile2 OSP.openBinaryTempFileWithDefaultPermissions) + , testCase "openBinaryTempFileWithDefaultPermissions (reopen file)" (openTempFile1 OSP.openBinaryTempFileWithDefaultPermissions) + , testCase "openBinaryTempFileWithDefaultPermissions (filepaths different)" (openTempFile3 OSP.openBinaryTempFileWithDefaultPermissions) ] ] @@ -112,8 +125,9 @@ concFile = do baseDir <- OSP.encodeFS baseDir' let fp = baseDir [osp|foo|] OSP.writeFile fp "" - _ <- OSP.openFile fp ReadMode + !h <- OSP.openFile fp ReadMode r <- try @IOException $ OSP.withFile fp WriteMode $ \h' -> do BS.hPut h' "test" + _ <- try @IOException $ BS.hPut h "" IOError Nothing fileLockedType "withFile" fileLockedMsg Nothing (Just $ baseDir' FP. "foo") @==? r concFile2 :: Assertion @@ -122,8 +136,9 @@ concFile2 = do baseDir <- OSP.encodeFS baseDir' let fp = baseDir [osp|foo|] OSP.writeFile fp "h" - _ <- OSP.openFile fp ReadMode + !h <- OSP.openFile fp ReadMode r <- try @IOException $ OSP.withFile fp ReadMode BS.hGetContents + _ <- try @IOException $ BS.hPut h "" Right "h" @=? r concFile3 :: Assertion @@ -132,8 +147,9 @@ concFile3 = do baseDir <- OSP.encodeFS baseDir' let fp = baseDir [osp|foo|] OSP.writeFile fp "" - _ <- OSP.openFile fp WriteMode + !h <- OSP.openFile fp ReadMode r <- try @IOException $ OSP.withFile fp WriteMode (flip BS.hPut "test") + _ <- try @IOException $ BS.hPut h "" IOError Nothing fileLockedType "withFile" fileLockedMsg Nothing (Just $ baseDir' FP. "foo") @==? r existingFile :: Assertion @@ -209,12 +225,47 @@ existingFile4' = do OSP.openExistingFile fp ReadWriteMode >>= \h -> do hSetBuffering h NoBuffering BS.hPut h "boo" - c <- BS.hGetSome h 5 + !c <- BS.hGetSome h 5 hSeek h AbsoluteSeek 0 - c' <- BS.hGetSome h 5 + !c' <- BS.hGetSome h 5 + hClose h pure (c, c') Right ("tx", "bootx") @=? r +openTempFile1 :: (OsPath -> OsString -> IO (OsPath, Handle)) -> Assertion +openTempFile1 open = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let file = [osp|foo.ext|] + (!fp, h') <- open baseDir file + hClose h' + r <- try @IOException $ do + OSP.openExistingFile fp ReadWriteMode >>= \h -> BS.hPut h "boo" >> hClose h + OSP.readFile fp + Right "boo" @=? r + +openTempFile2 :: (OsPath -> OsString -> IO (OsPath, Handle)) -> Assertion +openTempFile2 open = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let file = [osp|foo.ext|] + (fp, h) <- open baseDir file + r <- try @IOException $ do + BS.hPut h "boo" >> hClose h + OSP.readFile fp + Right "boo" @=? r + +openTempFile3 :: (OsPath -> OsString -> IO (OsPath, Handle)) -> Assertion +openTempFile3 open = do + withSystemTempDirectory "test" $ \baseDir' -> do + baseDir <- OSP.encodeFS baseDir' + let file = [osp|foo.ext|] + (!fp, h) <- open baseDir file + (!fp', h') <- open baseDir file + hClose h + hClose h' + (fp /= fp') @? "Filepaths are different" + compareIOError :: forall a . (Eq a, Show a, HasCallStack) => IOException -> Either IOException a -> Assertion compareIOError el (Left lel) = lel { ioe_handle = Nothing diff --git a/windows/System/File/Platform.hsc b/windows/System/File/Platform.hsc index 85b34d3..02bdafc 100644 --- a/windows/System/File/Platform.hsc +++ b/windows/System/File/Platform.hsc @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PackageImports #-} module System.File.Platform where @@ -9,10 +11,15 @@ import System.IO (IOMode(..), Handle) import System.OsPath.Windows ( WindowsPath ) import qualified System.OsPath.Windows as WS import Foreign.C.Types -import Foreign.Ptr (ptrToIntPtr) +import qualified System.OsString.Windows as WS hiding (decodeFS) +import System.OsString.Windows ( pstr, WindowsString ) import qualified System.Win32 as Win32 import qualified System.Win32.WindowsString.File as WS +import System.Win32.WindowsString.Types (withTString, peekTString) +#if MIN_VERSION_Win32(2, 14, 0) +import System.Win32.WindowsString.Types (withFilePath) +#endif import Control.Monad (when, void) #if defined(__IO_MANAGER_WINIO__) import GHC.IO.SubSystem @@ -20,6 +27,30 @@ import GHC.IO.SubSystem import GHC.IO.Handle.FD (fdToHandle') #include #endif +import GHC.IORef (atomicModifyIORef'_) +import Foreign.C (getErrno, errnoToIOError) +import Data.IORef (IORef, newIORef) +import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils (with) +import Foreign.Storable +import System.CPUTime (cpuTimePrecision, getCPUTime) +import System.Posix.Types (CMode) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Internals (c_getpid, o_EXCL) +import Text.Printf (printf) + +#if MIN_VERSION_filepath(1, 5, 0) +import System.OsString.Encoding +import "os-string" System.OsString.Internal.Types (WindowsString(..), WindowsChar(..)) +import qualified "os-string" System.OsString.Data.ByteString.Short as BC +#else +import Data.Coerce (coerce) +import System.OsPath.Encoding +import "filepath" System.OsString.Internal.Types (WindowsString(..), WindowsChar(..)) +import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC +#endif -- | Open a file and return the 'Handle'. openFile :: WindowsPath -> IOMode -> IO Handle @@ -40,19 +71,8 @@ openFile fp iomode = bracketOnError #endif Nothing) Win32.closeHandle - toHandle + (toHandle fp iomode) where -#if defined(__IO_MANAGER_WINIO__) - toHandle h = (`onException` Win32.closeHandle h) $ do - when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END - Win32.hANDLEToHandle h -#else - toHandle h = (`onException` Win32.closeHandle h) $ do - when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END - fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) - fp' <- either (const (fmap WS.toChar . WS.unpack $ fp)) id <$> try @SomeException (WS.decodeFS fp) - fdToHandle' fd Nothing False fp' iomode True -#endif accessMode = case iomode of ReadMode -> Win32.gENERIC_READ WriteMode -> Win32.gENERIC_WRITE @@ -101,11 +121,8 @@ openExistingFile fp iomode = bracketOnError #endif Nothing) Win32.closeHandle - toHandle + (toHandle fp iomode) where - toHandle h = do - when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END - Win32.hANDLEToHandle h accessMode = case iomode of ReadMode -> Win32.gENERIC_READ WriteMode -> Win32.gENERIC_WRITE @@ -135,3 +152,80 @@ openFileWithCloseOnExec = openFile openExistingFileWithCloseOnExec :: WindowsPath -> IOMode -> IO Handle openExistingFileWithCloseOnExec = openExistingFile +findTempName :: (WindowsString, WindowsString) + -> String + -> WindowsPath + -> CMode + -> IO (WindowsPath, Handle) +findTempName (prefix, suffix) loc tmp_dir mode = go + where + go = do + let label = if prefix == mempty then [pstr|ghc|] else prefix +#if MIN_VERSION_Win32(2, 14, 0) + withFilePath tmp_dir $ \c_tmp_dir -> +#else + withTString tmp_dir $ \c_tmp_dir -> +#endif + withTString label $ \c_template -> + withTString suffix $ \c_suffix -> + with nullPtr $ \c_ptr -> do + res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr + if not res + then do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just $ lenientDecode tmp_dir)) + else do c_p <- peek c_ptr + filename <- peekTString c_p + free c_p + let flags = fromIntegral mode .&. o_EXCL + handleResultsWinIO filename (flags == o_EXCL) + + handleResultsWinIO filename excl = do + h <- (if excl then openExistingFile else openFile) filename ReadWriteMode + return (filename, h) + +foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo + :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool + + + +tempCounter :: IORef Int +tempCounter = unsafePerformIO $ newIORef 0 +{-# NOINLINE tempCounter #-} + +-- build large digit-alike number +rand_string :: IO WindowsPath +rand_string = do + r1 <- fromIntegral @_ @Int <$> c_getpid + (r2, _) <- atomicModifyIORef'_ tempCounter (+1) + r3 <- (`quot` cpuTimePrecision) <$> getCPUTime + return $ WS.pack $ fmap (WS.unsafeFromChar) (printf "%x-%x-%x" r1 r2 r3) + +lenientDecode :: WindowsString -> String +lenientDecode ws = let utf16le' = WS.decodeWith utf16le_b ws + ucs2' = WS.decodeWith ucs2le ws + in case (utf16le', ucs2') of + (Right s, ~_) -> s + (_, Right s) -> s + (Left _, Left _) -> error "lenientDecode: failed to decode" + + +toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle +#if defined(__IO_MANAGER_WINIO__) +toHandle _ iomode h = (`onException` Win32.closeHandle h) $ do + when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + Win32.hANDLEToHandle h +#else +toHandle fp iomode h = (`onException` Win32.closeHandle h) $ do + when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END + fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY) + fp' <- either (const (fmap WS.toChar . WS.unpack $ fp)) id <$> try @SomeException (WS.decodeFS fp) + fdToHandle' fd Nothing False fp' iomode True +#endif + +#if !MIN_VERSION_filepath(1, 5, 0) + +any_ :: (WindowsChar -> Bool) -> WindowsString -> Bool +any_ = coerce BC.any + +#endif +