ghc/lib/haskell-1.3/LibPosixFiles.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 \section[LibPosixFiles]{Haskell 1.3 POSIX File and Directory Operations}
   5
   6 \begin{code}
   7 module LibPosixFiles (
   8     DeviceID(..),
   9     DirStream(..),
  10     FileID(..),
  11     FileMode(..),
  12     FileStatus(..),
  13     OpenMode(..),
  14     PathVar(..),
  15
  16     accessModes,
  17     accessTime,
  18     changeWorkingDirectory,     -- Too much like LibDirectory thing?
  19     closeDirStream,
  20     createDirectory,    -- Too much like LibDirectory thing?
  21     createFile,
  22     createLink,
  23     createNamedPipe,
  24     deviceID,
  25     fileGroup,
  26     fileID,
  27     fileMode,
  28     fileOwner,
  29     fileSize,
  30     getChannelStatus,
  31     getChannelVar,
  32     getFileStatus,
  33     getPathVar,
  34     getWorkingDirectory,        -- Too much like LibDirectory thing?
  35     groupExecuteMode,
  36     groupModes,
  37     groupReadMode,
  38     groupWriteMode,
  39     intersectFileModes,
  40     isBlockDevice,
  41     isCharacterDevice,
  42     isDirectory,
  43     isNamedPipe,
  44     isRegularFile,
  45     linkCount,
  46     modificationTime,
  47     nullFileMode,
  48     openDirStream,
  49     openChannel,
  50     otherExecuteMode,
  51     otherModes,
  52     otherReadMode,
  53     otherWriteMode,
  54     ownerExecuteMode,
  55     ownerModes,
  56     ownerReadMode,
  57     ownerWriteMode,
  58     queryAccess,
  59     queryFile,
  60     readDirStream,
  61     removeDirectory,    -- Too much like LibDirectory thing
  62     removeLink,
  63     rename,
  64     rewindDirStream,
  65     setFileCreationMask,
  66     setFileTimes,
  67     setGroupIDMode,
  68     setOwnerAndGroup,
  69     setFileMode,
  70     setUserIDMode,
  71     stdError,
  72     stdFileMode,
  73     stdInput,
  74     stdOutput,
  75     statusChangeTime,
  76     touchFile,
  77     unionFileModes
  78     ) where
  79
  80 import PreludeGlaST
  81 import PS
  82
  83 import LibPosixErr
  84 import LibPosixUtil
  85
  86 import LibDirectory     ( removeDirectory,  -- re-use its code
  87                           getCurrentDirectory,
  88                           setCurrentDirectory
  89                         )
  90
  91 type DirStream = _Addr
  92
  93 openDirStream :: FilePath -> IO DirStream
  94 openDirStream name =
  95     _packBytesForCST name                           `thenStrictlyST` \ dir ->
  96     _ccall_ opendir dir                             `thenPrimIO` \ dirp ->
  97     if dirp /= ``NULL'' then
  98         return dirp
  99     else
 100         syserr "openDirStream"
 101
 102 readDirStream :: DirStream -> IO String
 103 readDirStream dirp =
 104     setErrorCode noError                            >>
 105     _ccall_ readdir dirp                            `thenPrimIO` \ dirent ->
 106     if dirent /= (``NULL''::_Addr) then
 107         _casm_ ``%r = ((struct dirent *)%0)->d_name;'' dirent
 108                                                     `thenPrimIO` \ str ->
 109         strcpy str                                  `thenPrimIO` \ name ->
 110         return name
 111     else
 112         getErrorCode                                >>= \ errno ->
 113         if errno == noError then
 114             failWith EOF
 115         else
 116             syserr "readDirStream"
 117
 118 rewindDirStream :: DirStream -> IO ()
 119 rewindDirStream dirp =
 120     _ccall_ rewinddir dirp                          `thenPrimIO` \ () ->
 121     return ()
 122
 123 closeDirStream :: DirStream -> IO ()
 124 closeDirStream dirp =
 125     _ccall_ closedir dirp                           `thenPrimIO` \ rc ->
 126     if rc == 0 then
 127         return ()
 128     else
 129         syserr "closeDirStream"
 130
 131 getWorkingDirectory :: IO FilePath
 132 getWorkingDirectory = getCurrentDirectory{-LibDirectory-}
 133 {- OLD:
 134     _ccall_ getCurrentDirectory                     `thenPrimIO` \ str ->
 135     if str /= ``NULL'' then
 136         strcpy str                                  `thenPrimIO` \ pwd ->
 137         _ccall_ free str                            `thenPrimIO` \ () ->
 138         return pwd
 139     else
 140         syserr "getWorkingDirectory"
 141 -}
 142
 143 changeWorkingDirectory :: FilePath -> IO ()
 144 changeWorkingDirectory name = setCurrentDirectory{-LibDirectory-} name
 145 {- OLD:
 146     _packBytesForCST name                           `thenStrictlyST` \ dir ->
 147     _ccall_ chdir dir                               `thenPrimIO` \ rc ->
 148     if rc == 0 then
 149         return ()
 150     else
 151         syserr "changeWorkingDirectory"
 152 -}
 153
 154 type FileMode = _Word
 155
 156 nullFileMode :: FileMode
 157 nullFileMode = ``0''
 158
 159 ownerReadMode :: FileMode
 160 ownerReadMode = ``S_IRUSR''
 161
 162 ownerWriteMode :: FileMode
 163 ownerWriteMode = ``S_IWUSR''
 164
 165 ownerExecuteMode :: FileMode
 166 ownerExecuteMode = ``S_IXUSR''
 167
 168 groupReadMode :: FileMode
 169 groupReadMode = ``S_IRGRP''
 170
 171 groupWriteMode :: FileMode
 172 groupWriteMode = ``S_IWGRP''
 173
 174 groupExecuteMode :: FileMode
 175 groupExecuteMode = ``S_IXGRP''
 176
 177 otherReadMode :: FileMode
 178 otherReadMode = ``S_IROTH''
 179
 180 otherWriteMode :: FileMode
 181 otherWriteMode = ``S_IWOTH''
 182
 183 otherExecuteMode :: FileMode
 184 otherExecuteMode = ``S_IXOTH''
 185
 186 setUserIDMode :: FileMode
 187 setUserIDMode = ``S_ISUID''
 188
 189 setGroupIDMode :: FileMode
 190 setGroupIDMode = ``S_ISGID''
 191
 192 stdFileMode :: FileMode
 193 stdFileMode = ``(S_IRUSR|S_IWUSR|S_IRGRP|S_IWGRP|S_IROTH|S_IWOTH)''
 194
 195 ownerModes :: FileMode
 196 ownerModes = ``S_IRWXU''
 197
 198 groupModes :: FileMode
 199 groupModes = ``S_IRWXG''
 200
 201 otherModes :: FileMode
 202 otherModes = ``S_IRWXO''
 203
 204 accessModes :: FileMode
 205 accessModes = ``(S_IRWXU|S_IRWXG|S_IRWXO)''
 206
 207 unionFileModes :: FileMode -> FileMode -> FileMode
 208 unionFileModes (W# m1#) (W# m2#) = W# (m1# `or#` m2#)
 209
 210 intersectFileModes :: FileMode -> FileMode -> FileMode
 211 intersectFileModes (W# m1#) (W# m2#) = W# (m1# `and#` m2#)
 212
 213 stdInput :: Channel
 214 stdInput = 0
 215
 216 stdOutput :: Channel
 217 stdOutput = 1
 218
 219 stdError :: Channel
 220 stdError = 2
 221
 222 data OpenMode = ReadOnly
 223               | WriteOnly
 224               | ReadWrite
 225
 226 openChannel :: FilePath
 227                    -> OpenMode
 228                    -> Maybe FileMode    -- Just x => O_CREAT, Nothing => must exist
 229                    -> Bool              -- O_APPEND
 230                    -> Bool              -- O_EXCL
 231                    -> Bool              -- O_NOCTTY
 232                    -> Bool              -- O_NONBLOCK
 233                    -> Bool              -- O_TRUNC
 234                    -> IO Channel
 235 openChannel name how maybe_mode append excl noctty nonblock trunc =
 236     _packBytesForCST name                           `thenStrictlyST` \ file ->
 237     _ccall_ open file flags mode                    `thenPrimIO` \ fd ->
 238     if fd /= -1 then
 239         return fd
 240     else
 241         syserr "openChannel"
 242   where
 243     mode, creat :: FileMode
 244     mode = case maybe_mode of { Nothing -> ``0'' ; Just x -> x }
 245
 246     creat = case maybe_mode of { Nothing -> ``0'' ; Just _ -> ``O_CREAT'' }
 247     creat# = case creat of { W# x -> x }
 248
 249     flags = W# (creat# `or#` append# `or#` excl# `or#`
 250                 noctty# `or#` nonblock# `or#` trunc#)
 251     append#   = case (if append   then ``O_APPEND''   else ``0'') of { W# x -> x }
 252     excl#     = case (if excl     then ``O_EXCL''     else ``0'') of { W# x -> x }
 253     noctty#   = case (if noctty   then ``O_NOCTTY''   else ``0'') of { W# x -> x }
 254     nonblock# = case (if nonblock then ``O_NONBLOCK'' else ``0'') of { W# x -> x }
 255     trunc#    = case (if trunc    then ``O_TRUNC''    else ``0'') of { W# x -> x }
 256
 257 createFile :: FilePath -> FileMode -> IO Channel
 258 createFile name mode =
 259     _packBytesForCST name                           `thenStrictlyST` \ file ->
 260     _ccall_ creat file mode                         `thenPrimIO` \ fd ->
 261     if fd /= -1 then
 262         return fd
 263     else
 264         syserr "createFile"
 265
 266 setFileCreationMask :: FileMode -> IO FileMode
 267 setFileCreationMask mask =
 268     _ccall_ umask mask                              `thenPrimIO` \ omask ->
 269     return omask
 270
 271 createLink :: FilePath -> FilePath -> IO ()
 272 createLink name1 name2 =
 273     _packBytesForCST name1                          `thenStrictlyST` \ path1 ->
 274     _packBytesForCST name2                          `thenStrictlyST` \ path2 ->
 275     _ccall_ link path1 path2                        `thenPrimIO` \ rc ->
 276     if rc == 0 then
 277         return ()
 278     else
 279         syserr "createLink"
 280
 281 createDirectory :: FilePath -> FileMode -> IO ()
 282 createDirectory name mode = -- NB: diff signature from LibDirectory one!
 283     _packBytesForCST name                           `thenStrictlyST` \ dir ->
 284     _ccall_ mkdir dir mode                          `thenPrimIO` \ rc ->
 285     if rc == 0 then
 286         return ()
 287     else
 288         syserr "createDirectory"
 289
 290 createNamedPipe :: FilePath -> FileMode -> IO ()
 291 createNamedPipe name mode =
 292     _packBytesForCST name                           `thenStrictlyST` \ pipe ->
 293     _ccall_ mkfifo pipe mode                        `thenPrimIO` \ rc ->
 294     if rc == 0 then
 295         return ()
 296     else
 297         syserr "createNamedPipe"
 298
 299 removeLink :: FilePath -> IO ()
 300 removeLink name =
 301     _packBytesForCST name                           `thenStrictlyST` \ path ->
 302     _ccall_ unlink path                             `thenPrimIO` \ rc ->
 303     if rc == 0 then
 304         return ()
 305     else
 306         syserr "removeLink"
 307
 308 {- USE LibDirectory ONE:
 309 removeDirectory :: FilePath -> IO ()
 310 removeDirectory name =
 311     _packBytesForCST name                           `thenStrictlyST` \ dir ->
 312     _ccall_ rmdir dir                               `thenPrimIO` \ rc ->
 313     if rc == 0 then
 314         return ()
 315     else
 316         syserr "removeDirectory"
 317 -}
 318
 319 rename :: FilePath -> FilePath -> IO ()
 320 rename name1 name2 =
 321     _packBytesForCST name1                          `thenStrictlyST` \ path1 ->
 322     _packBytesForCST name2                          `thenStrictlyST` \ path2 ->
 323     _ccall_ rename path1 path2                      `thenPrimIO` \ rc ->
 324     if rc == 0 then
 325         return ()
 326     else
 327         syserr "rename"
 328
 329 type FileStatus = _ByteArray ()
 330 type FileID = Int
 331 type DeviceID = Int
 332
 333 fileMode :: FileStatus -> FileMode
 334 fileMode stat = unsafePerformPrimIO (
 335     _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat
 336                                                     `thenStrictlyST` \ mode ->
 337     returnPrimIO mode)
 338
 339 fileID :: FileStatus -> FileID
 340 fileID stat = unsafePerformPrimIO (
 341     _casm_ ``%r = ((struct stat *)%0)->st_ino;'' stat
 342                                                     `thenStrictlyST` \ ino ->
 343     returnPrimIO ino)
 344
 345 deviceID :: FileStatus -> DeviceID
 346 deviceID stat = unsafePerformPrimIO (
 347     _casm_ ``%r = ((struct stat *)%0)->st_dev;'' stat
 348                                                     `thenStrictlyST` \ dev ->
 349     returnPrimIO dev)
 350
 351 linkCount :: FileStatus -> LinkCount
 352 linkCount stat = unsafePerformPrimIO (
 353     _casm_ ``%r = ((struct stat *)%0)->st_nlink;'' stat
 354                                                     `thenStrictlyST` \ nlink ->
 355     returnPrimIO nlink)
 356
 357 fileOwner :: FileStatus -> UserID
 358 fileOwner stat = unsafePerformPrimIO (
 359     _casm_ ``%r = ((struct stat *)%0)->st_uid;'' stat
 360                                                     `thenStrictlyST` \ uid ->
 361     returnPrimIO uid)
 362
 363 fileGroup :: FileStatus -> GroupID
 364 fileGroup stat = unsafePerformPrimIO (
 365     _casm_ ``%r = ((struct stat *)%0)->st_gid;'' stat
 366                                                     `thenStrictlyST` \ gid ->
 367     returnPrimIO gid)
 368
 369 fileSize :: FileStatus -> FileOffset
 370 fileSize stat = unsafePerformPrimIO (
 371     _casm_ ``%r = ((struct stat *)%0)->st_size;'' stat
 372                                                     `thenStrictlyST` \ size ->
 373     returnPrimIO size)
 374
 375 accessTime :: FileStatus -> EpochTime
 376 accessTime stat = unsafePerformPrimIO (
 377     _casm_ ``%r = ((struct stat *)%0)->st_atime;'' stat
 378                                                     `thenStrictlyST` \ atime ->
 379     returnPrimIO atime)
 380
 381 modificationTime :: FileStatus -> EpochTime
 382 modificationTime stat = unsafePerformPrimIO (
 383     _casm_ ``%r = ((struct stat *)%0)->st_mtime;'' stat
 384                                                     `thenStrictlyST` \ mtime ->
 385     returnPrimIO mtime)
 386
 387 statusChangeTime :: FileStatus -> EpochTime
 388 statusChangeTime stat = unsafePerformPrimIO (
 389     _casm_ ``%r = ((struct stat *)%0)->st_ctime;'' stat
 390                                                     `thenStrictlyST` \ ctime ->
 391     returnPrimIO ctime)
 392
 393 isDirectory :: FileStatus -> Bool
 394 isDirectory stat = unsafePerformPrimIO (
 395     _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat
 396                                                     `thenStrictlyST` \ rc ->
 397     returnPrimIO (rc /= 0))
 398
 399 isCharacterDevice :: FileStatus -> Bool
 400 isCharacterDevice stat = unsafePerformPrimIO (
 401     _casm_ ``%r = S_ISCHR(((struct stat *)%0)->st_mode);'' stat
 402                                                     `thenStrictlyST` \ rc ->
 403     returnPrimIO (rc /= 0))
 404
 405 isBlockDevice :: FileStatus -> Bool
 406 isBlockDevice stat = unsafePerformPrimIO (
 407     _casm_ ``%r = S_ISBLK(((struct stat *)%0)->st_mode);'' stat
 408                                                     `thenStrictlyST` \ rc ->
 409     returnPrimIO (rc /= 0))
 410
 411 isRegularFile :: FileStatus -> Bool
 412 isRegularFile stat = unsafePerformPrimIO (
 413     _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat
 414                                                     `thenStrictlyST` \ rc ->
 415     returnPrimIO (rc /= 0))
 416
 417 isNamedPipe :: FileStatus -> Bool
 418 isNamedPipe stat = unsafePerformPrimIO (
 419     _casm_ ``%r = S_ISFIFO(((struct stat *)%0)->st_mode);'' stat
 420                                                     `thenStrictlyST` \ rc ->
 421     returnPrimIO (rc /= 0))
 422
 423 getFileStatus :: FilePath -> IO FileStatus
 424 getFileStatus name =
 425     _packBytesForCST name                           `thenStrictlyST` \ path ->
 426     allocChars ``sizeof(struct stat)''              `thenStrictlyST` \ bytes ->
 427     _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes
 428                                                     `thenPrimIO` \ rc ->
 429     if rc == 0 then
 430         freeze bytes                                `thenStrictlyST` \ stat ->
 431         return stat
 432     else
 433         syserr "getFileStatus"
 434
 435 getChannelStatus :: Channel -> IO FileStatus
 436 getChannelStatus fd =
 437     allocChars ``sizeof(struct stat)''              `thenStrictlyST` \ bytes ->
 438     _casm_ ``%r = fstat(%0,(struct stat *)%1);'' fd bytes
 439                                                     `thenPrimIO` \ rc ->
 440     if rc == 0 then
 441         freeze bytes                                `thenStrictlyST` \ stat ->
 442         return stat
 443     else
 444         syserr "getChannelStatus"
 445
 446 queryAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
 447 queryAccess name read write exec =
 448     _packBytesForCST name                           `thenStrictlyST` \ path ->
 449     _ccall_ access path flags                       `thenPrimIO` \ rc ->
 450     return (rc == 0)
 451   where
 452     flags = I# (word2Int# (read# `or#` write# `or#` exec#))
 453     read#  = case (if read  then ``R_OK'' else ``0'') of { W# x -> x }
 454     write# = case (if write then ``W_OK'' else ``0'') of { W# x -> x }
 455     exec#  = case (if exec  then ``X_OK'' else ``0'') of { W# x -> x }
 456
 457 queryFile :: FilePath -> IO Bool
 458 queryFile name =
 459     _packBytesForCST name                           `thenStrictlyST` \ path ->
 460     _ccall_ access path (``F_OK''::Int)             `thenPrimIO` \ rc ->
 461     return (rc == 0)
 462
 463 setFileMode :: FilePath -> FileMode -> IO ()
 464 setFileMode name mode =
 465     _packBytesForCST name                           `thenStrictlyST` \ path ->
 466     _ccall_ chmod path mode                         `thenPrimIO` \ rc ->
 467     if rc == 0 then
 468         return ()
 469     else
 470         syserr "setFileMode"
 471
 472 setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
 473 setOwnerAndGroup name uid gid =
 474     _packBytesForCST name                           `thenStrictlyST` \ path ->
 475     _ccall_ chown path uid gid                      `thenPrimIO` \ rc ->
 476     if rc == 0 then
 477         return ()
 478     else
 479         syserr "setOwnerAndGroup"
 480
 481 setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
 482 setFileTimes name atime mtime =
 483     _packBytesForCST name                           `thenStrictlyST` \ path ->
 484     _casm_ ``do {struct utimbuf ub; ub.actime = (time_t) %0; ub.modtime = (time_t) %1;
 485              %r = utime(%2, &ub);} while(0);'' atime mtime path
 486                                                     `thenPrimIO` \ rc ->
 487     if rc == 0 then
 488         return ()
 489     else
 490         syserr "setFileTimes"
 491
 492 touchFile :: FilePath -> IO ()
 493 touchFile name =
 494     _packBytesForCST name                           `thenStrictlyST` \ path ->
 495     _ccall_ utime path (``NULL''::_Addr)            `thenPrimIO` \ rc ->
 496     if rc == 0 then
 497         return ()
 498     else
 499         syserr "touchFile"
 500
 501 data PathVar = LinkLimit
 502              | InputLineLimit
 503              | InputQueueLimit
 504              | FileNameLimit
 505              | PathNameLimit
 506              | PipeBufferLimit
 507              | SetOwnerAndGroupIsRestricted
 508              | FileNamesAreNotTruncated
 509
 510 getPathVar :: PathVar -> FilePath -> IO Limit
 511 getPathVar v name =
 512     case v of
 513       LinkLimit -> pathconf ``_PC_LINK_MAX''
 514       InputLineLimit -> pathconf ``_PC_MAX_CANON''
 515       InputQueueLimit -> pathconf ``_PC_MAX_INPUT''
 516       FileNameLimit -> pathconf ``_PC_NAME_MAX''
 517       PathNameLimit -> pathconf ``_PC_PATH_MAX''
 518       PipeBufferLimit -> pathconf ``_PC_PIPE_BUF''
 519       SetOwnerAndGroupIsRestricted -> pathconf ``_PC_CHOWN_RESTRICTED''
 520       FileNamesAreNotTruncated -> pathconf ``_PC_NO_TRUNC''
 521   where
 522     pathconf :: Int -> IO Limit
 523     pathconf n =
 524         _packBytesForCST name                       `thenStrictlyST` \ path ->
 525         _ccall_ pathconf path n                     `thenPrimIO` \ rc ->
 526         if rc /= -1 then
 527             return rc
 528         else
 529             getErrorCode                            >>= \ errno ->
 530             if errno == invalidArgument then
 531                 failWith (NoSuchThing "no such path limit or option")
 532         else
 533             syserr "getPathVar"
 534
 535 getChannelVar :: PathVar -> Channel -> IO Limit
 536 getChannelVar v fd =
 537     case v of
 538       LinkLimit -> fpathconf ``_PC_LINK_MAX''
 539       InputLineLimit -> fpathconf ``_PC_MAX_CANON''
 540       InputQueueLimit -> fpathconf ``_PC_MAX_INPUT''
 541       FileNameLimit -> fpathconf ``_PC_NAME_MAX''
 542       PathNameLimit -> fpathconf ``_PC_PATH_MAX''
 543       PipeBufferLimit -> fpathconf ``_PC_PIPE_BUF''
 544       SetOwnerAndGroupIsRestricted -> fpathconf ``_PC_CHOWN_RESTRICTED''
 545       FileNamesAreNotTruncated -> fpathconf ``_PC_NO_TRUNC''
 546   where
 547     fpathconf :: Int -> IO Limit
 548     fpathconf n =
 549         _ccall_ fpathconf fd n                      `thenPrimIO` \ rc ->
 550         if rc /= -1 then
 551             return rc
 552         else
 553             getErrorCode                            >>= \ errno ->
 554             if errno == invalidArgument then
 555                 failWith (NoSuchThing "no such path limit or option")
 556             else
 557                 syserr "getPathVar"
 558
 559 \end{code}