Skip to content

Commit cbe0caf

Browse files
hasufellhasufell
committed
Support openTempFile and friends, fixes #2 
1 parent a4a0464 commit cbe0caf

File tree

5 files changed

+276
-20
lines changed

5 files changed

+276
-20
lines changed

‎System/File/OsPath.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,10 @@ module System.File.OsPath (
2323
, appendFile'
2424
, openFile
2525
, openExistingFile
26+
, openTempFile
27+
, openBinaryTempFile
28+
, openTempFileWithDefaultPermissions
29+
, openBinaryTempFileWithDefaultPermissions
2630
) where
2731

2832

‎System/File/OsPath/Internal.hs‎

Lines changed: 87 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,14 @@
11
{-# LANGUAGE TypeApplications #-}
22
{-# LANGUAGE BangPatterns #-}
3+
{-# LANGUAGE ViewPatterns #-}
4+
{-# LANGUAGE QuasiQuotes #-}
35

46
module System.File.OsPath.Internal where
57

68

79
import qualified System.File.Platform as P
810

9-
import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=))
11+
import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=), (==), otherwise, errorWithoutStackTrace)
1012
import GHC.IO (catchException)
1113
import GHC.IO.Exception (IOException(..))
1214
import GHC.IO.Handle (hClose_help)
@@ -18,11 +20,15 @@ import Control.DeepSeq (force)
1820
import Control.Exception (SomeException, try, evaluate, mask, onException)
1921
import System.IO (IOMode(..), hSetBinaryMode, hClose)
2022
import System.IO.Unsafe (unsafePerformIO)
23+
import System.OsString (osstr)
2124
import System.OsPath as OSP
2225
import System.OsString.Internal.Types
2326

2427
import qualified Data.ByteString as BS
2528
import qualified Data.ByteString.Lazy as BSL
29+
import qualified System.OsString as OSS
30+
import System.Posix.Types (CMode)
31+
import GHC.Base (failIO)
2632

2733
-- | Like 'openFile', but open the file in binary mode.
2834
-- On Windows, reading a file in text mode (which is the default)
@@ -127,6 +133,56 @@ openFileWithCloseOnExec osfp iomode = augmentError "openFileWithCloseOnExec" osf
127133
openExistingFileWithCloseOnExec :: OsPath -> IOMode -> IO Handle
128134
openExistingFileWithCloseOnExec osfp iomode = augmentError "openExistingFileWithCloseOnExec" osfp $ withOpenFile' osfp iomode False True True pure False
129135

136+
137+
-- | The function creates a temporary file in ReadWrite mode.
138+
-- The created file isn\'t deleted automatically, so you need to delete it manually.
139+
--
140+
-- The file is created with permissions such that only the current
141+
-- user can read\/write it.
142+
--
143+
-- With some exceptions (see below), the file will be created securely
144+
-- in the sense that an attacker should not be able to cause
145+
-- openTempFile to overwrite another file on the filesystem using your
146+
-- credentials, by putting symbolic links (on Unix) in the place where
147+
-- the temporary file is to be created. On Unix the @O_CREAT@ and
148+
-- @O_EXCL@ flags are used to prevent this attack, but note that
149+
-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
150+
-- rely on this behaviour it is best to use local filesystems only.
151+
--
152+
-- @since 0.1.3
153+
openTempFile :: OsPath -- ^ Directory in which to create the file
154+
-> OsString -- ^ File name template. If the template is \"foo.ext\" then
155+
-- the created file will be \"fooXXX.ext\" where XXX is some
156+
-- random number. Note that this should not contain any path
157+
-- separator characters. On Windows, the template prefix may
158+
-- be truncated to 3 chars, e.g. \"foobar.ext\" will be
159+
-- \"fooXXX.ext\".
160+
-> IO (OsPath, Handle)
161+
openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False 0o600
162+
163+
-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
164+
--
165+
-- @since 0.1.3
166+
openBinaryTempFile :: OsPath -> OsString -> IO (OsPath, Handle)
167+
openBinaryTempFile tmp_dir template
168+
= openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
169+
170+
-- | Like 'openTempFile', but uses the default file permissions
171+
--
172+
-- @since 0.1.3
173+
openTempFileWithDefaultPermissions :: OsPath -> OsString
174+
-> IO (OsPath, Handle)
175+
openTempFileWithDefaultPermissions tmp_dir template
176+
= openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666
177+
178+
-- | Like 'openBinaryTempFile', but uses the default file permissions
179+
--
180+
-- @since 0.1.3
181+
openBinaryTempFileWithDefaultPermissions :: OsPath -> OsString
182+
-> IO (OsPath, Handle)
183+
openBinaryTempFileWithDefaultPermissions tmp_dir template
184+
= openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666
185+
130186
-- ---------------------------------------------------------------------------
131187
-- Internals
132188

@@ -173,3 +229,33 @@ addFilePathToIOError fun fp ioe = unsafePerformIO $ do
173229
augmentError :: String -> OsPath -> IO a -> IO a
174230
augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp)
175231

232+
233+
openTempFile' :: String -> OsPath -> OsString -> Bool -> CMode
234+
-> IO (OsPath, Handle)
235+
openTempFile' loc (OsString tmp_dir) template@(OsString tmpl) binary mode
236+
| OSS.any (== OSP.pathSeparator) template
237+
= failIO $ "openTempFile': Template string must not contain path separator characters: " ++ P.lenientDecode tmpl
238+
| otherwise = do
239+
(fp, hdl) <- P.findTempName (prefix, suffix) loc tmp_dir mode
240+
when binary $ hSetBinaryMode hdl True
241+
pure (OsString fp, hdl)
242+
where
243+
-- We split off the last extension, so we can use .foo.ext files
244+
-- for temporary files (hidden on Unix OSes). Unfortunately we're
245+
-- below filepath in the hierarchy here.
246+
(OsString prefix, OsString suffix) =
247+
case OSS.break (== OSS.unsafeFromChar '.') $ OSS.reverse template of
248+
-- First case: template contains no '.'s. Just re-reverse it.
249+
(rev_suffix, [osstr||]) -> (OSS.reverse rev_suffix, OSS.empty)
250+
-- Second case: template contains at least one '.'. Strip the
251+
-- dot from the prefix and prepend it to the suffix (if we don't
252+
-- do this, the unique number will get added after the '.' and
253+
-- thus be part of the extension, which is wrong.)
254+
(rev_suffix, xs)
255+
| (h:rest) <- OSS.unpack xs
256+
, h == unsafeFromChar '.' -> (OSS.reverse (OSS.pack rest), OSS.cons (unsafeFromChar '.') $ OSS.reverse rev_suffix)
257+
-- Otherwise, something is wrong, because (break (== '.')) should
258+
-- always return a pair with either the empty string or a string
259+
-- beginning with '.' as the second component.
260+
_ -> errorWithoutStackTrace "bug in System.IO.openTempFile"
261+

‎posix/System/File/Platform.hs‎

Lines changed: 56 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,9 @@
1+
{-# LANGUAGE TupleSections #-}
12
{-# LANGUAGE TypeApplications #-}
23

34
module System.File.Platform where
45

6+
import Data.Either (fromRight)
57
import Control.Exception (try, onException, SomeException)
68
import GHC.IO.Handle.FD (fdToHandle')
79
import System.IO (IOMode(..), Handle)
@@ -10,10 +12,17 @@ import System.Posix.IO.PosixString
1012
( defaultFileFlags,
1113
openFd,
1214
closeFd,
13-
OpenFileFlags(noctty, nonBlock, creat, append, trunc, cloexec),
15+
OpenFileFlags(noctty, nonBlock, creat, append, trunc, cloexec, exclusive),
1416
OpenMode(ReadWrite, ReadOnly, WriteOnly) )
15-
import System.OsPath.Posix ( PosixPath )
17+
import System.OsPath.Posix ( PosixPath, PosixString, (</>) )
1618
import qualified System.OsPath.Posix as PS
19+
import Data.IORef (IORef, newIORef)
20+
import System.Posix (CMode)
21+
import System.IO (utf8, latin1)
22+
import System.IO.Unsafe (unsafePerformIO)
23+
import System.Posix.Internals (c_getpid)
24+
import GHC.IORef (atomicModifyIORef'_)
25+
import Foreign.C (getErrno, eEXIST, errnoToIOError)
1726

1827
-- | Open a file and return the 'Handle'.
1928
openFile :: PosixPath -> IOMode -> IO Handle
@@ -43,7 +52,7 @@ openExistingFile_ df fp iomode = fdToHandle_ iomode fp =<< case iomode of
4352

4453
fdToHandle_ :: IOMode -> PosixPath -> Fd -> IO Handle
4554
fdToHandle_ iomode fp (Fd fd) = (`onException` closeFd (Fd fd)) $ do
46-
fp' <- either (const (fmap PS.toChar . PS.unpack $ fp)) id <$> try @SomeException (PS.decodeFS fp)
55+
fp' <- fromRight (fmap PS.toChar . PS.unpack $ fp) <$> try @SomeException (PS.decodeFS fp)
4756
fdToHandle' fd Nothing False fp' iomode True
4857

4958
openFileWithCloseOnExec :: PosixPath -> IOMode -> IO Handle
@@ -58,3 +67,47 @@ defaultFileFlags' = defaultFileFlags { noctty = True, nonBlock = True }
5867
defaultExistingFileFlags :: OpenFileFlags
5968
defaultExistingFileFlags = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing }
6069

70+
findTempName :: (PosixString, PosixString)
71+
-> String
72+
-> PosixPath
73+
-> CMode
74+
-> IO (PosixPath, Handle)
75+
findTempName (prefix, suffix) loc tmp_dir mode = go
76+
where
77+
go = do
78+
rs <- rand_string
79+
let filename = prefix <> rs <> suffix
80+
filepath = tmp_dir </> filename
81+
fd <- openTempFile_ filepath mode
82+
if fd < 0
83+
then do
84+
errno <- getErrno
85+
case errno of
86+
_ | errno == eEXIST -> go
87+
_ -> do
88+
let tmp_dir' = lenientDecode tmp_dir
89+
ioError (errnoToIOError loc errno Nothing (Just tmp_dir'))
90+
else fmap (filepath,) $ fdToHandle_ ReadWriteMode filepath fd
91+
92+
openTempFile_ :: PosixPath -> CMode -> IO Fd
93+
openTempFile_ fp cmode = openFd fp ReadWrite defaultFileFlags' { creat = Just cmode, nonBlock = True, noctty = True, exclusive = True }
94+
95+
tempCounter :: IORef Int
96+
tempCounter = unsafePerformIO $ newIORef 0
97+
{-# NOINLINE tempCounter #-}
98+
99+
-- build large digit-alike number
100+
rand_string :: IO PosixString
101+
rand_string = do
102+
r1 <- c_getpid
103+
(r2, _) <- atomicModifyIORef'_ tempCounter (+1)
104+
return $ PS.pack $ fmap (PS.unsafeFromChar) (show r1 ++ "-" ++ show r2)
105+
106+
lenientDecode :: PosixString -> String
107+
lenientDecode ps = let utf8' = PS.decodeWith utf8 ps
108+
latin1' = PS.decodeWith latin1 ps
109+
in case (utf8', latin1') of
110+
(Right s, ~_) -> s
111+
(_, Right s) -> s
112+
(Left _, Left _) -> error "lenientDecode: failed to decode"
113+

‎tests/Properties.hs‎

Lines changed: 45 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import Control.Exception
1010
import qualified System.FilePath as FP
1111
import Test.Tasty
1212
import Test.Tasty.HUnit
13-
import System.OsPath ((</>), osp)
13+
import System.OsPath ((</>), osp, OsPath, OsString)
1414
import qualified System.OsPath as OSP
1515
import qualified System.File.OsPath as OSP
1616
import GHC.IO.Exception (IOErrorType(..), IOException(..))
@@ -40,6 +40,18 @@ main = defaultMain $ testGroup "All"
4040
, testCase "openExistingFile yes (Write)" existingFile2'
4141
, testCase "openExistingFile yes (Append)" existingFile3'
4242
, testCase "openExistingFile yes (ReadWrite)" existingFile4'
43+
, testCase "openTempFile" (openTempFile2 OSP.openTempFile)
44+
, testCase "openTempFile (reopen file)" (openTempFile1 OSP.openTempFile)
45+
, testCase "openTempFile (filepaths different)" (openTempFile3 OSP.openTempFile)
46+
, testCase "openBinaryTempFile" (openTempFile2 OSP.openBinaryTempFile)
47+
, testCase "openBinaryTempFile (reopen file)" (openTempFile1 OSP.openBinaryTempFile)
48+
, testCase "openBinaryTempFile (filepaths different)" (openTempFile3 OSP.openBinaryTempFile)
49+
, testCase "openTempFileWithDefaultPermissions" (openTempFile2 OSP.openTempFileWithDefaultPermissions)
50+
, testCase "openTempFileWithDefaultPermissions (reopen file)" (openTempFile1 OSP.openTempFileWithDefaultPermissions)
51+
, testCase "openTempFileWithDefaultPermissions (filepaths different)" (openTempFile3 OSP.openTempFileWithDefaultPermissions)
52+
, testCase "openBinaryTempFileWithDefaultPermissions" (openTempFile2 OSP.openBinaryTempFileWithDefaultPermissions)
53+
, testCase "openBinaryTempFileWithDefaultPermissions (reopen file)" (openTempFile1 OSP.openBinaryTempFileWithDefaultPermissions)
54+
, testCase "openBinaryTempFileWithDefaultPermissions (filepaths different)" (openTempFile3 OSP.openBinaryTempFileWithDefaultPermissions)
4355
]
4456
]
4557

@@ -215,6 +227,38 @@ existingFile4' = do
215227
pure (c, c')
216228
Right ("tx", "bootx") @=? r
217229

230+
openTempFile1 :: (OsPath -> OsString -> IO (OsPath, Handle)) -> Assertion
231+
openTempFile1 open = do
232+
withSystemTempDirectory "test" $ \baseDir' -> do
233+
baseDir <- OSP.encodeFS baseDir'
234+
let file = [osp|foo.ext|]
235+
(fp, h') <- open baseDir file
236+
hClose h'
237+
r <- try @IOException $ do
238+
OSP.openExistingFile fp ReadWriteMode >>= \h -> BS.hPut h "boo" >> hClose h
239+
OSP.readFile fp
240+
Right "boo" @=? r
241+
242+
openTempFile2 :: (OsPath -> OsString -> IO (OsPath, Handle)) -> Assertion
243+
openTempFile2 open = do
244+
withSystemTempDirectory "test" $ \baseDir' -> do
245+
baseDir <- OSP.encodeFS baseDir'
246+
let file = [osp|foo.ext|]
247+
(fp, h) <- open baseDir file
248+
r <- try @IOException $ do
249+
BS.hPut h "boo" >> hClose h
250+
OSP.readFile fp
251+
Right "boo" @=? r
252+
253+
openTempFile3 :: (OsPath -> OsString -> IO (OsPath, Handle)) -> Assertion
254+
openTempFile3 open = do
255+
withSystemTempDirectory "test" $ \baseDir' -> do
256+
baseDir <- OSP.encodeFS baseDir'
257+
let file = [osp|foo.ext|]
258+
(fp, _) <- open baseDir file
259+
(fp', _) <- open baseDir file
260+
(fp /= fp') @? "Filepaths are different"
261+
218262

219263
compareIOError :: forall a . (Eq a, Show a, HasCallStack) => IOException -> Either IOException a -> Assertion
220264
compareIOError el (Left lel) = lel { ioe_handle = Nothing

0 commit comments

Comments
 (0)