X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FIO.hs;h=a543f2b1f6c27454f635fef63d0817d34eba3396;hb=4dc0a6fa50f56444c76e84387a16b179df2549ee;hp=a5b9d7d2e3fae659e773eb9c8b0f41ea4b1c3669;hpb=dd487472345cffd5b440f2e73f3244bf20a49eb7;p=ghc-base.git diff --git a/System/IO.hs b/System/IO.hs index a5b9d7d..a543f2b 100644 --- a/System/IO.hs +++ b/System/IO.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : System.IO @@ -16,14 +16,14 @@ module System.IO ( -- * The IO monad - IO, -- instance MonadFix - fixIO, -- :: (a -> IO a) -> IO a + IO, -- instance MonadFix + fixIO, -- :: (a -> IO a) -> IO a -- * Files and handles - FilePath, -- :: String + FilePath, -- :: String - Handle, -- abstract, instance of: Eq, Show. + Handle, -- abstract, instance of: Eq, Show. -- ** Standard handles @@ -37,20 +37,20 @@ module System.IO ( -- ** Opening files withFile, - openFile, -- :: FilePath -> IOMode -> IO Handle + openFile, -- :: FilePath -> IOMode -> IO Handle IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), -- ** Closing files - hClose, -- :: Handle -> IO () + hClose, -- :: Handle -> IO () -- ** Special cases -- | These functions are also exported by the "Prelude". - readFile, -- :: FilePath -> IO String - writeFile, -- :: FilePath -> String -> IO () - appendFile, -- :: FilePath -> String -> IO () + readFile, -- :: FilePath -> IO String + writeFile, -- :: FilePath -> String -> IO () + appendFile, -- :: FilePath -> String -> IO () -- ** File locking @@ -60,33 +60,33 @@ module System.IO ( -- ** Determining and changing the size of a file - hFileSize, -- :: Handle -> IO Integer + hFileSize, -- :: Handle -> IO Integer #ifdef __GLASGOW_HASKELL__ hSetFileSize, -- :: Handle -> Integer -> IO () #endif -- ** Detecting the end of input - hIsEOF, -- :: Handle -> IO Bool - isEOF, -- :: IO Bool + hIsEOF, -- :: Handle -> IO Bool + isEOF, -- :: IO Bool -- ** Buffering operations BufferMode(NoBuffering,LineBuffering,BlockBuffering), - hSetBuffering, -- :: Handle -> BufferMode -> IO () - hGetBuffering, -- :: Handle -> IO BufferMode - hFlush, -- :: Handle -> IO () + hSetBuffering, -- :: Handle -> BufferMode -> IO () + hGetBuffering, -- :: Handle -> IO BufferMode + hFlush, -- :: Handle -> IO () -- ** Repositioning handles - hGetPosn, -- :: Handle -> IO HandlePosn - hSetPosn, -- :: HandlePosn -> IO () + hGetPosn, -- :: Handle -> IO HandlePosn + hSetPosn, -- :: HandlePosn -> IO () HandlePosn, -- abstract, instance of: Eq, Show. - hSeek, -- :: Handle -> SeekMode -> Integer -> IO () + hSeek, -- :: Handle -> SeekMode -> Integer -> IO () SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), #if !defined(__NHC__) - hTell, -- :: Handle -> IO Integer + hTell, -- :: Handle -> IO Integer #endif -- ** Handle properties @@ -95,94 +95,158 @@ module System.IO ( hIsReadable, hIsWritable, -- :: Handle -> IO Bool hIsSeekable, -- :: Handle -> IO Bool - -- ** Terminal operations + -- ** Terminal operations (not portable: GHC\/Hugs only) #if !defined(__NHC__) - hIsTerminalDevice, -- :: Handle -> IO Bool + hIsTerminalDevice, -- :: Handle -> IO Bool - hSetEcho, -- :: Handle -> Bool -> IO () - hGetEcho, -- :: Handle -> IO Bool + hSetEcho, -- :: Handle -> Bool -> IO () + hGetEcho, -- :: Handle -> IO Bool #endif - -- ** Showing handle state + -- ** Showing handle state (not portable: GHC only) #ifdef __GLASGOW_HASKELL__ - hShow, -- :: Handle -> IO String + hShow, -- :: Handle -> IO String #endif -- * Text input and output -- ** Text input - hWaitForInput, -- :: Handle -> Int -> IO Bool - hReady, -- :: Handle -> IO Bool - hGetChar, -- :: Handle -> IO Char - hGetLine, -- :: Handle -> IO [Char] - hLookAhead, -- :: Handle -> IO Char - hGetContents, -- :: Handle -> IO [Char] + hWaitForInput, -- :: Handle -> Int -> IO Bool + hReady, -- :: Handle -> IO Bool + hGetChar, -- :: Handle -> IO Char + hGetLine, -- :: Handle -> IO [Char] + hLookAhead, -- :: Handle -> IO Char + hGetContents, -- :: Handle -> IO [Char] -- ** Text output - hPutChar, -- :: Handle -> Char -> IO () - hPutStr, -- :: Handle -> [Char] -> IO () - hPutStrLn, -- :: Handle -> [Char] -> IO () - hPrint, -- :: Show a => Handle -> a -> IO () + hPutChar, -- :: Handle -> Char -> IO () + hPutStr, -- :: Handle -> [Char] -> IO () + hPutStrLn, -- :: Handle -> [Char] -> IO () + hPrint, -- :: Show a => Handle -> a -> IO () -- ** Special cases for standard input and output -- | These functions are also exported by the "Prelude". - interact, -- :: (String -> String) -> IO () - putChar, -- :: Char -> IO () - putStr, -- :: String -> IO () - putStrLn, -- :: String -> IO () - print, -- :: Show a => a -> IO () - getChar, -- :: IO Char - getLine, -- :: IO String - getContents, -- :: IO String - readIO, -- :: Read a => String -> IO a - readLn, -- :: Read a => IO a + interact, -- :: (String -> String) -> IO () + putChar, -- :: Char -> IO () + putStr, -- :: String -> IO () + putStrLn, -- :: String -> IO () + print, -- :: Show a => a -> IO () + getChar, -- :: IO Char + getLine, -- :: IO String + getContents, -- :: IO String + readIO, -- :: Read a => String -> IO a + readLn, -- :: Read a => IO a -- * Binary input and output withBinaryFile, - openBinaryFile, -- :: FilePath -> IOMode -> IO Handle - hSetBinaryMode, -- :: Handle -> Bool -> IO () - hPutBuf, -- :: Handle -> Ptr a -> Int -> IO () - hGetBuf, -- :: Handle -> Ptr a -> Int -> IO Int + openBinaryFile, -- :: FilePath -> IOMode -> IO Handle + hSetBinaryMode, -- :: Handle -> Bool -> IO () + hPutBuf, -- :: Handle -> Ptr a -> Int -> IO () + hGetBuf, -- :: Handle -> Ptr a -> Int -> IO Int #if !defined(__NHC__) && !defined(__HUGS__) - hPutBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int - hGetBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int + hGetBufSome, -- :: Handle -> Ptr a -> Int -> IO Int + hPutBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int + hGetBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int #endif -- * Temporary files openTempFile, openBinaryTempFile, + openTempFileWithDefaultPermissions, + openBinaryTempFileWithDefaultPermissions, + +#if !defined(__NHC__) && !defined(__HUGS__) + -- * Unicode encoding\/decoding + + -- | A text-mode 'Handle' has an associated 'TextEncoding', which + -- is used to decode bytes into Unicode characters when reading, + -- and encode Unicode characters into bytes when writing. + -- + -- The default 'TextEncoding' is the same as the default encoding + -- on your system, which is also available as 'localeEncoding'. + -- (GHC note: on Windows, we currently do not support double-byte + -- encodings; if the console\'s code page is unsupported, then + -- 'localeEncoding' will be 'latin1'.) + -- + -- Encoding and decoding errors are always detected and reported, + -- except during lazy I/O ('hGetContents', 'getContents', and + -- 'readFile'), where a decoding error merely results in + -- termination of the character stream, as with other I/O errors. + + hSetEncoding, + hGetEncoding, + + -- ** Unicode encodings + TextEncoding, + latin1, + utf8, utf8_bom, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding, + mkTextEncoding, +#endif + +#if !defined(__NHC__) && !defined(__HUGS__) + -- * Newline conversion + + -- | In Haskell, a newline is always represented by the character + -- '\n'. However, in files and external character streams, a + -- newline may be represented by another character sequence, such + -- as '\r\n'. + -- + -- A text-mode 'Handle' has an associated 'NewlineMode' that + -- specifies how to transate newline characters. The + -- 'NewlineMode' specifies the input and output translation + -- separately, so that for instance you can translate '\r\n' + -- to '\n' on input, but leave newlines as '\n' on output. + -- + -- The default 'NewlineMode' for a 'Handle' is + -- 'nativeNewlineMode', which does no translation on Unix systems, + -- but translates '\r\n' to '\n' and back on Windows. + -- + -- Binary-mode 'Handle's do no newline translation at all. + -- + hSetNewlineMode, + Newline(..), nativeNewline, + NewlineMode(..), + noNewlineTranslation, universalNewlineMode, nativeNewlineMode, +#endif ) where +import Control.Exception.Base + +#ifndef __NHC__ import Data.Bits import Data.List import Data.Maybe import Foreign.C.Error -import Foreign.C.String +import Foreign.C.Types import System.Posix.Internals - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exception as ExceptionBase hiding (catch) -#endif -#ifdef __HUGS__ -import Hugs.Exception as ExceptionBase +import System.Posix.Types #endif #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase -- Together these four Prelude modules define -import GHC.Handle -- all the stuff exported by IO for the GHC version -import GHC.IO -import GHC.Exception +import GHC.Real +import GHC.IO hiding ( onException ) +import GHC.IO.IOMode +import GHC.IO.Handle.FD +import qualified GHC.IO.FD as FD +import GHC.IO.Handle +import GHC.IO.Handle.Text ( hGetBufSome ) +import GHC.IORef +import GHC.IO.Exception ( userError ) +import GHC.IO.Encoding import GHC.Num -import GHC.Read +import Text.Read import GHC.Show #endif @@ -190,9 +254,7 @@ import GHC.Show import Hugs.IO import Hugs.IOExts import Hugs.IORef -import Hugs.Prelude ( throw, Exception(NonTermination) ) -import Control.Exception ( bracket ) -import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Unsafe ( unsafeInterleaveIO ) #endif #ifdef __NHC__ @@ -305,7 +367,7 @@ interact f = do s <- getContents -- The file is read lazily, on demand, as with 'getContents'. readFile :: FilePath -> IO String -readFile name = openFile name ReadMode >>= hGetContents +readFile name = openFile name ReadMode >>= hGetContents -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@. @@ -336,11 +398,11 @@ readLn = do l <- getLine readIO :: Read a => String -> IO a readIO s = case (do { (x,t) <- reads s ; - ("","") <- lex t ; + ("","") <- lex t ; return x }) of - [x] -> return x - [] -> ioError (userError "Prelude.readIO: no parse") - _ -> ioError (userError "Prelude.readIO: ambiguous parse") + [x] -> return x + [] -> ioError (userError "Prelude.readIO: no parse") + _ -> ioError (userError "Prelude.readIO: ambiguous parse") #endif /* __GLASGOW_HASKELL__ */ #ifndef __NHC__ @@ -351,12 +413,12 @@ readIO s = case (do { (x,t) <- reads s ; -- -- * 'System.IO.Error.isEOFError' if the end of file has been reached. -hReady :: Handle -> IO Bool -hReady h = hWaitForInput h 0 +hReady :: Handle -> IO Bool +hReady h = hWaitForInput h 0 -- | The same as 'hPutStr', but adds a newline character. -hPutStrLn :: Handle -> String -> IO () +hPutStrLn :: Handle -> String -> IO () hPutStrLn hndl str = do hPutStr hndl str hPutChar hndl '\n' @@ -371,8 +433,8 @@ hPutStrLn hndl str = do -- -- * 'System.IO.Error.isPermissionError' if another system resource limit would be exceeded. -hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStrLn hdl . show +hPrint :: Show a => Handle -> a -> IO () +hPrint hdl = hPutStrLn hdl . show #endif /* !__NHC__ */ -- | @'withFile' name mode act@ opens a file using 'openFile' and passes @@ -410,33 +472,74 @@ fixIO k = do -- Assume a unix platform, where text and binary I/O are identical. openBinaryFile = openFile hSetBinaryMode _ _ = return () + +type CMode = Int #endif -- | 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 creates 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. +-- openTempFile :: FilePath -- ^ Directory in which to create the file -> String -- ^ File name template. If the template is \"foo.ext\" then - -- the create file will be \"fooXXX.ext\" where XXX is some + -- the created file will be \"fooXXX.ext\" where XXX is some -- random number. -> IO (FilePath, Handle) -openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False +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. openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True - -openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle) -openTempFile' loc tmp_dir template binary = do +openBinaryTempFile tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 + +-- | Like 'openTempFile', but uses the default file permissions +openTempFileWithDefaultPermissions :: FilePath -> String + -> IO (FilePath, Handle) +openTempFileWithDefaultPermissions tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template False 0o666 + +-- | Like 'openBinaryTempFile', but uses the default file permissions +openBinaryTempFileWithDefaultPermissions :: FilePath -> String + -> IO (FilePath, Handle) +openBinaryTempFileWithDefaultPermissions tmp_dir template + = openTempFile' "openBinaryTempFile" tmp_dir template True 0o666 + +openTempFile' :: String -> FilePath -> String -> Bool -> CMode + -> IO (FilePath, Handle) +openTempFile' loc tmp_dir template binary mode = do pid <- c_getpid findTempName pid 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. - (prefix,suffix) = case break (== '.') $ reverse template of - (rev_suffix, rev_prefix) -> - (reverse rev_prefix, reverse rev_suffix) + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- 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, '.':rest) -> (reverse rest, '.':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. + _ -> error "bug in System.IO.openTempFile" +#ifndef __NHC__ oflags1 = rw_flags .|. o_EXCL binary_flags @@ -444,26 +547,47 @@ openTempFile' loc tmp_dir template binary = do | otherwise = 0 oflags = oflags1 .|. binary_flags +#endif +#if defined(__NHC__) + findTempName x = do h <- openFile filepath ReadWriteMode + return (filepath, h) +#elif defined(__GLASGOW_HASKELL__) findTempName x = do - fd <- withCString filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 + fd <- withFilePath filepath $ \ f -> + c_open f oflags mode + if fd < 0 then do errno <- getErrno if errno == eEXIST then findTempName (x+1) else ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) else do - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- fdToHandle fd - `ExceptionBase.catchException` \e -> do c_close fd; throw e - return (filepath, h) + + (fD,fd_type) <- FD.mkFD (fromIntegral fd) ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} + (Just localeEncoding) + + return (filepath, h) +#else + h <- fdToHandle fd `onException` c_close fd + return (filepath, h) +#endif + where filename = prefix ++ show x ++ suffix - filepath = tmp_dir ++ [pathSeparator] ++ filename + filepath = tmp_dir `combine` filename + + -- XXX bits copied from System.FilePath, since that's not available here + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + #if __HUGS__ fdToHandle fd = openFd (fromIntegral fd) False ReadWriteMode binary #endif @@ -476,13 +600,17 @@ pathSeparator = '\\' pathSeparator = '/' #endif +#ifndef __NHC__ -- XXX Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT -read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY rw_flags = output_flags .|. o_RDWR -append_flags = write_flags .|. o_APPEND +#endif + +#ifdef __NHC__ +foreign import ccall "getpid" c_getpid :: IO Int +#endif -- $locking -- Implementations should enforce as far as possible, at least locally to the @@ -502,24 +630,3 @@ append_flags = write_flags .|. o_APPEND -- It follows that an attempt to write to a file (using 'writeFile', for -- example) that was earlier opened by 'readFile' will usually result in -- failure with 'System.IO.Error.isAlreadyInUseError'. - --- ----------------------------------------------------------------------------- --- Utils - -#ifdef __GLASGOW_HASKELL__ --- Copied here to avoid recursive dependency with Control.Exception -bracket - :: IO a -- ^ computation to run first (\"acquire resource\") - -> (a -> IO b) -- ^ computation to run last (\"release resource\") - -> (a -> IO c) -- ^ computation to run in-between - -> IO c -- returns the value from the in-between computation -bracket before after thing = - block (do - a <- before - r <- catchException - (unblock (thing a)) - (\e -> do { after a; throw e }) - after a - return r - ) -#endif