module LIO.TmpFile (
mkTmpFile
, mkTmpDir
, mkTmpDir'
, mkTmp, openFileExclusive
, tmpName, nextTmpName, serializele, unserializele
, hSync
)where
import LIO.Armor
import Prelude hiding (catch)
import Control.Exception (throwIO, catch)
import Data.Bits (shiftL, shiftR, (.|.))
import qualified Data.ByteString.Lazy as L
import Data.Word (Word8)
import Foreign.C.Error
import Foreign.C.Types
import System.Directory (createDirectory)
import System.FilePath ((</>))
import System.Posix.IO (OpenMode(..), OpenFileFlags(..)
, defaultFileFlags , openFd, fdToHandle)
import qualified System.IO as IO
import qualified System.IO.Error as IO
import System.Time (ClockTime(..), getClockTime)
import Data.Typeable
import GHC.IO.FD (FD(..))
import GHC.IO.Handle.Types (Handle__(..))
import GHC.IO.Handle.Internals (wantWritableHandle)
foreign import ccall "unistd.h fsync" c_fsync :: CInt -> IO CInt
serializele :: Int
-> Integer
-> [Word8]
serializele n i | n <= 0 && i <= 0 = []
serializele n i = (fromInteger i):serializele (n 1) (i `shiftR` 8)
unserializele :: [Word8] -> Integer
unserializele [] = 0
unserializele (c:s) = (fromIntegral c) .|. (unserializele s `shiftL` 8)
tmpName :: IO String
tmpName = do
(TOD sec psec) <- getClockTime
return $ armor32 $ L.pack $
serializele 3 (psec `shiftR` 16) ++ serializele 4 sec
nextTmpName :: String -> String
nextTmpName s =
let val = unserializele $ L.unpack $ dearmor32 s
in armor32 $ L.pack $ serializele 7 (1 + val)
openFileExclusive :: IO.IOMode -> FilePath -> IO IO.Handle
openFileExclusive m p = do
let dom = defaultFileFlags { exclusive = True }
(om, fm) = case m of
IO.WriteMode -> (WriteOnly, dom)
IO.AppendMode -> (WriteOnly, dom { append = True })
IO.ReadWriteMode -> (ReadWrite, dom)
IO.ReadMode ->
error "openFileExclusive: ReadMode is illegal"
fd <- openFd p om (Just $ toEnum 0o666) fm
fdToHandle fd
mkTmp :: (FilePath -> IO a)
-> FilePath
-> String
-> IO (a, FilePath)
mkTmp f dir suffix = tmpName >>= loop
where
ff n = case dir </> n of path -> do a <- f path; return (a, path)
loop name = ff (name ++ suffix) `catch` reloop name
reloop name e = if IO.isAlreadyExistsError e
then loop $ nextTmpName name
else throwIO e
mkTmpFile :: IO.IOMode
-> FilePath
-> String
-> IO (IO.Handle, FilePath)
mkTmpFile m d s = mkTmp (openFileExclusive m) d s
mkTmpDir :: FilePath
-> String
-> IO ((), FilePath)
mkTmpDir d s = mkTmp createDirectory d s
mkTmpDir' :: FilePath
-> String
-> IO FilePath
mkTmpDir' d s = fmap snd $ mkTmpDir d s
hSync :: IO.Handle -> IO ()
hSync h = do
IO.hFlush h
wantWritableHandle "hSync" h $ fsyncH
where
fsyncH Handle__ {haDevice = dev} = maybe (return ()) fsyncD $ cast dev
fsyncD FD {fdFD = fd} = throwErrnoPathIfMinus1_ "fsync" (show h)
(c_fsync fd)