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/src/Distribution/Compat/Exception.hs b/src/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Distribution/Compat/TempFile.hs b/src/Distribution/Compat/TempFile.hs new file mode 100644 --- /dev/null +++ b/src/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/src/System/IO/Temp.hs b/src/System/IO/Temp.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Temp.hs @@ -0,0 +1,79 @@ +module System.IO.Temp + ( createTempDirectory + , openBinaryTempFile + , openTempFile + ) 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 ( when ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, ReleaseKey, allocate ) +import System.Directory + ( doesDirectoryExist, doesFileExist, getTemporaryDirectory + , removeDirectory, removeDirectoryRecursive, removeFile ) +import System.IO ( Handle ) + +import qualified Distribution.Compat.TempFile as Compat + +-- | Create a temporary directory. The directory will be deleted if empty +-- when the resource is released. If a parent directory is supplied, the +-- temporary directory will be created there; otherwise, it will be created +-- in the system temporary directory returned by 'getTemporaryDirectory'. +createTempDirectory :: MonadResource m + => Maybe FilePath -- ^ optional parent directory + -> String + -- ^ filename template; for security, a random number + -- will be inserted between the filename and any + -- extension. + -> m (ReleaseKey, FilePath) +createTempDirectory mDir tmpl = do + dir <- resolveTempDir mDir + allocate (Compat.createTempDirectory dir tmpl) removeDirectoryRecursive + +-- | Open a temporary file in binary mode. The file will be readable and +-- writeable, but only by the current user. The file will be deleted when +-- the resource is released, if it still exists. If a parent directory is +-- supplied, the file will be created there; otherwise, it will be created +-- in the system temporary directory returned by 'getTemporaryDirectory'. +openBinaryTempFile :: MonadResource m + => Maybe FilePath -- ^ optional parent directory + -> String + -- ^ filename template; for security, a random number + -- will be inserted between the filename and any + -- extension. + -> m (ReleaseKey, FilePath, Handle) +openBinaryTempFile mDir tmpl = do + dir <- resolveTempDir mDir + (key, (path, h)) <- allocate (Compat.openBinaryTempFile dir tmpl) + (removeFileIfExists . fst) + return (key, path, h) + +-- | Open a temporary file. The file will be readable and writeable, but +-- only by the current user. The file will be deleted when the resource is +-- released, if it still exists. If a parent directory is supplied, the +-- file will be created there; otherwise, it will be created in the system +-- temporary directory returned by 'getTemporaryDirectory'. +openTempFile :: MonadResource m + => Maybe FilePath -- ^ optional parent directory + -> String + -- ^ filename template; for security, a random number will be + -- inserted between the filename and any extension. + -> m (ReleaseKey, FilePath, Handle) +openTempFile mDir tmpl = do + dir <- resolveTempDir mDir + (key, (path, h)) <- allocate (Compat.openTempFile dir tmpl) + (removeFileIfExists . fst) + return (key, path, h) + +removeFileIfExists :: FilePath -> IO () +removeFileIfExists path = do + exists <- doesFileExist path + when exists $ removeFile path + +resolveTempDir :: MonadIO m => Maybe FilePath -> m FilePath +resolveTempDir = maybe (liftIO getTemporaryDirectory) return diff --git a/temporary-resourcet.cabal b/temporary-resourcet.cabal new file mode 100644 --- /dev/null +++ b/temporary-resourcet.cabal @@ -0,0 +1,63 @@ +name: temporary-resourcet +version: 0.1.0.0 +cabal-version: >= 1.8 +synopsis: Portable temporary files and directories with automatic deletion +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 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 library provides the same functionality as the @temporary@ package, but + uses @resourcet@ to provide automatic deletion without nesting @withTempFile@. +category: System, Utils +license: BSD3 +license-file: LICENSE +copyright: (c) 2003-2006, Isaac Jones + (c) 2005-2009, Duncan Coutts + (c) 2014, Thomas Tuegel +author: Isaac Jones + Duncan Coutts + Thomas Tuegel +maintainer: Thomas Tuegel +homepage: http://www.github.com/ttuegel/temporary-resourcet +bug-reports: https://github.com/ttuegel/temporary-resourcet/issues +build-type: Simple + +source-repository head + type: git + location: https://github.com/ttuegel/temporary-resourcet.git + +Library + hs-source-dirs: src + exposed-modules: + System.IO.Temp + other-modules: + Distribution.Compat.Exception + Distribution.Compat.TempFile + build-depends: + base >=3 && <10, + directory >=1.0, + exceptions >=0.5, + filepath >=1.1, + resourcet >=0.3 && <2, + transformers >=0.2.0.0 + + if !os(windows) + build-depends: unix >=2.3 + +test-suite test-temporary-resourcet + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: + base >=3 && <10, + directory >=1.0, + resourcet >=0.3 && <2, + tasty >=0.8 && <0.11, + tasty-hunit >=0.8 && <0.11, + temporary-resourcet, + transformers >=0.2.0.0 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,68 @@ +module Main where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad ( liftM ) +import Control.Monad.IO.Class ( liftIO ) +import Control.Monad.Trans.Resource +import System.Directory ( doesDirectoryExist, doesFileExist ) +import System.IO.Temp + +main :: IO () +main = defaultMain $ testGroup "temporary-resourcet" + [ testGroup "createTempDirectory" + [ testCase "release" $ assert test_createTempDirectory_release + , testCase "runResourceT" $ assert test_createTempDirectory_runResourceT + ] + , testGroup "openBinaryTempFile" + [ testCase "release" $ assert test_openBinaryTempFile_release + , testCase "runResourceT" $ assert test_openBinaryTempFile_runResourceT + ] + , testGroup "openTempFile" + [ testCase "release" $ assert test_openTempFile_release + , testCase "runResourceT" $ assert test_openTempFile_runResourceT + ] + ] + +test_createTempDirectory_release :: IO Bool +test_createTempDirectory_release = + runResourceT $ do + (key, path) <- createTempDirectory Nothing "test-temporary-resourcet-" + release key + liftIO $ liftM not $ doesDirectoryExist path + +test_createTempDirectory_runResourceT :: IO Bool +test_createTempDirectory_runResourceT = do + path <- runResourceT $ do + (_, path) <- createTempDirectory Nothing "test-temporary-resourcet-" + return path + liftM not $ doesDirectoryExist path + +test_openBinaryTempFile_release :: IO Bool +test_openBinaryTempFile_release = + runResourceT $ do + (key, path, _) <- openBinaryTempFile Nothing "test-temporary-resourcet-" + release key + liftIO $ liftM not $ doesFileExist path + +test_openBinaryTempFile_runResourceT :: IO Bool +test_openBinaryTempFile_runResourceT = do + path <- runResourceT $ do + (_, path, _) <- openBinaryTempFile Nothing "test-temporary-resourcet-" + return path + liftM not $ doesFileExist path + +test_openTempFile_release :: IO Bool +test_openTempFile_release = + runResourceT $ do + (key, path, _) <- openTempFile Nothing "test-temporary-resourcet-" + release key + liftIO $ liftM not $ doesFileExist path + +test_openTempFile_runResourceT :: IO Bool +test_openTempFile_runResourceT = do + path <- runResourceT $ do + (_, path, _) <- openTempFile Nothing "test-temporary-resourcet-" + return path + liftM not $ doesFileExist path