diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2007, Bjorn Bringert +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,26 @@ +> import Distribution.PackageDescription (PackageDescription(buildDepends)) +> import Distribution.Setup (ConfigFlags) +> import Distribution.Simple (UserHooks(confHook), +> defaultMainWithHooks, defaultUserHooks, +> Dependency(..), VersionRange(..)) +> import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) +> import qualified System.Info (os) + +> main :: IO () +> main = defaultMainWithHooks myHooks + +> myHooks :: UserHooks +> myHooks = addOptionalUnixDependencyHook defaultUserHooks + +> addOptionalUnixDependencyHook :: UserHooks -> UserHooks +> addOptionalUnixDependencyHook hooks = +> hooks { confHook = confHook hooks . addOptionalUnixDependency } + +> addOptionalUnixDependency :: PackageDescription -> PackageDescription +> addOptionalUnixDependency desc = +> case System.Info.os of +> "mingw32" -> desc +> _ -> addDependency (Dependency "unix" AnyVersion) desc + +> addDependency :: Dependency -> PackageDescription -> PackageDescription +> addDependency dep desc = desc { buildDepends = dep : buildDepends desc} diff --git a/System/PosixCompat/Extensions.hsc b/System/PosixCompat/Extensions.hsc new file mode 100644 --- /dev/null +++ b/System/PosixCompat/Extensions.hsc @@ -0,0 +1,49 @@ +-- | This module provides some functions not present in the unix package. +module System.PosixCompat.Extensions ( + -- * Device IDs. + CMajor, CMinor, + deviceMajor, deviceMinor, makeDeviceID + ) where + +#include "HsUnixCompat.h" + +import Foreign.C.Types +import System.Posix.Types + + +type CMajor = CUInt +type CMinor = CUInt + +-- | Gets the major number from a 'DeviceID' for a device file. +-- +-- The portable implementation always returns @0@. +deviceMajor :: DeviceID -> CMajor +#if UNIX_IMPL +deviceMajor dev = unix_major dev + +foreign import ccall unsafe "unix_major" unix_major :: CDev -> CUInt +#else +deviceMajor _ = 0 +#endif + +-- | Gets the minor number from a 'DeviceID' for a device file. +-- +-- The portable implementation always returns @0@. +deviceMinor :: DeviceID -> CMinor +#if UNIX_IMPL +deviceMinor dev = unix_minor dev + +foreign import ccall unsafe "unix_minor" unix_minor :: CDev -> CUInt +#else +deviceMinor _ = 0 +#endif + +-- | Creates a 'DeviceID' for a device file given a major and minor number. +makeDeviceID :: CMajor -> CMinor -> DeviceID +#if UNIX_IMPL +makeDeviceID ma mi = unix_makedev ma mi + +foreign import ccall unsafe "unix_makedev" unix_makedev :: CUInt -> CUInt -> CDev +#else +makeDeviceID _ _ = 0 +#endif diff --git a/System/PosixCompat/Files.hsc b/System/PosixCompat/Files.hsc new file mode 100644 --- /dev/null +++ b/System/PosixCompat/Files.hsc @@ -0,0 +1,411 @@ +-- | 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 this +-- operations as far as possible. +-- +-- NOTE: the portable implementations are not well tested. +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 + +#include "HsUnixCompat.h" + +#if UNIX_IMPL + +import System.Posix.Files + +#if NEED_setSymbolicLinkOwnerAndGroup +import System.Posix.Types +#endif + +#else /* Portable implementation */ + +import Control.Exception (bracket) +import Control.Monad (liftM, liftM2) +import Data.Bits ((.|.), (.&.)) +import System.Directory (renameFile, doesFileExist, doesDirectoryExist, + Permissions(..), getPermissions, setPermissions, + getModificationTime) +import System.IO (IOMode(..), openFile, hFileSize, hSetFileSize, hClose) +import System.IO.Error +import System.Posix.Types +import System.Time (ClockTime(..), getClockTime) + +#if __GLASGOW_HASKELL__ +import GHC.Handle (fdToHandle) +#endif + + +#endif + + + +#if UNIX_IMPL + +#if NEED_setSymbolicLinkOwnerAndGroup +setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () +setSymbolicLinkOwnerAndGroup name uid gid = return () +#endif + + +#else /* Portable implementations */ + +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 fd m = unsupported "setFdMode" + +-- | The portable implementation does nothing and returns 'nullFileMode'. +setFileCreationMask :: FileMode -> IO FileMode +setFileCreationMask mask = return nullFileMode + +modeToPerms :: FileMode -> Permissions +modeToPerms m = Permissions { + readable = m .&. ownerReadMode /= 0, + writable = m .&. ownerWriteMode /= 0, + executable = m .&. ownerExecuteMode /= 0, + searchable = m .&. ownerExecuteMode /= 0 + } + +-- ----------------------------------------------------------------------------- +-- 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 clockTimeToEpochTime $ getModificationTime path + return $ FileStatus { + deviceID = -1, + fileID = -1, + fileMode = typ .|. perm, + linkCount = 1, + fileOwner = 0, + fileGroup = 0, + specialDeviceID = 0, + fileSize = size, + accessTime = mtime, + modificationTime = mtime, + statusChangeTime = mtime + } + +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) + +clockTimeToEpochTime :: ClockTime -> EpochTime +clockTimeToEpochTime (TOD s _) = fromInteger s + + +getFdStatus :: Fd -> IO FileStatus +getFdStatus fd = unsupported "getFdStatus" + +getSymbolicLinkStatus :: FilePath -> IO FileStatus +getSymbolicLinkStatus path = getFileStatus path + +createNamedPipe :: FilePath -> FileMode -> IO () +createNamedPipe name mode = unsupported "createNamedPipe" + +createDevice :: FilePath -> FileMode -> DeviceID -> IO () +createDevice path mode dev = unsupported "createDevice" + +-- ----------------------------------------------------------------------------- +-- Hard links + +createLink :: FilePath -> FilePath -> IO () +createLink name1 name2 = unsupported "createLink" + +removeLink :: FilePath -> IO () +removeLink name = unsupported "removeLink" + +-- ----------------------------------------------------------------------------- +-- Symbolic Links + +createSymbolicLink :: FilePath -> FilePath -> IO () +createSymbolicLink file1 file2 = unsupported "createSymbolicLink" + +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = 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 name uid gid = return () + +-- | The portable implementation does nothing. +setFdOwnerAndGroup :: Fd -> UserID -> GroupID -> IO () +setFdOwnerAndGroup fd uid gid = return () + +-- | The portable implementation does nothing. +setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () +setSymbolicLinkOwnerAndGroup name uid gid = return () + +-- ----------------------------------------------------------------------------- +-- utime() + +setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () +setFileTimes name atime mtime = 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 () +#if __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 name v = unsupported "getPathVar" + +getFdPathVar :: Fd -> PathVar -> IO Limit +getFdPathVar fd v = unsupported "getFdPathVar" + +#endif + diff --git a/System/PosixCompat/User.hsc b/System/PosixCompat/User.hsc new file mode 100644 --- /dev/null +++ b/System/PosixCompat/User.hsc @@ -0,0 +1,127 @@ +module System.PosixCompat.User ( + -- * User environment + -- ** Querying the user environment + getRealUserID, + getRealGroupID, + getEffectiveUserID, + getEffectiveGroupID, + getGroups, + getLoginName, + getEffectiveUserName, + + -- *** The group database + GroupEntry(..), + getGroupEntryForID, + getGroupEntryForName, + getAllGroupEntries, + + -- *** The user database + UserEntry(..), + getUserEntryForID, + getUserEntryForName, + getAllUserEntries, + + -- ** Modifying the user environment + setUserID, + setGroupID + ) where + +#include "HsUnixCompat.h" + +#if UNIX_IMPL + +import System.Posix.User + +#else /* Portable implementation */ + +import System.IO.Error +import System.Posix.Types + +#endif + + +#if UNIX_IMPL + +#else /* Portable implementation */ + +unsupported :: String -> IO a +unsupported f = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where x = "System.PosixCompat.User." ++ f ++ ": not supported" + +-- ----------------------------------------------------------------------------- +-- User environment + +getRealUserID :: IO UserID +getRealUserID = unsupported "getRealUserID" + +getRealGroupID :: IO GroupID +getRealGroupID = unsupported "getRealGroupID" + +getEffectiveUserID :: IO UserID +getEffectiveUserID = unsupported "getEffectiveUserID" + +getEffectiveGroupID :: IO GroupID +getEffectiveGroupID = unsupported "getEffectiveGroupID" + +getGroups :: IO [GroupID] +getGroups = return [] + +getLoginName :: IO String +getLoginName = unsupported "getLoginName" + +setUserID :: UserID -> IO () +setUserID uid = return () + +setGroupID :: GroupID -> IO () +setGroupID gid = return () + +-- ----------------------------------------------------------------------------- +-- User names + +getEffectiveUserName :: IO String +getEffectiveUserName = unsupported "getEffectiveUserName" + +-- ----------------------------------------------------------------------------- +-- The group database + +data GroupEntry = + GroupEntry { + groupName :: String, + groupPassword :: String, + groupID :: GroupID, + groupMembers :: [String] + } deriving (Show, Read, Eq) + +getGroupEntryForID :: GroupID -> IO GroupEntry +getGroupEntryForID gid = unsupported "getGroupEntryForID" + +getGroupEntryForName :: String -> IO GroupEntry +getGroupEntryForName name = unsupported "getGroupEntryForName" + +getAllGroupEntries :: IO [GroupEntry] +getAllGroupEntries = return [] + +-- ----------------------------------------------------------------------------- +-- The user database (pwd.h) + +data UserEntry = + UserEntry { + userName :: String, + userPassword :: String, + userID :: UserID, + userGroupID :: GroupID, + userGecos :: String, + homeDirectory :: String, + userShell :: String + } deriving (Show, Read, Eq) + +getUserEntryForID :: UserID -> IO UserEntry +getUserEntryForID uid = unsupported "getUserEntryForID" + +getUserEntryForName :: String -> IO UserEntry +getUserEntryForName name = unsupported "getUserEntryForName" + +getAllUserEntries :: IO [UserEntry] +getAllUserEntries = return [] + +#endif diff --git a/cbits/HsUnixCompat.c b/cbits/HsUnixCompat.c new file mode 100644 --- /dev/null +++ b/cbits/HsUnixCompat.c @@ -0,0 +1,17 @@ +#include "HsUnixCompat.h" + +#if UNIX_IMPL + +unsigned int unix_major(dev_t dev) { + return major(dev); +} + +unsigned int unix_minor(dev_t dev) { + return minor(dev); +} + +dev_t unix_makedev(unsigned int maj, unsigned int min) { + return makedev(maj, min); +} + +#endif diff --git a/include/HsUnixCompat.h b/include/HsUnixCompat.h new file mode 100644 --- /dev/null +++ b/include/HsUnixCompat.h @@ -0,0 +1,14 @@ +#define UNIX_IMPL !defined(mingw32_HOST_OS) + +#if UNIX_IMPL +#include "HsUnix.h" +#include + +unsigned int unix_major(dev_t dev); +unsigned int unix_minor(dev_t dev); +dev_t unix_makedev(unsigned int maj, unsigned int min); + +#define NEED_setSymbolicLinkOwnerAndGroup !HAVE_LCHOWN + +#endif + diff --git a/unix-compat.cabal b/unix-compat.cabal new file mode 100644 --- /dev/null +++ b/unix-compat.cabal @@ -0,0 +1,23 @@ +Name: unix-compat +Version: 0.1 +License: BSD4 +License-file: LICENSE +Maintainer: bjorn@bringert.net +Synopsis: Portable POSIX-compatibility layer. +Description: + This package provides portable implementations of parts + of the unix package. This package re-exports the unix + package when available. When it isn't available, + portable implementations are used. +Exposed-modules: + System.PosixCompat.Extensions + System.PosixCompat.Files + System.PosixCompat.User +-- Also depends on the unix package on POSIX platforms, added by Setup.lhs. +Build-depends: base +Extensions: CPP, ForeignFunctionInterface +Include-dirs: include +Install-includes: HsUnixCompat.h +C-sources: cbits/HsUnixCompat.c +Extra-source-files: include/HsUnixCompat.h +GHC-Options: -O -Wall