2005-04-24 08:51:33 +00:00
{- # OPTIONS - cpp - fffi - fglasgow - exts # -}
2005-04-25 03:48:00 +00:00
--
-- glaexts for I# ops
2005-04-24 08:51:33 +00:00
--
2005-04-25 03:48:00 +00:00
-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
2005-04-24 08:51:33 +00:00
--
-- 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:
2005-04-25 03:48:00 +00:00
-- > $ OpenBSD: mktemp.c,v 1.17 2003/06/02 20:18:37 millert Exp $
2005-04-24 08:51:33 +00:00
-- which are available under the BSD license.
--
module Plugins.MkTemp (
2005-04-25 03:48:00 +00:00
mktemp , -- :: FilePath -> IO Maybe FilePath
mkstemp , -- :: FilePath -> IO Maybe (FilePath, Handle)
mkstemps , -- :: FilePath -> Int -> IO Maybe (FilePath,Handle)
mkdtemp , -- :: FilePath -> IO Maybe FilePath
2005-04-24 08:51:33 +00:00
) where
import Data.List
2005-04-25 03:48:00 +00:00
import Data.Char ( chr , ord , isDigit )
2005-04-24 08:51:33 +00:00
import Control.Monad ( liftM )
import Control.Exception ( handleJust )
2005-04-25 03:48:00 +00:00
import System.Directory ( doesDirectoryExist , doesFileExist , createDirectory )
import System.IO
2005-04-24 08:51:33 +00:00
import System.IO.Error ( isAlreadyExistsError )
2005-04-25 03:48:00 +00:00
import GHC.IOBase ( IOException ( IOError ) ,
Exception ( IOException ) ,
IOErrorType ( AlreadyExists ) )
2005-04-24 08:51:33 +00:00
# ifndef __MINGW32__
import qualified System.Posix.Internals ( c_getpid )
# endif
2005-04-25 03:48:00 +00:00
# ifdef HAVE_ARC4RANDOM
import GHC.Base hiding ( ord , chr )
2005-04-24 08:51:33 +00:00
import GHC.Int
2005-04-25 03:48:00 +00:00
# else
import System.Random ( getStdRandom , Random ( randomR ) )
2005-04-24 08:51:33 +00:00
# endif
2005-04-25 03:48:00 +00:00
------------------------------------------------------------------------
2005-04-24 08:51:33 +00:00
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
2005-04-25 03:48:00 +00:00
------------------------------------------------------------------------
2005-04-24 08:51:33 +00:00
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
( p , t ) = break ( == 'X' ) r
in ( 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
--
2005-05-03 14:54:20 +00:00
; pid <- liftM show $ do { v <- getProcessID ; return $ abs v } -- getProcessID returns a negative number? why, dunno, but the minus sign screws up Module header names, illegal char.
-- ;pid <- liftM show $ getProcessID
2005-04-24 08:51:33 +00:00
; 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
-- ---------------------------------------------------------------------
2005-04-25 03:48:00 +00:00
alreadyExists :: Exception -> Maybe Exception
2005-04-24 08:51:33 +00:00
alreadyExists e @ ( IOException ioe )
| isAlreadyExistsError ioe = Just e
| otherwise = Nothing
alreadyExists _ = Nothing
2005-04-25 03:48:00 +00:00
isInUse :: Exception -> Maybe ()
2005-04-24 08:51:33 +00:00
# ifndef __MINGW32__
isInUse ( IOException ioe )
| isAlreadyExistsError ioe = Just ()
| otherwise = Nothing
isInUse _ = Nothing
# else
isInUse ( IOException 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
--
2005-04-25 03:48:00 +00:00
-- N.B. race condition between testing existence and opening
-- But we can live with that to avoid a posix dependency, right?
--
2005-04-24 08:51:33 +00:00
open0600 :: FilePath -> IO Handle
2005-04-25 03:48:00 +00:00
open0600 f = do
b <- doesFileExist f
if b then ioError err -- race
else openFile f ReadWriteMode
where
err = IOError Nothing AlreadyExists " open0600 " " already exists " Nothing
2005-04-24 08:51:33 +00:00
2005-04-25 03:48:00 +00:00
{-
2005-04-24 08:51:33 +00:00
-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600)
2005-04-25 03:48:00 +00:00
--
2005-04-24 08:51:33 +00:00
open0600 f = do
openFd f ReadWrite ( Just o600 ) excl >>= fdToHandle
where
o600 = ownerReadMode ` unionFileModes ` ownerWriteMode
excl = defaultFileFlags { exclusive = True }
2005-04-25 03:48:00 +00:00
- }
2005-04-24 08:51:33 +00:00
--
-- create a directory mode 0700 if possible
--
mkdir0700 :: FilePath -> IO ()
2005-04-25 03:48:00 +00:00
mkdir0700 dir = createDirectory dir
{-
2005-04-24 08:51:33 +00:00
System . Posix . Directory . createDirectory dir ownerModes
2005-04-25 03:48:00 +00:00
- }
2005-04-24 08:51:33 +00:00
-- | getProcessId, stolen from GHC
2005-04-25 03:48:00 +00:00
--
2005-04-24 08:51:33 +00:00
# ifdef __MINGW32__
foreign import ccall unsafe " _getpid " getProcessID :: IO Int
# else
getProcessID :: IO Int
2005-04-25 03:48:00 +00:00
getProcessID = System . Posix . Internals . c_getpid >>= return . fromIntegral
2005-04-24 08:51:33 +00:00
# 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
2005-04-25 03:48:00 +00:00
( I32 # i ) <- c_arc4random
return ( I # ( word2Int # ( ( int2Word # i ` and # ` int2Word # 0xffff # )
` remWord # ` int2Word # 52 # ) ) )
2005-04-24 08:51:33 +00:00
2005-04-25 03:48:00 +00:00
foreign import ccall unsafe " stdlib.h arc4random " c_arc4random :: IO Int32
2005-04-24 08:51:33 +00:00
# endif