Files.hsc

{-# OPTIONS_GHC -cpp #-}
module System.Posix.Files where

import Foreign.Marshal.Alloc ( allocaBytes )
import Foreign.C.Error ( throwErrnoIfMinus1Retry, throwErrnoPathIf_ )
import Foreign.C.String ( withCString, withCWString, CWString )
import Foreign.C.Types ( CTime, CInt )
import Foreign.Ptr ( Ptr, nullPtr )

import System.Posix.Internals
          ( FDType, CStat, c_fstat, lstat, 
            sizeof_stat, statGetType, 
            st_mode, st_size, st_mtime,
            s_isreg, s_isdir, s_isfifo, c_stat )
import System.Posix.Types ( Fd(..), CMode, EpochTime, FileMode )

import Data.Bits ( (.|.) )

#if mingw32_HOST_OS
import Data.Int ( Int64 )
#else
import System.Posix.Types ( FileOffset )
#endif

##if mingw32_HOST_OS
type FileOffset = Int64
##endif

data FileStatus = FileStatus {
    fst_type :: FDType,
    fst_mode :: CMode,
    fst_mtime :: CTime,
    fst_size :: FileOffset
 }

getFdStatus :: Fd -> IO FileStatus
getFdStatus (Fd fd) = do
  do_stat (c_fstat fd)

do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus
do_stat stat_func = do
  allocaBytes sizeof_stat $ \p -> do
    throwErrnoIfMinus1Retry "do_stat" $
      stat_func p
    tp <- statGetType p
    mode <- st_mode p
    mtime <- st_mtime p
    size <- st_size p
    return (FileStatus tp mode mtime (fromIntegral size))

isNamedPipe :: FileStatus -> Bool
isNamedPipe = s_isfifo . fst_mode

isDirectory :: FileStatus -> Bool
isDirectory = s_isdir . fst_mode

isRegularFile :: FileStatus -> Bool
isRegularFile = s_isreg . fst_mode

isSymbolicLink :: FileStatus -> Bool
isSymbolicLink = const False

linkCount :: FileStatus -> Int
linkCount _ = 1

modificationTime :: FileStatus -> EpochTime
modificationTime = fst_mtime

fileSize :: FileStatus -> FileOffset
fileSize = fst_size

fileMode :: a -> ()
fileMode _ = ()

setFileMode :: FilePath -> () -> IO ()
setFileMode _ _ = return ()

#include <sys/stat.h>
stdFileMode :: FileMode
stdFileMode = (#const S_IRUSR) .|. (#const S_IWUSR)

getFileStatus :: FilePath -> IO FileStatus
getFileStatus fp =
  do_stat (\p -> (fp `withCString` (`c_stat` p)))

-- lstat is broken on win32 with at least GHC 6.10.3
getSymbolicLinkStatus :: FilePath -> IO FileStatus
##if mingw32_HOST_OS
getSymbolicLinkStatus = getFileStatus
##else
getSymbolicLinkStatus fp =
  do_stat (\p -> (fp `withCString` (`lstat` p)))
##endif

#define _WIN32_WINNT 0x0500
foreign import stdcall "winbase.h CreateHardLinkW" c_CreateHardLink :: CWString -> CWString -> Ptr a -> IO CInt

createLink :: FilePath -> FilePath -> IO ()
createLink old new = withCWString old $ \c_old -> withCWString new $ \c_new ->
	throwErrnoPathIf_ (==0) "createLink" new $
		c_CreateHardLink c_new c_old nullPtr