Replace custom mktemp implementation in favor of one now in base
This commit is contained in:
Don Stewart
parent
420a1644ce
commit
b8e8809186
@ -5,8 +5,12 @@ synopsis: Dynamic linking for Haskell and C objects
|
|||||||
description: Dynamic linking and runtime evaluation of Haskell,
|
description: Dynamic linking and runtime evaluation of Haskell,
|
||||||
and C, including dependency chasing and package resolution.
|
and C, including dependency chasing and package resolution.
|
||||||
.
|
.
|
||||||
Described in the paper:
|
Described in the papers:
|
||||||
/Plugging Haskell In/, <http://www.cse.unsw.edu.au/~dons/papers/PSSC04.html>
|
|
||||||
|
* /Plugging Haskell In/, <http://www.cse.unsw.edu.au/~dons/papers/PSSC04.html>
|
||||||
|
* /Dynamic Applications from the Ground Up/, <http://www.cse.unsw.edu.au/~dons/papers/SC05.html>
|
||||||
|
* /Dynamic Extension of Typed Functional Languages/.
|
||||||
|
|
||||||
category: System
|
category: System
|
||||||
license: BSD3
|
license: BSD3
|
||||||
License-file: LICENSE
|
License-file: LICENSE
|
||||||
@ -25,7 +29,6 @@ library
|
|||||||
System.Eval,
|
System.Eval,
|
||||||
System.Eval.Haskell,
|
System.Eval.Haskell,
|
||||||
System.Eval.Utils,
|
System.Eval.Utils,
|
||||||
System.MkTemp,
|
|
||||||
System.Plugins,
|
System.Plugins,
|
||||||
System.Plugins.Consts,
|
System.Plugins.Consts,
|
||||||
System.Plugins.Env,
|
System.Plugins.Env,
|
||||||
|
|||||||
@ -1,274 +0,0 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE MagicHash #-}
|
|
||||||
--
|
|
||||||
-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
|
||||||
--
|
|
||||||
-- This library is free software; you can redistribute it and/or
|
|
||||||
-- modify it under the terms of the GNU Lesser General Public
|
|
||||||
-- License as published by the Free Software Foundation; either
|
|
||||||
-- version 2.1 of the License, or (at your option) any later version.
|
|
||||||
--
|
|
||||||
-- This library is distributed in the hope that it will be useful,
|
|
||||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
||||||
-- Lesser General Public License for more details.
|
|
||||||
--
|
|
||||||
-- You should have received a copy of the GNU Lesser General Public
|
|
||||||
-- License along with this library; if not, write to the Free Software
|
|
||||||
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
|
|
||||||
-- USA
|
|
||||||
--
|
|
||||||
|
|
||||||
--
|
|
||||||
-- A Haskell reimplementation of the C mktemp/mkstemp/mkstemps library
|
|
||||||
-- based on the algorithms in:
|
|
||||||
-- > $ OpenBSD: mktemp.c,v 1.17 2003/06/02 20:18:37 millert Exp $
|
|
||||||
-- which are available under the BSD license.
|
|
||||||
--
|
|
||||||
|
|
||||||
module System.MkTemp (
|
|
||||||
|
|
||||||
mktemp, -- :: FilePath -> IO Maybe FilePath
|
|
||||||
mkstemp, -- :: FilePath -> IO Maybe (FilePath, Handle)
|
|
||||||
mkstemps, -- :: FilePath -> Int -> IO Maybe (FilePath,Handle)
|
|
||||||
mkdtemp, -- :: FilePath -> IO Maybe FilePath
|
|
||||||
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.List ( )
|
|
||||||
import Data.Char ( chr, ord, isDigit )
|
|
||||||
import Control.Monad ( liftM )
|
|
||||||
import Control.Exception ( handleJust )
|
|
||||||
import System.FilePath ( splitFileName, (</>) )
|
|
||||||
import System.Directory ( doesDirectoryExist, doesFileExist, createDirectory )
|
|
||||||
import System.IO
|
|
||||||
#ifndef __MINGW32__
|
|
||||||
import System.IO.Error ( mkIOError, alreadyExistsErrorType,
|
|
||||||
isAlreadyExistsError )
|
|
||||||
#else
|
|
||||||
import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError )
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifndef __MINGW32__
|
|
||||||
import qualified System.Posix.Internals ( c_getpid )
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifdef HAVE_ARC4RANDOM
|
|
||||||
import GHC.Base hiding ( ord, chr )
|
|
||||||
import GHC.Int
|
|
||||||
#else
|
|
||||||
import System.Random ( getStdRandom, Random(randomR) )
|
|
||||||
#endif
|
|
||||||
|
|
||||||
------------------------------------------------------------------------
|
|
||||||
|
|
||||||
mkstemps :: FilePath -> Int -> IO (Maybe (FilePath,Handle))
|
|
||||||
mkstemp :: FilePath -> IO (Maybe (FilePath,Handle))
|
|
||||||
mktemp :: FilePath -> IO (Maybe FilePath)
|
|
||||||
mkdtemp :: FilePath -> IO (Maybe FilePath)
|
|
||||||
|
|
||||||
mkstemps path slen = gettemp path True False slen
|
|
||||||
|
|
||||||
mkstemp path = gettemp path True False 0
|
|
||||||
|
|
||||||
mktemp path = do v <- gettemp path False False 0
|
|
||||||
return $ case v of Just (path',_) -> Just path'; _ -> Nothing
|
|
||||||
|
|
||||||
mkdtemp path = do v <- gettemp path False True 0
|
|
||||||
return $ case v of Just (path',_) -> Just path'; _ -> Nothing
|
|
||||||
|
|
||||||
------------------------------------------------------------------------
|
|
||||||
|
|
||||||
gettemp :: FilePath -> Bool -> Bool -> Int -> IO (Maybe (FilePath, Handle))
|
|
||||||
|
|
||||||
gettemp [] _ _ _ = return Nothing
|
|
||||||
gettemp _ True True _ = return Nothing
|
|
||||||
|
|
||||||
gettemp path doopen domkdir slen = do
|
|
||||||
--
|
|
||||||
-- firstly, break up the path and extract the template
|
|
||||||
--
|
|
||||||
let (pref,tmpl,suff) = let (r,s) = splitAt (length path - slen) path
|
|
||||||
(d,f) = splitFileName r
|
|
||||||
(p,t) = break (== 'X') f
|
|
||||||
in (d </> p,t,s)
|
|
||||||
--
|
|
||||||
-- an error if there is only a suffix, it seems
|
|
||||||
--
|
|
||||||
if null pref && null tmpl then return Nothing else do {
|
|
||||||
--
|
|
||||||
-- replace end of template with process id, and rest with randomness
|
|
||||||
--
|
|
||||||
;pid <- liftM show $ getProcessID
|
|
||||||
;let (rest, xs) = merge tmpl pid
|
|
||||||
;as <- randomise rest
|
|
||||||
;let tmpl' = as ++ xs
|
|
||||||
path' = pref ++ tmpl' ++ suff
|
|
||||||
--
|
|
||||||
-- just check if we can get at the directory we might need
|
|
||||||
--
|
|
||||||
;dir_ok <- if doopen || domkdir
|
|
||||||
then let d = reverse $ dropWhile (/= '/') $ reverse path'
|
|
||||||
in doesDirectoryExist d
|
|
||||||
else return True
|
|
||||||
|
|
||||||
;if not dir_ok then return Nothing else do {
|
|
||||||
--
|
|
||||||
-- We need a function for looking for appropriate temp files
|
|
||||||
--
|
|
||||||
;let fn p
|
|
||||||
| doopen = handleJust isInUse (\_ -> return Nothing) $
|
|
||||||
do h <- open0600 p ; return $ Just h
|
|
||||||
| domkdir = handleJust alreadyExists (\_ -> return Nothing) $
|
|
||||||
do mkdir0700 p ; return $ Just undefined
|
|
||||||
| otherwise = do b <- doesFileExist p
|
|
||||||
return $ if b then Nothing else Just undefined
|
|
||||||
|
|
||||||
--
|
|
||||||
-- now, try to create the tmp file, permute if we can't
|
|
||||||
-- once we've tried all permutations, give up
|
|
||||||
--
|
|
||||||
;let tryIt p t i =
|
|
||||||
do v <- fn p
|
|
||||||
case v of Just h -> return $ Just (p,h) -- it worked
|
|
||||||
Nothing -> let (i',t') = tweak i t
|
|
||||||
in if null t'
|
|
||||||
then return Nothing -- no more
|
|
||||||
else tryIt (pref++t'++suff) t' i'
|
|
||||||
;tryIt path' tmpl' 0
|
|
||||||
|
|
||||||
}}
|
|
||||||
|
|
||||||
--
|
|
||||||
-- Replace X's with pid digits. Complete rewrite
|
|
||||||
--
|
|
||||||
merge :: String -> String -> (String,String)
|
|
||||||
merge t [] = (t ,[])
|
|
||||||
merge [] _ = ([] ,[])
|
|
||||||
merge (_:ts) (p:ps) = (ts',p:ps')
|
|
||||||
where (ts',ps') = merge ts ps
|
|
||||||
|
|
||||||
--
|
|
||||||
-- And replace remaining X's with random chars
|
|
||||||
-- randomR is pretty slow, oh well.
|
|
||||||
--
|
|
||||||
randomise :: String -> IO String
|
|
||||||
randomise [] = return []
|
|
||||||
randomise ('X':xs) = do p <- getRandom ()
|
|
||||||
let c = chr $! if p < 26
|
|
||||||
then p + (ord 'A')
|
|
||||||
else (p - 26) + (ord 'a')
|
|
||||||
xs' <- randomise xs
|
|
||||||
return (c : xs')
|
|
||||||
randomise s = return s
|
|
||||||
|
|
||||||
--
|
|
||||||
-- "tricky little algorithm for backward compatibility"
|
|
||||||
-- could do with a Haskellish rewrite
|
|
||||||
--
|
|
||||||
tweak :: Int -> String -> (Int,String)
|
|
||||||
tweak i s
|
|
||||||
| i > length s - 1 = (i,[]) -- no more
|
|
||||||
| s !! i == 'Z' = if i == length s - 1
|
|
||||||
then (i,[]) -- no more
|
|
||||||
else let s' = splice (i+1) 'a'
|
|
||||||
in tweak (i+1) s' -- loop
|
|
||||||
| otherwise = let c = s !! i in case () of {_
|
|
||||||
| isDigit c -> (i, splice i 'a' )
|
|
||||||
| c == 'z' -> (i, splice i 'A' )
|
|
||||||
| otherwise -> let c' = chr $ (ord c) + 1 in (i,splice i c')
|
|
||||||
}
|
|
||||||
where
|
|
||||||
splice j c = let (a,b) = splitAt j s in a ++ [c] ++ tail b
|
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
|
||||||
|
|
||||||
alreadyExists :: IOError -> Maybe IOError
|
|
||||||
alreadyExists ioe
|
|
||||||
| isAlreadyExistsError ioe = Just ioe
|
|
||||||
| otherwise = Nothing
|
|
||||||
|
|
||||||
isInUse :: IOError -> Maybe ()
|
|
||||||
#ifndef __MINGW32__
|
|
||||||
isInUse ioe
|
|
||||||
| isAlreadyExistsError ioe = Just ()
|
|
||||||
| otherwise = Nothing
|
|
||||||
#else
|
|
||||||
isInUse ioe
|
|
||||||
| isAlreadyInUseError ioe = Just ()
|
|
||||||
| isPermissionError ioe = Just ()
|
|
||||||
| isAlreadyExistsError ioe = Just () -- we throw this
|
|
||||||
| otherwise = Nothing
|
|
||||||
isInUse _ = Nothing
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
|
||||||
-- Create a file mode 0600 if possible
|
|
||||||
--
|
|
||||||
-- N.B. race condition between testing existence and opening
|
|
||||||
-- But we can live with that to avoid a posix dependency, right?
|
|
||||||
--
|
|
||||||
open0600 :: FilePath -> IO Handle
|
|
||||||
open0600 f = do
|
|
||||||
b <- doesFileExist f
|
|
||||||
if b then ioError err -- race
|
|
||||||
else openFile f ReadWriteMode
|
|
||||||
where
|
|
||||||
err = mkIOError alreadyExistsErrorType "op0600" Nothing (Just f)
|
|
||||||
|
|
||||||
{-
|
|
||||||
-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600)
|
|
||||||
--
|
|
||||||
open0600 f = do
|
|
||||||
openFd f ReadWrite (Just o600) excl >>= fdToHandle
|
|
||||||
where
|
|
||||||
o600 = ownerReadMode `unionFileModes` ownerWriteMode
|
|
||||||
excl = defaultFileFlags { exclusive = True }
|
|
||||||
-}
|
|
||||||
|
|
||||||
--
|
|
||||||
-- create a directory mode 0700 if possible
|
|
||||||
--
|
|
||||||
mkdir0700 :: FilePath -> IO ()
|
|
||||||
mkdir0700 dir = createDirectory dir
|
|
||||||
{-
|
|
||||||
System.Posix.Directory.createDirectory dir ownerModes
|
|
||||||
-}
|
|
||||||
|
|
||||||
-- | getProcessId, stolen from GHC /main\/SysTools.lhs/
|
|
||||||
--
|
|
||||||
#ifdef __MINGW32__
|
|
||||||
-- relies on Int == Int32 on Windows
|
|
||||||
foreign import ccall unsafe "_getpid" getProcessID' :: IO Int
|
|
||||||
getProcessID :: IO Int
|
|
||||||
getProcessID = liftM abs getProcessID'
|
|
||||||
#else
|
|
||||||
getProcessID :: IO Int
|
|
||||||
#ifdef CYGWIN
|
|
||||||
getProcessID = System.Posix.Internals.c_getpid >>= return . abs . fromIntegral
|
|
||||||
#else
|
|
||||||
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
|
|
||||||
#endif
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
|
||||||
-- | Use a variety of random functions, if you like.
|
|
||||||
--
|
|
||||||
getRandom :: () -> IO Int
|
|
||||||
|
|
||||||
#ifndef HAVE_ARC4RANDOM
|
|
||||||
getRandom _ = getStdRandom (randomR (0,51))
|
|
||||||
#else
|
|
||||||
--
|
|
||||||
-- OpenBSD: "The arc4random() function provides a high quality 32-bit
|
|
||||||
-- pseudo-random number very quickly. arc4random() seeds itself on a
|
|
||||||
-- regular basis from the kernel strong random number subsystem
|
|
||||||
-- described in random(4)." Also, it is a bit faster than getStdRandom
|
|
||||||
--
|
|
||||||
getRandom _ = do
|
|
||||||
(I32# i) <- c_arc4random
|
|
||||||
return (I# (word2Int# ((int2Word# i `and#` int2Word# 0xffff#)
|
|
||||||
`remWord#` int2Word# 52#)))
|
|
||||||
|
|
||||||
foreign import ccall unsafe "stdlib.h arc4random" c_arc4random :: IO Int32
|
|
||||||
#endif
|
|
||||||
@ -61,7 +61,7 @@ module System.Plugins.Utils (
|
|||||||
|
|
||||||
import System.Plugins.Env ( isLoaded )
|
import System.Plugins.Env ( isLoaded )
|
||||||
import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )
|
import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )
|
||||||
import qualified System.MkTemp ( mkstemps )
|
-- import qualified System.MkTemp ( mkstemps )
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.List
|
import Data.List
|
||||||
@ -94,11 +94,11 @@ hWrite hdl src = hPutStr hdl src >> hClose hdl >> return ()
|
|||||||
-- mkstemps(3).
|
-- mkstemps(3).
|
||||||
--
|
--
|
||||||
|
|
||||||
mkstemps :: String -> Int -> IO (String,Handle)
|
-- mkstemps :: String -> Int -> IO (String,Handle)
|
||||||
mkstemps path slen = do
|
-- mkstemps path slen = do
|
||||||
m_v <- System.MkTemp.mkstemps path slen
|
-- m_v <- System.MkTemp.mkstemps path slen
|
||||||
case m_v of Nothing -> error "mkstemps : couldn't create temp file"
|
-- case m_v of Nothing -> error "mkstemps : couldn't create temp file"
|
||||||
Just v' -> return v'
|
-- Just v' -> return v'
|
||||||
|
|
||||||
{-
|
{-
|
||||||
|
|
||||||
@ -124,7 +124,9 @@ mkTemp = do tmpd <- catch (getEnv "TMPDIR") (\_ -> return tmpDir)
|
|||||||
|
|
||||||
mkTempIn :: String -> IO (String, Handle)
|
mkTempIn :: String -> IO (String, Handle)
|
||||||
mkTempIn tmpd = do
|
mkTempIn tmpd = do
|
||||||
(tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3
|
-- XXX (tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3
|
||||||
|
|
||||||
|
(tmpf, hdl) <- openTempFile tmpd "MXXXXX.hs"
|
||||||
let modname = mkModid $ dropSuffix tmpf
|
let modname = mkModid $ dropSuffix tmpf
|
||||||
if and $ map (\c -> isAlphaNum c && c /= '_') modname
|
if and $ map (\c -> isAlphaNum c && c /= '_') modname
|
||||||
then return (tmpf,hdl)
|
then return (tmpf,hdl)
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user