Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 461 lines (375 sloc) 13.941 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461
{-# LANGUAGE CPP #-}

{-|
This module makes the operations exported by @System.Posix.Files@
available on all platforms. On POSIX systems it re-exports operations from
@System.Posix.Files@. On other platforms it emulates the operations as far
as possible.

/NOTE: the portable implementations are not well tested, in some cases
functions are only stubs./
-}
module System.PosixCompat.Files (
    -- * File modes
    -- FileMode exported by System.Posix.Types
      unionFileModes
    , intersectFileModes
    , nullFileMode
    , ownerReadMode
    , ownerWriteMode
    , ownerExecuteMode
    , ownerModes
    , groupReadMode
    , groupWriteMode
    , groupExecuteMode
    , groupModes
    , otherReadMode
    , otherWriteMode
    , otherExecuteMode
    , otherModes
    , setUserIDMode
    , setGroupIDMode
    , stdFileMode
    , accessModes

    -- ** Setting file modes
    , setFileMode
    , setFdMode
    , setFileCreationMask

    -- ** Checking file existence and permissions
    , fileAccess
    , fileExist

    -- * File status
    , FileStatus
    -- ** Obtaining file status
    , getFileStatus
    , getFdStatus
    , getSymbolicLinkStatus
    -- ** Querying file status
    , deviceID
    , fileID
    , fileMode
    , linkCount
    , fileOwner
    , fileGroup
    , specialDeviceID
    , fileSize
    , accessTime
    , modificationTime
    , statusChangeTime
    , isBlockDevice
    , isCharacterDevice
    , isNamedPipe
    , isRegularFile
    , isDirectory
    , isSymbolicLink
    , isSocket

    -- * Creation
    , createNamedPipe
    , createDevice

    -- * Hard links
    , createLink
    , removeLink

    -- * Symbolic links
    , createSymbolicLink
    , readSymbolicLink

    -- * Renaming files
    , rename

    -- * Changing file ownership
    , setOwnerAndGroup
    , setFdOwnerAndGroup
    , setSymbolicLinkOwnerAndGroup

    -- * Changing file timestamps
    , setFileTimes
    , touchFile

    -- * Setting file sizes
    , setFileSize
    , setFdSize

    -- * Find system-specific limits for a file
    , PathVar(..)
    , getPathVar
    , getFdPathVar
    ) where

#ifndef mingw32_HOST_OS

#include "HsUnixCompat.h"

import System.Posix.Files

#if NEED_setSymbolicLinkOwnerAndGroup
import System.PosixCompat.Types

setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
setSymbolicLinkOwnerAndGroup _ _ _ = return ()
#endif

#else /* Portable implementation */

import Control.Exception (bracket)
import Control.Monad (liftM, liftM2)
import Data.Bits ((.|.), (.&.))
import Prelude hiding (read)
import System.Directory
import System.IO (IOMode(..), openFile, hFileSize, hSetFileSize, hClose)
import System.IO.Error
import System.PosixCompat.Types
import System.Win32.File hiding (getFileType)

import System.PosixCompat.Internal.Time (
      getClockTime, clockTimeToEpochTime
    , modificationTimeToEpochTime
    )

#ifdef __GLASGOW_HASKELL__
import GHC.IO.Handle.FD (fdToHandle)
#endif


unsupported :: String -> IO a
unsupported f = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
  where
    x = "System.PosixCompat.Files." ++ f ++ ": not supported"

-- -----------------------------------------------------------------------------
-- POSIX file modes

nullFileMode :: FileMode
nullFileMode = 0o000000

ownerReadMode :: FileMode
ownerWriteMode :: FileMode
ownerExecuteMode :: FileMode
groupReadMode :: FileMode
groupWriteMode :: FileMode
groupExecuteMode :: FileMode
otherReadMode :: FileMode
otherWriteMode :: FileMode
otherExecuteMode :: FileMode
setUserIDMode :: FileMode
setGroupIDMode :: FileMode

ownerReadMode = 0o000400
ownerWriteMode = 0o000200
ownerExecuteMode = 0o000100
groupReadMode = 0o000040
groupWriteMode = 0o000020
groupExecuteMode = 0o000010
otherReadMode = 0o000004
otherWriteMode = 0o000002
otherExecuteMode = 0o000001
setUserIDMode = 0o004000
setGroupIDMode = 0o002000

stdFileMode :: FileMode
ownerModes :: FileMode
groupModes :: FileMode
otherModes :: FileMode
accessModes :: FileMode

stdFileMode = ownerReadMode .|. ownerWriteMode .|.
              groupReadMode .|. groupWriteMode .|.
              otherReadMode .|. otherWriteMode
ownerModes = ownerReadMode .|. ownerWriteMode .|. ownerExecuteMode
groupModes = groupReadMode .|. groupWriteMode .|. groupExecuteMode
otherModes = otherReadMode .|. otherWriteMode .|. otherExecuteMode
accessModes = ownerModes .|. groupModes .|. otherModes

unionFileModes :: FileMode -> FileMode -> FileMode
unionFileModes m1 m2 = m1 .|. m2

intersectFileModes :: FileMode -> FileMode -> FileMode
intersectFileModes m1 m2 = m1 .&. m2

fileTypeModes :: FileMode
fileTypeModes = 0o0170000

blockSpecialMode :: FileMode
characterSpecialMode :: FileMode
namedPipeMode :: FileMode
regularFileMode :: FileMode
directoryMode :: FileMode
symbolicLinkMode :: FileMode
socketMode :: FileMode

blockSpecialMode = 0o0060000
characterSpecialMode = 0o0020000
namedPipeMode = 0o0010000
regularFileMode = 0o0100000
directoryMode = 0o0040000
symbolicLinkMode = 0o0120000
socketMode = 0o0140000


setFileMode :: FilePath -> FileMode -> IO ()
setFileMode name m = setPermissions name $ modeToPerms m


setFdMode :: Fd -> FileMode -> IO ()
setFdMode _ _ = unsupported "setFdMode"

-- | The portable implementation does nothing and returns 'nullFileMode'.
setFileCreationMask :: FileMode -> IO FileMode
setFileCreationMask _ = return nullFileMode

modeToPerms :: FileMode -> Permissions

#ifdef DIRECTORY_1_0
modeToPerms m = Permissions
    { readable = m .&. ownerReadMode /= 0
    , writable = m .&. ownerWriteMode /= 0
    , executable = m .&. ownerExecuteMode /= 0
    , searchable = m .&. ownerExecuteMode /= 0 }
#else
modeToPerms m =
    setOwnerReadable (m .&. ownerReadMode /= 0) $
    setOwnerWritable (m .&. ownerWriteMode /= 0) $
    setOwnerExecutable (m .&. ownerExecuteMode /= 0) $
    setOwnerSearchable (m .&. ownerExecuteMode /= 0) $
    emptyPermissions
#endif

-- -----------------------------------------------------------------------------
-- access()

fileAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
fileAccess name read write exec =
    do perm <- getPermissions name
       return $ (not read || readable perm)
             && (not write || writable perm)
             && (not exec || executable perm || searchable perm)

fileExist :: FilePath -> IO Bool
fileExist name = liftM2 (||) (doesFileExist name) (doesDirectoryExist name)

-- -----------------------------------------------------------------------------
-- stat() support

data FileStatus = FileStatus
    { deviceID :: DeviceID
    , fileID :: FileID
    , fileMode :: FileMode
    , linkCount :: LinkCount
    , fileOwner :: UserID
    , fileGroup :: GroupID
    , specialDeviceID :: DeviceID
    , fileSize :: FileOffset
    , accessTime :: EpochTime
    , modificationTime :: EpochTime
    , statusChangeTime :: EpochTime
    }

isBlockDevice :: FileStatus -> Bool
isBlockDevice stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == blockSpecialMode

isCharacterDevice :: FileStatus -> Bool
isCharacterDevice stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == characterSpecialMode

isNamedPipe :: FileStatus -> Bool
isNamedPipe stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == namedPipeMode

isRegularFile :: FileStatus -> Bool
isRegularFile stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == regularFileMode

isDirectory :: FileStatus -> Bool
isDirectory stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == directoryMode

isSymbolicLink :: FileStatus -> Bool
isSymbolicLink stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == symbolicLinkMode

isSocket :: FileStatus -> Bool
isSocket stat =
    (fileMode stat `intersectFileModes` fileTypeModes) == socketMode

getFileStatus :: FilePath -> IO FileStatus
getFileStatus path = do
    perm <- liftM permsToMode (getPermissions path)
    typ <- getFileType path
    size <- if typ == regularFileMode then getFileSize path else return 0
    mtime <- liftM modificationTimeToEpochTime (getModificationTime path)
    info <- bracket openPath closeHandle getFileInformationByHandle
    return $ FileStatus
             { deviceID = fromIntegral (bhfiVolumeSerialNumber info)
             , fileID = fromIntegral (bhfiFileIndex info)
             , fileMode = typ .|. perm
             , linkCount = fromIntegral (bhfiNumberOfLinks info)
             , fileOwner = 0
             , fileGroup = 0
             , specialDeviceID = 0
             , fileSize = size
             , accessTime = mtime
             , modificationTime = mtime
             , statusChangeTime = mtime }
  where
    openPath = createFile path
                 gENERIC_READ
                 (fILE_SHARE_READ .|. fILE_SHARE_WRITE .|. fILE_SHARE_DELETE)
                 Nothing
                 oPEN_EXISTING
                 (sECURITY_ANONYMOUS .|. fILE_FLAG_BACKUP_SEMANTICS)
                 Nothing

permsToMode :: Permissions -> FileMode
permsToMode perms = r .|. w .|. x
  where
    r = f (readable perms) (ownerReadMode .|. groupReadMode .|. otherReadMode)
    w = f (writable perms) (ownerWriteMode .|. groupWriteMode .|. otherWriteMode)
    x = f (executable perms || searchable perms)
          (ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)
    f True m = m
    f False _ = nullFileMode

getFileType :: FilePath -> IO FileMode
getFileType path =
    do f <- doesFileExist path
       if f then return regularFileMode
            else do d <- doesDirectoryExist path
                    if d then return directoryMode
                         else unsupported "Unknown file type."

getFileSize :: FilePath -> IO FileOffset
getFileSize path =
    bracket (openFile path ReadMode) hClose (liftM fromIntegral . hFileSize)

getFdStatus :: Fd -> IO FileStatus
getFdStatus _ = unsupported "getFdStatus"

getSymbolicLinkStatus :: FilePath -> IO FileStatus
getSymbolicLinkStatus path = getFileStatus path

createNamedPipe :: FilePath -> FileMode -> IO ()
createNamedPipe _ _ = unsupported "createNamedPipe"

createDevice :: FilePath -> FileMode -> DeviceID -> IO ()
createDevice _ _ _ = unsupported "createDevice"

-- -----------------------------------------------------------------------------
-- Hard links

createLink :: FilePath -> FilePath -> IO ()
createLink _ _ = unsupported "createLink"

removeLink :: FilePath -> IO ()
removeLink _ = unsupported "removeLink"

-- -----------------------------------------------------------------------------
-- Symbolic Links

createSymbolicLink :: FilePath -> FilePath -> IO ()
createSymbolicLink _ _ = unsupported "createSymbolicLink"

readSymbolicLink :: FilePath -> IO FilePath
readSymbolicLink _ = unsupported "readSymbolicLink"

-- -----------------------------------------------------------------------------
-- Renaming files

rename :: FilePath -> FilePath -> IO ()
rename name1 name2 = renameFile name1 name2

-- -----------------------------------------------------------------------------
-- chown()

-- | The portable implementation does nothing.
setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup _ _ _ = return ()

-- | The portable implementation does nothing.
setFdOwnerAndGroup :: Fd -> UserID -> GroupID -> IO ()
setFdOwnerAndGroup _ _ _ = return ()

-- | The portable implementation does nothing.
setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
setSymbolicLinkOwnerAndGroup _ _ _ = return ()

-- -----------------------------------------------------------------------------
-- utime()

setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
setFileTimes _ _ _ = unsupported "setFileTimes"

touchFile :: FilePath -> IO ()
touchFile name =
    do t <- liftM clockTimeToEpochTime getClockTime
       setFileTimes name t t

-- -----------------------------------------------------------------------------
-- Setting file sizes

setFileSize :: FilePath -> FileOffset -> IO ()
setFileSize file off =
    bracket (openFile file WriteMode) (hClose)
            (\h -> hSetFileSize h (fromIntegral off))

setFdSize :: Fd -> FileOffset -> IO ()
#ifdef __GLASGOW_HASKELL__
setFdSize (Fd fd) off =
    do h <- fdToHandle (fromIntegral fd)
       hSetFileSize h (fromIntegral off)
#else
setFdSize fd off = unsupported "setFdSize"
#endif

-- -----------------------------------------------------------------------------
-- pathconf()/fpathconf() support

data PathVar
  = FileSizeBits -- _PC_FILESIZEBITS
  | LinkLimit -- _PC_LINK_MAX
  | InputLineLimit -- _PC_MAX_CANON
  | InputQueueLimit -- _PC_MAX_INPUT
  | FileNameLimit -- _PC_NAME_MAX
  | PathNameLimit -- _PC_PATH_MAX
  | PipeBufferLimit -- _PC_PIPE_BUF

  -- These are described as optional in POSIX:
                                  -- _PC_ALLOC_SIZE_MIN
                                  -- _PC_REC_INCR_XFER_SIZE
                                  -- _PC_REC_MAX_XFER_SIZE
                                  -- _PC_REC_MIN_XFER_SIZE
                                  -- _PC_REC_XFER_ALIGN
  | SymbolicLinkLimit -- _PC_SYMLINK_MAX
  | SetOwnerAndGroupIsRestricted -- _PC_CHOWN_RESTRICTED
  | FileNamesAreNotTruncated -- _PC_NO_TRUNC
  | VDisableChar -- _PC_VDISABLE
  | AsyncIOAvailable -- _PC_ASYNC_IO
  | PrioIOAvailable -- _PC_PRIO_IO
  | SyncIOAvailable -- _PC_SYNC_IO

getPathVar :: FilePath -> PathVar -> IO Limit
getPathVar _ _ = unsupported "getPathVar"

getFdPathVar :: Fd -> PathVar -> IO Limit
getFdPathVar _ _ = unsupported "getFdPathVar"

#endif
Something went wrong with that request. Please try again.