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# `or#` how#)
 251     how#      = case (case how of { ReadOnly -> ``O_RDONLY'';WriteOnly -> ``O_WRONLY'';ReadWrite -> ``O_RDWR''}) of { W# x -> x }
 252     append#   = case (if append   then ``O_APPEND''   else ``0'') of { W# x -> x }
 253     excl#     = case (if excl     then ``O_EXCL''     else ``0'') of { W# x -> x }
 254     noctty#   = case (if noctty   then ``O_NOCTTY''   else ``0'') of { W# x -> x }
 255     nonblock# = case (if nonblock then ``O_NONBLOCK'' else ``0'') of { W# x -> x }
 256     trunc#    = case (if trunc    then ``O_TRUNC''    else ``0'') of { W# x -> x }
 257
 258 createFile :: FilePath -> FileMode -> IO Channel
 259 createFile name mode =
 260     _packBytesForCST name                           `thenStrictlyST` \ file ->
 261     _ccall_ creat file mode                         `thenPrimIO` \ fd ->
 262     if fd /= -1 then
 263         return fd
 264     else
 265         syserr "createFile"
 266
 267 setFileCreationMask :: FileMode -> IO FileMode
 268 setFileCreationMask mask =
 269     _ccall_ umask mask                              `thenPrimIO` \ omask ->
 270     return omask
 271
 272 createLink :: FilePath -> FilePath -> IO ()
 273 createLink name1 name2 =
 274     _packBytesForCST name1                          `thenStrictlyST` \ path1 ->
 275     _packBytesForCST name2                          `thenStrictlyST` \ path2 ->
 276     _ccall_ link path1 path2                        `thenPrimIO` \ rc ->
 277     if rc == 0 then
 278         return ()
 279     else
 280         syserr "createLink"
 281
 282 createDirectory :: FilePath -> FileMode -> IO ()
 283 createDirectory name mode = -- NB: diff signature from LibDirectory one!
 284     _packBytesForCST name                           `thenStrictlyST` \ dir ->
 285     _ccall_ mkdir dir mode                          `thenPrimIO` \ rc ->
 286     if rc == 0 then
 287         return ()
 288     else
 289         syserr "createDirectory"
 290
 291 createNamedPipe :: FilePath -> FileMode -> IO ()
 292 createNamedPipe name mode =
 293     _packBytesForCST name                           `thenStrictlyST` \ pipe ->
 294     _ccall_ mkfifo pipe mode                        `thenPrimIO` \ rc ->
 295     if rc == 0 then
 296         return ()
 297     else
 298         syserr "createNamedPipe"
 299
 300 removeLink :: FilePath -> IO ()
 301 removeLink name =
 302     _packBytesForCST name                           `thenStrictlyST` \ path ->
 303     _ccall_ unlink path                             `thenPrimIO` \ rc ->
 304     if rc == 0 then
 305         return ()
 306     else
 307         syserr "removeLink"
 308
 309 {- USE LibDirectory ONE:
 310 removeDirectory :: FilePath -> IO ()
 311 removeDirectory name =
 312     _packBytesForCST name                           `thenStrictlyST` \ dir ->
 313     _ccall_ rmdir dir                               `thenPrimIO` \ rc ->
 314     if rc == 0 then
 315         return ()
 316     else
 317         syserr "removeDirectory"
 318 -}
 319
 320 rename :: FilePath -> FilePath -> IO ()
 321 rename name1 name2 =
 322     _packBytesForCST name1                          `thenStrictlyST` \ path1 ->
 323     _packBytesForCST name2                          `thenStrictlyST` \ path2 ->
 324     _ccall_ rename path1 path2                      `thenPrimIO` \ rc ->
 325     if rc == 0 then
 326         return ()
 327     else
 328         syserr "rename"
 329
 330 type FileStatus = _ByteArray ()
 331 type FileID = Int
 332 type DeviceID = Int
 333
 334 fileMode :: FileStatus -> FileMode
 335 fileMode stat = unsafePerformPrimIO (
 336     _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat
 337                                                     `thenStrictlyST` \ mode ->
 338     returnPrimIO mode)
 339
 340 fileID :: FileStatus -> FileID
 341 fileID stat = unsafePerformPrimIO (
 342     _casm_ ``%r = ((struct stat *)%0)->st_ino;'' stat
 343                                                     `thenStrictlyST` \ ino ->
 344     returnPrimIO ino)
 345
 346 deviceID :: FileStatus -> DeviceID
 347 deviceID stat = unsafePerformPrimIO (
 348     _casm_ ``%r = ((struct stat *)%0)->st_dev;'' stat
 349                                                     `thenStrictlyST` \ dev ->
 350     returnPrimIO dev)
 351
 352 linkCount :: FileStatus -> LinkCount
 353 linkCount stat = unsafePerformPrimIO (
 354     _casm_ ``%r = ((struct stat *)%0)->st_nlink;'' stat
 355                                                     `thenStrictlyST` \ nlink ->
 356     returnPrimIO nlink)
 357
 358 fileOwner :: FileStatus -> UserID
 359 fileOwner stat = unsafePerformPrimIO (
 360     _casm_ ``%r = ((struct stat *)%0)->st_uid;'' stat
 361                                                     `thenStrictlyST` \ uid ->
 362     returnPrimIO uid)
 363
 364 fileGroup :: FileStatus -> GroupID
 365 fileGroup stat = unsafePerformPrimIO (
 366     _casm_ ``%r = ((struct stat *)%0)->st_gid;'' stat
 367                                                     `thenStrictlyST` \ gid ->
 368     returnPrimIO gid)
 369
 370 fileSize :: FileStatus -> FileOffset
 371 fileSize stat = unsafePerformPrimIO (
 372     _casm_ ``%r = ((struct stat *)%0)->st_size;'' stat
 373                                                     `thenStrictlyST` \ size ->
 374     returnPrimIO size)
 375
 376 accessTime :: FileStatus -> EpochTime
 377 accessTime stat = unsafePerformPrimIO (
 378     _casm_ ``%r = ((struct stat *)%0)->st_atime;'' stat
 379                                                     `thenStrictlyST` \ atime ->
 380     returnPrimIO atime)
 381
 382 modificationTime :: FileStatus -> EpochTime
 383 modificationTime stat = unsafePerformPrimIO (
 384     _casm_ ``%r = ((struct stat *)%0)->st_mtime;'' stat
 385                                                     `thenStrictlyST` \ mtime ->
 386     returnPrimIO mtime)
 387
 388 statusChangeTime :: FileStatus -> EpochTime
 389 statusChangeTime stat = unsafePerformPrimIO (
 390     _casm_ ``%r = ((struct stat *)%0)->st_ctime;'' stat
 391                                                     `thenStrictlyST` \ ctime ->
 392     returnPrimIO ctime)
 393
 394 isDirectory :: FileStatus -> Bool
 395 isDirectory stat = unsafePerformPrimIO (
 396     _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat
 397                                                     `thenStrictlyST` \ rc ->
 398     returnPrimIO (rc /= 0))
 399
 400 isCharacterDevice :: FileStatus -> Bool
 401 isCharacterDevice stat = unsafePerformPrimIO (
 402     _casm_ ``%r = S_ISCHR(((struct stat *)%0)->st_mode);'' stat
 403                                                     `thenStrictlyST` \ rc ->
 404     returnPrimIO (rc /= 0))
 405
 406 isBlockDevice :: FileStatus -> Bool
 407 isBlockDevice stat = unsafePerformPrimIO (
 408     _casm_ ``%r = S_ISBLK(((struct stat *)%0)->st_mode);'' stat
 409                                                     `thenStrictlyST` \ rc ->
 410     returnPrimIO (rc /= 0))
 411
 412 isRegularFile :: FileStatus -> Bool
 413 isRegularFile stat = unsafePerformPrimIO (
 414     _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat
 415                                                     `thenStrictlyST` \ rc ->
 416     returnPrimIO (rc /= 0))
 417
 418 isNamedPipe :: FileStatus -> Bool
 419 isNamedPipe stat = unsafePerformPrimIO (
 420     _casm_ ``%r = S_ISFIFO(((struct stat *)%0)->st_mode);'' stat
 421                                                     `thenStrictlyST` \ rc ->
 422     returnPrimIO (rc /= 0))
 423
 424 getFileStatus :: FilePath -> IO FileStatus
 425 getFileStatus name =
 426     _packBytesForCST name                           `thenStrictlyST` \ path ->
 427     allocChars ``sizeof(struct stat)''              `thenStrictlyST` \ bytes ->
 428     _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes
 429                                                     `thenPrimIO` \ rc ->
 430     if rc == 0 then
 431         freeze bytes                                `thenStrictlyST` \ stat ->
 432         return stat
 433     else
 434         syserr "getFileStatus"
 435
 436 getChannelStatus :: Channel -> IO FileStatus
 437 getChannelStatus fd =
 438     allocChars ``sizeof(struct stat)''              `thenStrictlyST` \ bytes ->
 439     _casm_ ``%r = fstat(%0,(struct stat *)%1);'' fd bytes
 440                                                     `thenPrimIO` \ rc ->
 441     if rc == 0 then
 442         freeze bytes                                `thenStrictlyST` \ stat ->
 443         return stat
 444     else
 445         syserr "getChannelStatus"
 446
 447 queryAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
 448 queryAccess name read write exec =
 449     _packBytesForCST name                           `thenStrictlyST` \ path ->
 450     _ccall_ access path flags                       `thenPrimIO` \ rc ->
 451     return (rc == 0)
 452   where
 453     flags = I# (word2Int# (read# `or#` write# `or#` exec#))
 454     read#  = case (if read  then ``R_OK'' else ``0'') of { W# x -> x }
 455     write# = case (if write then ``W_OK'' else ``0'') of { W# x -> x }
 456     exec#  = case (if exec  then ``X_OK'' else ``0'') of { W# x -> x }
 457
 458 queryFile :: FilePath -> IO Bool
 459 queryFile name =
 460     _packBytesForCST name                           `thenStrictlyST` \ path ->
 461     _ccall_ access path (``F_OK''::Int)             `thenPrimIO` \ rc ->
 462     return (rc == 0)
 463
 464 setFileMode :: FilePath -> FileMode -> IO ()
 465 setFileMode name mode =
 466     _packBytesForCST name                           `thenStrictlyST` \ path ->
 467     _ccall_ chmod path mode                         `thenPrimIO` \ rc ->
 468     if rc == 0 then
 469         return ()
 470     else
 471         syserr "setFileMode"
 472
 473 setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
 474 setOwnerAndGroup name uid gid =
 475     _packBytesForCST name                           `thenStrictlyST` \ path ->
 476     _ccall_ chown path uid gid                      `thenPrimIO` \ rc ->
 477     if rc == 0 then
 478         return ()
 479     else
 480         syserr "setOwnerAndGroup"
 481
 482 setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
 483 setFileTimes name atime mtime =
 484     _packBytesForCST name                           `thenStrictlyST` \ path ->
 485     _casm_ ``do {struct utimbuf ub; ub.actime = (time_t) %0; ub.modtime = (time_t) %1;
 486              %r = utime(%2, &ub);} while(0);'' atime mtime path
 487                                                     `thenPrimIO` \ rc ->
 488     if rc == 0 then
 489         return ()
 490     else
 491         syserr "setFileTimes"
 492
 493 touchFile :: FilePath -> IO ()
 494 touchFile name =
 495     _packBytesForCST name                           `thenStrictlyST` \ path ->
 496     _ccall_ utime path (``NULL''::_Addr)            `thenPrimIO` \ rc ->
 497     if rc == 0 then
 498         return ()
 499     else
 500         syserr "touchFile"
 501
 502 data PathVar = LinkLimit
 503              | InputLineLimit
 504              | InputQueueLimit
 505              | FileNameLimit
 506              | PathNameLimit
 507              | PipeBufferLimit
 508              | SetOwnerAndGroupIsRestricted
 509              | FileNamesAreNotTruncated
 510
 511 getPathVar :: PathVar -> FilePath -> IO Limit
 512 getPathVar v name =
 513     case v of
 514       LinkLimit -> pathconf ``_PC_LINK_MAX''
 515       InputLineLimit -> pathconf ``_PC_MAX_CANON''
 516       InputQueueLimit -> pathconf ``_PC_MAX_INPUT''
 517       FileNameLimit -> pathconf ``_PC_NAME_MAX''
 518       PathNameLimit -> pathconf ``_PC_PATH_MAX''
 519       PipeBufferLimit -> pathconf ``_PC_PIPE_BUF''
 520       SetOwnerAndGroupIsRestricted -> pathconf ``_PC_CHOWN_RESTRICTED''
 521       FileNamesAreNotTruncated -> pathconf ``_PC_NO_TRUNC''
 522   where
 523     pathconf :: Int -> IO Limit
 524     pathconf n =
 525         _packBytesForCST name                       `thenStrictlyST` \ path ->
 526         _ccall_ pathconf path n                     `thenPrimIO` \ rc ->
 527         if rc /= -1 then
 528             return rc
 529         else
 530             getErrorCode                            >>= \ errno ->
 531             if errno == invalidArgument then
 532                 failWith (NoSuchThing "no such path limit or option")
 533         else
 534             syserr "getPathVar"
 535
 536 getChannelVar :: PathVar -> Channel -> IO Limit
 537 getChannelVar v fd =
 538     case v of
 539       LinkLimit -> fpathconf ``_PC_LINK_MAX''
 540       InputLineLimit -> fpathconf ``_PC_MAX_CANON''
 541       InputQueueLimit -> fpathconf ``_PC_MAX_INPUT''
 542       FileNameLimit -> fpathconf ``_PC_NAME_MAX''
 543       PathNameLimit -> fpathconf ``_PC_PATH_MAX''
 544       PipeBufferLimit -> fpathconf ``_PC_PIPE_BUF''
 545       SetOwnerAndGroupIsRestricted -> fpathconf ``_PC_CHOWN_RESTRICTED''
 546       FileNamesAreNotTruncated -> fpathconf ``_PC_NO_TRUNC''
 547   where
 548     fpathconf :: Int -> IO Limit
 549     fpathconf n =
 550         _ccall_ fpathconf fd n                      `thenPrimIO` \ rc ->
 551         if rc /= -1 then
 552             return rc
 553         else
 554             getErrorCode                            >>= \ errno ->
 555             if errno == invalidArgument then
 556                 failWith (NoSuchThing "no such path limit or option")
 557             else
 558                 syserr "getPathVar"
 559
 560 \end{code}