temporary-resourcet (empty) → 0.1.0.0
raw patch · 7 files changed
+493/−0 lines, 7 filesdep +basedep +directorydep +exceptionssetup-changed
Dependencies added: base, directory, exceptions, filepath, resourcet, tasty, tasty-hunit, temporary-resourcet, transformers, unix
Files
- LICENSE +22/−0
- Setup.lhs +3/−0
- src/Distribution/Compat/Exception.hs +49/−0
- src/Distribution/Compat/TempFile.hs +209/−0
- src/System/IO/Temp.hs +79/−0
- temporary-resourcet.cabal +63/−0
- test/Test.hs +68/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Distribution/Compat/Exception.hs view
@@ -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+
+ src/Distribution/Compat/TempFile.hs view
@@ -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
+ src/System/IO/Temp.hs view
@@ -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
+ temporary-resourcet.cabal view
@@ -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 <ijones@syntaxpolice.org>+ Duncan Coutts <duncan@haskell.org>+ Thomas Tuegel <ttuegel@gmail.com>+maintainer: Thomas Tuegel <ttuegel@gmail.com>+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
+ test/Test.hs view
@@ -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