diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Exception.hs @@ -0,0 +1,49 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.Compat.Exception + (onException, catchIO, catchExit, throwIOIO) + where + +import System.Exit +import qualified Control.Exception as Exception + +onException :: IO a -> IO b -> IO a +#ifdef NEW_EXCEPTION +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#ifdef NEW_EXCEPTION +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif + diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/TempFile.hs @@ -0,0 +1,209 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + + +import System.FilePath (()) +import Foreign.C (eEXIST) + +#if __NHC__ || __HUGS__ +import System.IO (openFile, openBinaryFile, + Handle, IOMode(ReadWriteMode)) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) +#else +import System.IO (Handle, openTempFile, openBinaryTempFile) +import Data.Bits ((.|.)) +import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, + o_BINARY, o_NONBLOCK, o_NOCTTY) +import System.IO.Error (isAlreadyExistsError) +#if __GLASGOW_HASKELL__ >= 706 +import Control.Exception (try) +#else +import System.IO.Error (try) +#endif +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import Foreign.C (CInt) +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else +import GHC.Handle (fdToHandle) +#endif +import Distribution.Compat.Exception (onException) +#endif +import Foreign.C (getErrno, errnoToIOError) + +#if __NHC__ +import System.Posix.Types (CPid(..)) +foreign import ccall unsafe "getpid" c_getpid :: IO CPid +#else +import System.Posix.Internals (c_getpid) +#endif + +#ifdef mingw32_HOST_OS +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- This is here for Haskell implementations that do not come with +-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. +-- TODO: Not sure about jhc + +#if __NHC__ || __HUGS__ +-- use a temporary filename that doesn't already exist. +-- NB. *not* secure (we don't atomically lock the tmp file we get) +openTempFile :: FilePath -> String -> IO (FilePath, Handle) +openTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openFile path ReadWriteMode + return (path, hnd) + +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openBinaryFile path ReadWriteMode + return (path, hnd) + +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFile + +getProcessID :: IO Int +getProcessID = fmap fromIntegral c_getpid +#else +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = 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 + -- 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" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + +#if __GLASGOW_HASKELL__ < 611 + withFilePath = withCString +#endif + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) + -- fdToHandle is borked on Windows with ghc-6.6.x + openFd (fromIntegral fd) Nothing False filepath + ReadWriteMode True +#else + fdToHandle (fromIntegral fd) +#endif + `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR +#endif + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ show x + r <- try $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#ifdef mingw32_HOST_OS +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2008, Maximilian Bolingbroke +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/System/IO/Temp.hs b/System/IO/Temp.hs new file mode 100644 --- /dev/null +++ b/System/IO/Temp.hs @@ -0,0 +1,84 @@ +module System.IO.Temp ( + withSystemTempFile, withSystemTempDirectory, + withTempFile, withTempDirectory, + module Distribution.Compat.TempFile + ) where + +-- NB: this module was extracted directly from "Distribution/Simple/Utils.hs" +-- in a Cabal tree whose most recent commit was on Sun Oct 10 22:00:26 +-- +-- The files in the Distribution/Compat tree are exact copies of the corresponding +-- file in the Cabal checkout. + + +import Control.Monad.Catch as Exception + +import Control.Monad.IO.Class +import System.Directory +import System.IO + +import Distribution.Compat.TempFile + + +-- | Create and use a temporary directory in the system standard temporary directory. +-- +-- Behaves exactly the same as 'withTempFile', except that the parent temporary directory +-- will be that returned by 'getTemporaryDirectory'. +withSystemTempFile :: (MonadIO m, MonadMask m) => + String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file + -> m a +withSystemTempFile template action = liftIO getTemporaryDirectory >>= \tmpDir -> withTempFile tmpDir template action + +-- | Create and use a temporary directory in the system standard temporary directory. +-- +-- Behaves exactly the same as 'withTempDirectory', except that the parent temporary directory +-- will be that returned by 'getTemporaryDirectory'. +withSystemTempDirectory :: (MonadIO m, MonadMask m) => + String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> m a) -- ^ Callback that can use the directory + -> m a +withSystemTempDirectory template action = liftIO getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action + + +-- | Use a temporary filename that doesn't already exist. +-- +-- Creates a new temporary file inside the given directory, making use of the +-- template. The temp file is deleted after use. For example: +-- +-- > withTempFile "src" "sdist." $ \tmpFile hFile -> do ... +-- +-- The @tmpFlie@ will be file in the given directory, e.g. +-- @src/sdist.342@. +withTempFile :: (MonadIO m, MonadMask m) => + FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file + -> m a +withTempFile tmpDir template action = + Exception.bracket + (liftIO (openTempFile tmpDir template)) + (\(name, handle) -> liftIO (hClose handle >> ignoringIOErrors (removeFile name))) + (uncurry action) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: (MonadMask m, MonadIO m) => + FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> m a) -- ^ Callback that can use the directory + -> m a +withTempDirectory targetDir template = + Exception.bracket + (liftIO (createTempDirectory targetDir template)) + (liftIO . ignoringIOErrors . removeDirectoryRecursive) + +ignoringIOErrors :: MonadCatch m => m () -> m () +ignoringIOErrors ioe = ioe `Exception.catch` (\e -> const (return ()) (e :: IOError)) diff --git a/temporary-rc.cabal b/temporary-rc.cabal new file mode 100644 --- /dev/null +++ b/temporary-rc.cabal @@ -0,0 +1,31 @@ +name: temporary-rc +version: 1.2.0.3 +cabal-version: >= 1.6 +synopsis: Portable temporary file and directory support for Windows and Unix, based on code from Cabal +description: The functions for creating temporary files and directories in the base library are quite limited. The unixutils + package contains some good ones, but they aren't portable to Windows. + + This library just repackages the Cabal implementations of its own temporary file and folder functions so that + you can use them without linking against Cabal or depending on it being installed. + + This is a better maintained fork of the "temporary" package. +category: System, Utils +license: BSD3 +license-file: LICENSE +copyright: (c) 2003-2006, Isaac Jones + (c) 2005-2009, Duncan Coutts +author: Isaac Jones + Duncan Coutts +maintainer: Roman Cheplyaka +homepage: http://www.github.com/feuerbach/temporary +build-type: Simple + +Library + exposed-modules: System.IO.Temp + other-modules: Distribution.Compat.Exception + Distribution.Compat.TempFile + build-depends: base >= 3 && < 10, filepath >= 1.1, directory >= 1.0, + transformers >= 0.2.0.0, exceptions >= 0.6 + + if !os(windows) + build-depends: unix >= 2.3