From 61f2688f7776afe70f0ba68a29137c45d7df806f Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 25 2020 16:37:46 +0000 Subject: ghc-unix-compat-0.5.0.1 base --- diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e55140d --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2007-2008, Björn Bringert +Copyright (c) 2007-2009, Duncan Coutts +Copyright (c) 2010-2011, Jacob Stanley +Copyright (c) 2011, Bryan O'Sullivan +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 index 0000000..37d1ded --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/cbits/HsUname.c b/cbits/HsUname.c new file mode 100644 index 0000000..ae29dfd --- /dev/null +++ b/cbits/HsUname.c @@ -0,0 +1,363 @@ +/* + * For details of what's going on here, see the following URL: + * + * http://msdn.microsoft.com/en-us/library/ms724429(v=vs.85).aspx + */ + +#include +#include +#include + +#ifdef _MSC_VER +# include +#else + +static void StringCchCopy(char *dest, size_t bufsize, const char *src) +{ + strcpy(dest, src); +} + +static void StringCchCat(char *dest, size_t bufsize, const char *src) +{ + strcat(dest, src); +} + +#define StringCchPrintf _snprintf + +#endif + +typedef void (WINAPI *PGNSI)(LPSYSTEM_INFO); +typedef BOOL (WINAPI *PGPI)(DWORD, DWORD, DWORD, DWORD, PDWORD); + +#ifndef PRODUCT_ULTIMATE +# define PRODUCT_ULTIMATE 0x00000001 +#endif + +#ifndef PRODUCT_PROFESSIONAL +# define PRODUCT_PROFESSIONAL 0x00000030 +#endif + +#ifndef PRODUCT_HOME_PREMIUM +# define PRODUCT_HOME_PREMIUM 0x00000003 +#endif + +#ifndef PRODUCT_HOME_BASIC +# define PRODUCT_HOME_BASIC 0x00000002 +#endif + +#ifndef PRODUCT_BUSINESS +# define PRODUCT_BUSINESS 0x00000006 +#endif + +#ifndef PRODUCT_ENTERPRISE +# define PRODUCT_ENTERPRISE 0x00000004 +#endif + +#ifndef PRODUCT_STARTER +# define PRODUCT_STARTER 0x0000000B +#endif + +#ifndef PRODUCT_CLUSTER_SERVER +# define PRODUCT_CLUSTER_SERVER 0x00000012 +#endif + +#ifndef PRODUCT_DATACENTER_SERVER +# define PRODUCT_DATACENTER_SERVER 0x00000008 +#endif + +#ifndef PRODUCT_DATACENTER_SERVER_CORE +# define PRODUCT_DATACENTER_SERVER_CORE 0x0000000C +#endif + +#ifndef PRODUCT_ENTERPRISE_SERVER +# define PRODUCT_ENTERPRISE_SERVER 0x0000000A +#endif + +#ifndef PRODUCT_ENTERPRISE_SERVER_CORE +# define PRODUCT_ENTERPRISE_SERVER_CORE 0x0000000E +#endif + +#ifndef PRODUCT_ENTERPRISE_SERVER_IA64 +# define PRODUCT_ENTERPRISE_SERVER_IA64 0x0000000F +#endif + +#ifndef PRODUCT_SMALLBUSINESS_SERVER +# define PRODUCT_SMALLBUSINESS_SERVER 0x00000009 +#endif + +#ifndef PRODUCT_SMALLBUSINESS_SERVER_PREMIUM +# define PRODUCT_SMALLBUSINESS_SERVER_PREMIUM 0x00000019 +#endif + +#ifndef PRODUCT_STANDARD_SERVER +# define PRODUCT_STANDARD_SERVER 0x00000007 +#endif + +#ifndef PRODUCT_STANDARD_SERVER_CORE +# define PRODUCT_STANDARD_SERVER_CORE 0x0000000D +#endif + +#ifndef PRODUCT_WEB_SERVER +# define PRODUCT_WEB_SERVER 0x00000011 +#endif + +#ifndef VER_SUITE_WH_SERVER +# define VER_SUITE_WH_SERVER 0x00008000 +#endif + +int unixcompat_os_display_string(char *pszOS, size_t BUFSIZE) +{ + OSVERSIONINFOEX osvi; + SYSTEM_INFO si; + PGNSI pGNSI; + PGPI pGPI; + BOOL bOsVersionInfoEx; + DWORD dwType; + + ZeroMemory(&si, sizeof(SYSTEM_INFO)); + ZeroMemory(&osvi, sizeof(OSVERSIONINFOEX)); + + osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX); + bOsVersionInfoEx = GetVersionEx((OSVERSIONINFO*) &osvi); + + if (bOsVersionInfoEx == 0) + return FALSE; + + // Call GetNativeSystemInfo if supported or GetSystemInfo otherwise. + + pGNSI = (PGNSI) GetProcAddress( + GetModuleHandle(TEXT("kernel32.dll")), + "GetNativeSystemInfo"); + if (NULL != pGNSI) + pGNSI(&si); + else + GetSystemInfo(&si); + + if (VER_PLATFORM_WIN32_NT == osvi.dwPlatformId && osvi.dwMajorVersion > 4) { + StringCchCopy(pszOS, BUFSIZE, TEXT("Microsoft ")); + + // Test for the specific product. + if (osvi.dwMajorVersion == 6) { + if(osvi.dwMinorVersion == 0) { + if(osvi.wProductType == VER_NT_WORKSTATION) + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Vista ")); + else + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Server 2008 ")); + } + + if (osvi.dwMinorVersion == 1) { + if (osvi.wProductType == VER_NT_WORKSTATION) + StringCchCat(pszOS, BUFSIZE, TEXT("Windows 7 ")); + else + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Server 2008 R2 ")); + } + + pGPI = (PGPI) GetProcAddress( + GetModuleHandle(TEXT("kernel32.dll")), + "GetProductInfo"); + + pGPI(osvi.dwMajorVersion, osvi.dwMinorVersion, 0, 0, &dwType); + + switch (dwType) { + case PRODUCT_ULTIMATE: + StringCchCat(pszOS, BUFSIZE, TEXT("Ultimate Edition")); + break; + case PRODUCT_PROFESSIONAL: + StringCchCat(pszOS, BUFSIZE, TEXT("Professional")); + break; + case PRODUCT_HOME_PREMIUM: + StringCchCat(pszOS, BUFSIZE, TEXT("Home Premium Edition")); + break; + case PRODUCT_HOME_BASIC: + StringCchCat(pszOS, BUFSIZE, TEXT("Home Basic Edition")); + break; + case PRODUCT_ENTERPRISE: + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise Edition")); + break; + case PRODUCT_BUSINESS: + StringCchCat(pszOS, BUFSIZE, TEXT("Business Edition")); + break; + case PRODUCT_STARTER: + StringCchCat(pszOS, BUFSIZE, TEXT("Starter Edition")); + break; + case PRODUCT_CLUSTER_SERVER: + StringCchCat(pszOS, BUFSIZE, TEXT("Cluster Server Edition")); + break; + case PRODUCT_DATACENTER_SERVER: + StringCchCat(pszOS, BUFSIZE, TEXT("Datacenter Edition")); + break; + case PRODUCT_DATACENTER_SERVER_CORE: + StringCchCat(pszOS, BUFSIZE, TEXT("Datacenter Edition (core installation)")); + break; + case PRODUCT_ENTERPRISE_SERVER: + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise Edition")); + break; + case PRODUCT_ENTERPRISE_SERVER_CORE: + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise Edition (core installation)")); + break; + case PRODUCT_ENTERPRISE_SERVER_IA64: + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise Edition for Itanium-based Systems")); + break; + case PRODUCT_SMALLBUSINESS_SERVER: + StringCchCat(pszOS, BUFSIZE, TEXT("Small Business Server")); + break; + case PRODUCT_SMALLBUSINESS_SERVER_PREMIUM: + StringCchCat(pszOS, BUFSIZE, TEXT("Small Business Server Premium Edition")); + break; + case PRODUCT_STANDARD_SERVER: + StringCchCat(pszOS, BUFSIZE, TEXT("Standard Edition")); + break; + case PRODUCT_STANDARD_SERVER_CORE: + StringCchCat(pszOS, BUFSIZE, TEXT("Standard Edition (core installation)")); + break; + case PRODUCT_WEB_SERVER: + StringCchCat(pszOS, BUFSIZE, TEXT("Web Server Edition")); + break; + } + } + + if (osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) { + if (GetSystemMetrics(SM_SERVERR2)) + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Server 2003 R2, ")); + else if (osvi.wSuiteMask & VER_SUITE_STORAGE_SERVER) + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Storage Server 2003")); + else if (osvi.wSuiteMask & VER_SUITE_WH_SERVER) + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Home Server")); + else if (osvi.wProductType == VER_NT_WORKSTATION && + si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64) + StringCchCat(pszOS, BUFSIZE, TEXT("Windows XP Professional x64 Edition")); + else + StringCchCat(pszOS, BUFSIZE, TEXT("Windows Server 2003, ")); + + // Test for the server type. + + if (osvi.wProductType != VER_NT_WORKSTATION) { + if (si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_IA64) { + if(osvi.wSuiteMask & VER_SUITE_DATACENTER) + StringCchCat(pszOS, BUFSIZE, TEXT("Datacenter Edition for Itanium-based Systems")); + else if(osvi.wSuiteMask & VER_SUITE_ENTERPRISE) + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise Edition for Itanium-based Systems")); + } else if (si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64) { + if(osvi.wSuiteMask & VER_SUITE_DATACENTER) + StringCchCat(pszOS, BUFSIZE, TEXT("Datacenter x64 Edition")); + else if(osvi.wSuiteMask & VER_SUITE_ENTERPRISE) + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise x64 Edition")); + else StringCchCat(pszOS, BUFSIZE, TEXT("Standard x64 Edition")); + } else { + if (osvi.wSuiteMask & VER_SUITE_COMPUTE_SERVER) + StringCchCat(pszOS, BUFSIZE, TEXT("Compute Cluster Edition")); + else if(osvi.wSuiteMask & VER_SUITE_DATACENTER) + StringCchCat(pszOS, BUFSIZE, TEXT("Datacenter Edition")); + else if(osvi.wSuiteMask & VER_SUITE_ENTERPRISE) + StringCchCat(pszOS, BUFSIZE, TEXT("Enterprise Edition")); + else if (osvi.wSuiteMask & VER_SUITE_BLADE) + StringCchCat(pszOS, BUFSIZE, TEXT("Web Edition")); + else StringCchCat(pszOS, BUFSIZE, TEXT("Standard Edition")); + } + } + } + + if (osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1) { + StringCchCat(pszOS, BUFSIZE, TEXT("Windows XP ")); + + if (osvi.wSuiteMask & VER_SUITE_PERSONAL) + StringCchCat(pszOS, BUFSIZE, TEXT("Home Edition")); + else + StringCchCat(pszOS, BUFSIZE, TEXT("Professional")); + } + + if (osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0) { + StringCchCat(pszOS, BUFSIZE, TEXT("Windows 2000 ")); + + if (osvi.wProductType == VER_NT_WORKSTATION) { + StringCchCat(pszOS, BUFSIZE, TEXT("Professional")); + } else { + if(osvi.wSuiteMask & VER_SUITE_DATACENTER) + StringCchCat(pszOS, BUFSIZE, TEXT("Datacenter Server")); + else if(osvi.wSuiteMask & VER_SUITE_ENTERPRISE) + StringCchCat(pszOS, BUFSIZE, TEXT("Advanced Server")); + else + StringCchCat(pszOS, BUFSIZE, TEXT("Server")); + } + } + + // Include service pack (if any) and build number. + + if(_tcslen(osvi.szCSDVersion) > 0) { + StringCchCat(pszOS, BUFSIZE, TEXT(" ")); + StringCchCat(pszOS, BUFSIZE, osvi.szCSDVersion); + } + + char buf[80]; + StringCchPrintf(buf, 80, TEXT(" (build %d)"), osvi.dwBuildNumber); + StringCchCat(pszOS, BUFSIZE, buf); + + if (osvi.dwMajorVersion >= 6) { + if (si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64) + StringCchCat(pszOS, BUFSIZE, TEXT(", 64-bit")); + else if (si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_INTEL) + StringCchCat(pszOS, BUFSIZE, TEXT(", 32-bit")); + } + + return TRUE; + } else { + // This sample does not support this version of Windows. + return FALSE; + } +} + +int unixcompat_os_version_string(char *ptr, size_t bufsize) +{ + OSVERSIONINFOEX osvi; + BOOL bOsVersionInfoEx; + char *szServicePack; + + ZeroMemory(&osvi, sizeof(OSVERSIONINFOEX)); + osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX); + bOsVersionInfoEx = GetVersionEx((OSVERSIONINFO*) &osvi); + + if (bOsVersionInfoEx == 0) + return FALSE; + + if (strncmp(osvi.szCSDVersion, "Service Pack ", 13) == 0) + szServicePack = "0"; + else + szServicePack = osvi.szCSDVersion + 13; + + StringCchPrintf(ptr, bufsize, "%ld.%ld.%s.%ld", + osvi.dwMajorVersion, osvi.dwMinorVersion, szServicePack, + osvi.dwBuildNumber); + + return TRUE; +} + +int unixcompat_os_arch_string(char *ptr, size_t bufsize) +{ + SYSTEM_INFO sysInfo; + + GetSystemInfo(&sysInfo); + + switch (sysInfo.wProcessorArchitecture) { + case PROCESSOR_ARCHITECTURE_INTEL: + StringCchCopy(ptr, bufsize, "i386"); + break; + case PROCESSOR_ARCHITECTURE_AMD64: + StringCchCopy(ptr, bufsize, "x86_64"); + break; + default: + StringCchCopy(ptr, bufsize, "unknown"); + break; + } + + return TRUE; +} + +int unixcompat_os_node_name(char *ptr, size_t bufsize) +{ + DWORD sLength; + + sLength = bufsize - 1; + GetComputerName(ptr, &sLength); + + return TRUE; +} diff --git a/cbits/HsUnixCompat.c b/cbits/HsUnixCompat.c new file mode 100644 index 0000000..1f7f189 --- /dev/null +++ b/cbits/HsUnixCompat.c @@ -0,0 +1,20 @@ +#include "HsUnixCompat.h" + +#ifdef SOLARIS +#include +#endif + +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); +} diff --git a/cbits/mktemp.c b/cbits/mktemp.c new file mode 100644 index 0000000..b9ec050 --- /dev/null +++ b/cbits/mktemp.c @@ -0,0 +1,173 @@ +/* + * Modified version of 'mktemp.c' from FreeBSD + * http://www.freebsd.org/cgi/cvsweb.cgi/src/lib/libc/stdio/mktemp.c + * ?rev=1.29.2.2.2.1;content-type=text%2Fplain + */ + +/* + * Copyright (c) 1987, 1993 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. 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. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +static int random(uint32_t *); +static int _gettemp(char *, int *); + +static const unsigned char padchar[] = +"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; + +int unixcompat_mkstemp(char *path) +{ + int fd; + + if (_gettemp(path, &fd)) + return fd; + + return -1; +} + +static int _gettemp(char *path, int *doopen) +{ + char *start, *trv, *suffp, *carryp; + char *pad; + struct _stat sbuf; + int rval; + uint32_t randidx, randval; + char carrybuf[MAXPATHLEN]; + + for (trv = path; *trv != '\0'; ++trv) + ; + if (trv - path >= MAXPATHLEN) { + errno = ENAMETOOLONG; + return (0); + } + suffp = trv; + --trv; + if (trv < path || NULL != strchr(suffp, '/')) { + errno = EINVAL; + return (0); + } + + /* Fill space with random characters */ + while (trv >= path && *trv == 'X') { + if (!random(&randval)) { + /* this should never happen */ + errno = EIO; + return 0; + } + randidx = randval % (sizeof(padchar) - 1); + *trv-- = padchar[randidx]; + } + start = trv + 1; + + /* save first combination of random characters */ + memcpy(carrybuf, start, suffp - start); + + /* + * check the target directory. + */ + if (doopen != NULL) { + for (; trv > path; --trv) { + if (*trv == '/') { + *trv = '\0'; + rval = _stat(path, &sbuf); + *trv = '/'; + if (rval != 0) + return (0); + if (!S_ISDIR(sbuf.st_mode)) { + errno = ENOTDIR; + return (0); + } + break; + } + } + } + + for (;;) { + if (doopen) { + if ((*doopen = + _open(path, O_CREAT|O_EXCL|O_RDWR, 0600)) >= 0) + return (1); + if (errno != EEXIST) + return (0); + } else if (_stat(path, &sbuf)) + return (errno == ENOENT); + + /* If we have a collision, cycle through the space of filenames */ + for (trv = start, carryp = carrybuf;;) { + /* have we tried all possible permutations? */ + if (trv == suffp) + return (0); /* yes - exit with EEXIST */ + pad = strchr(padchar, *trv); + if (pad == NULL) { + /* this should never happen */ + errno = EIO; + return (0); + } + /* increment character */ + *trv = (*++pad == '\0') ? padchar[0] : *pad; + /* carry to next position? */ + if (*trv == *carryp) { + /* increment position and loop */ + ++trv; + ++carryp; + } else { + /* try with new name */ + break; + } + } + } + /*NOTREACHED*/ +} + +static int random(uint32_t *value) +{ + /* This handle is never released. Windows will clean up when the process + * exits. Python takes this approach when emulating /dev/urandom, and if + * it's good enough for them, then it's good enough for us. */ + static HCRYPTPROV context = 0; + + if (context == 0) + if (!CryptAcquireContext( + &context, NULL, NULL, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)) + return 0; + + if (!CryptGenRandom(context, sizeof *value, (BYTE *)value)) + return 0; + + return 1; +} diff --git a/include/HsUnixCompat.h b/include/HsUnixCompat.h new file mode 100644 index 0000000..32476d4 --- /dev/null +++ b/include/HsUnixCompat.h @@ -0,0 +1,8 @@ +#include "HsUnixConfig.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 diff --git a/src/System/PosixCompat.hs b/src/System/PosixCompat.hs new file mode 100644 index 0000000..ed3a618 --- /dev/null +++ b/src/System/PosixCompat.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +{-| +The @unix-compat@ package provides portable implementations of parts of the +@unix@ package. On POSIX system it re-exports operations from the @unix@ +package, on other platforms it emulates the operations as far as possible. +-} +module System.PosixCompat ( + module System.PosixCompat.Files + , module System.PosixCompat.Temp + , module System.PosixCompat.Time + , module System.PosixCompat.Types + , module System.PosixCompat.Unistd + , module System.PosixCompat.User + , usingPortableImpl + ) where + +import System.PosixCompat.Files +import System.PosixCompat.Temp +import System.PosixCompat.Time +import System.PosixCompat.Types +import System.PosixCompat.Unistd +import System.PosixCompat.User + +-- | 'True' if unix-compat is using its portable implementation, +-- or 'False' if the unix package is simply being re-exported. +usingPortableImpl :: Bool +#ifdef mingw32_HOST_OS +usingPortableImpl = True +#else +usingPortableImpl = False +#endif + diff --git a/src/System/PosixCompat/Extensions.hsc b/src/System/PosixCompat/Extensions.hsc new file mode 100644 index 0000000..f9aa7bd --- /dev/null +++ b/src/System/PosixCompat/Extensions.hsc @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | This module provides some functions not present in the unix package. +module System.PosixCompat.Extensions ( + -- * Device IDs. + CMajor + , CMinor + , deviceMajor + , deviceMinor + , makeDeviceID + ) where + + +#ifndef mingw32_HOST_OS +#include "HsUnixCompat.h" +#endif + +import Foreign.C.Types +import System.PosixCompat.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 +#ifdef mingw32_HOST_OS +deviceMajor _ = 0 +#else +deviceMajor dev = unix_major dev + +foreign import ccall unsafe "unix_major" unix_major :: CDev -> CUInt +#endif + +-- | Gets the minor number from a 'DeviceID' for a device file. +-- +-- The portable implementation always returns @0@. +deviceMinor :: DeviceID -> CMinor +#ifdef mingw32_HOST_OS +deviceMinor _ = 0 +#else +deviceMinor dev = unix_minor dev + +foreign import ccall unsafe "unix_minor" unix_minor :: CDev -> CUInt +#endif + +-- | Creates a 'DeviceID' for a device file given a major and minor number. +makeDeviceID :: CMajor -> CMinor -> DeviceID +#ifdef mingw32_HOST_OS +makeDeviceID _ _ = 0 +#else +makeDeviceID ma mi = unix_makedev ma mi + +foreign import ccall unsafe "unix_makedev" unix_makedev :: CUInt -> CUInt -> CDev +#endif diff --git a/src/System/PosixCompat/Files.hsc b/src/System/PosixCompat/Files.hsc new file mode 100644 index 0000000..0c45069 --- /dev/null +++ b/src/System/PosixCompat/Files.hsc @@ -0,0 +1,497 @@ +{-# 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 Data.Int (Int64) +import Foreign.C.Types (CTime(..)) +import Prelude hiding (read) +import System.Directory (Permissions, emptyPermissions) +import System.Directory (getPermissions, setPermissions) +import System.Directory (readable, setOwnerReadable) +import System.Directory (writable, setOwnerWritable) +import System.Directory (executable, setOwnerExecutable) +import System.Directory (searchable, setOwnerSearchable) +import System.Directory (doesFileExist, doesDirectoryExist) +import System.Directory (getModificationTime, renameFile) +import System.IO (IOMode(..), openFile, hFileSize, hSetFileSize, hClose) +import System.IO.Error +import System.PosixCompat.Types +import System.Win32.File hiding (getFileType) +import System.Win32.HardLink (createHardLink) +import System.Win32.Time (FILETIME(..), getFileTime, setFileTime) + +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 = createHardLink + +removeLink :: FilePath -> IO () +removeLink _ = unsupported "removeLink" + +-- ----------------------------------------------------------------------------- +-- Symbolic Links + +createSymbolicLink :: FilePath -> FilePath -> IO () +createSymbolicLink _ _ = unsupported "createSymbolicLink" + +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink _ = unsupported "readSymbolicLink" + +-- ----------------------------------------------------------------------------- +-- Renaming + +rename :: FilePath -> FilePath -> IO () +#if MIN_VERSION_Win32(2, 6, 0) +rename name1 name2 = moveFileEx name1 (Just name2) mOVEFILE_REPLACE_EXISTING +#else +rename name1 name2 = moveFileEx name1 name2 mOVEFILE_REPLACE_EXISTING +#endif + +-- ----------------------------------------------------------------------------- +-- 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 file atime mtime = + bracket openFileHandle closeHandle $ \handle -> do + (creationTime, _, _) <- getFileTime handle + setFileTime + handle + creationTime + (epochTimeToFileTime atime) + (epochTimeToFileTime mtime) + where + openFileHandle = createFile file + gENERIC_WRITE + fILE_SHARE_NONE + Nothing + oPEN_EXISTING + fILE_ATTRIBUTE_NORMAL + Nothing + + -- based on https://support.microsoft.com/en-us/kb/167296 + epochTimeToFileTime (CTime t) = FILETIME (fromIntegral ll) + where + ll :: Int64 + ll = fromIntegral t * 10000000 + 116444736000000000 + +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 diff --git a/src/System/PosixCompat/Internal/Time.hs b/src/System/PosixCompat/Internal/Time.hs new file mode 100644 index 0000000..b0706d1 --- /dev/null +++ b/src/System/PosixCompat/Internal/Time.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{- +Compatibility wrapper to help manage the transition from +old-time to time packages. Only used at all on win32. +-} +module System.PosixCompat.Internal.Time ( + ClockTime + , getClockTime + , clockTimeToEpochTime + , ModificationTime + , modificationTimeToEpochTime + ) where + +import System.Posix.Types (EpochTime) + +#ifdef OLD_TIME + +import System.Time (ClockTime(TOD), getClockTime) + +clockTimeToEpochTime :: ClockTime -> EpochTime +clockTimeToEpochTime (TOD s _) = fromInteger s + +type ModificationTime = ClockTime + +modificationTimeToEpochTime :: ModificationTime -> EpochTime +modificationTimeToEpochTime = clockTimeToEpochTime + +#else + +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, utcTimeToPOSIXSeconds) + +type ClockTime = POSIXTime + +getClockTime :: IO ClockTime +getClockTime = getPOSIXTime + +clockTimeToEpochTime :: ClockTime -> EpochTime +clockTimeToEpochTime = fromInteger . floor + +type ModificationTime = UTCTime + +modificationTimeToEpochTime :: UTCTime -> EpochTime +modificationTimeToEpochTime = clockTimeToEpochTime . utcTimeToPOSIXSeconds + +#endif diff --git a/src/System/PosixCompat/Temp.hs b/src/System/PosixCompat/Temp.hs new file mode 100644 index 0000000..8575fc1 --- /dev/null +++ b/src/System/PosixCompat/Temp.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +{-| +This module makes the operations exported by @System.Posix.Temp@ +available on all platforms. On POSIX systems it re-exports operations from +@System.Posix.Temp@, on other platforms it emulates the operations as far +as possible. +-} +module System.PosixCompat.Temp ( + mkstemp + ) where + +#ifndef mingw32_HOST_OS +-- Re-export unix package + +import System.Posix.Temp + +#elif defined(__GLASGOW_HASKELL__) +-- Windows w/ GHC, we have fdToHandle so we +-- can use our own implementation of mkstemp. + +import System.IO (Handle) +import Foreign.C (CInt(..), CString, withCString, peekCString, throwErrnoIfMinus1) +import GHC.IO.Handle.FD (fdToHandle) + +-- | 'mkstemp' - make a unique filename and open it for +-- reading\/writing. +-- The returned 'FilePath' is the (possibly relative) path of +-- the created file, which is padded with 6 random characters. +mkstemp :: String -> IO (FilePath, Handle) +mkstemp template = do + withCString template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) + name <- peekCString ptr + h <- fdToHandle (fromIntegral fd) + return (name, h) + +foreign import ccall unsafe "unixcompat_mkstemp" + c_mkstemp :: CString -> IO CInt + +#else +-- Windows w/o GHC, we don't have fdToHandle :( + +import System.IO (Handle) +import System.IO.Error (mkIOError, illegalOperationErrorType) + +mkstemp :: String -> IO (FilePath, Handle) +mkstemp _ = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where + x = "System.PosixCompat.Temp.mkstemp: not supported" + +#endif diff --git a/src/System/PosixCompat/Time.hs b/src/System/PosixCompat/Time.hs new file mode 100644 index 0000000..44acd06 --- /dev/null +++ b/src/System/PosixCompat/Time.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +{-| +This module makes the operations exported by @System.Posix.Time@ +available on all platforms. On POSIX systems it re-exports operations from +@System.Posix.Time@, on other platforms it emulates the operations as far +as possible. +-} +module System.PosixCompat.Time ( + epochTime + ) where + +#ifndef mingw32_HOST_OS + +import System.Posix.Time + +#else + +import Control.Monad (liftM) +import System.Posix.Types (EpochTime) + +import System.PosixCompat.Internal.Time ( + getClockTime, clockTimeToEpochTime + ) + +-- | The portable version of @epochTime@ calls 'getClockTime' to obtain the +-- number of seconds that have elapsed since the epoch (Jan 01 00:00:00 GMT +-- 1970). +epochTime :: IO EpochTime +epochTime = liftM clockTimeToEpochTime getClockTime + +#endif + diff --git a/src/System/PosixCompat/Types.hs b/src/System/PosixCompat/Types.hs new file mode 100644 index 0000000..48aed97 --- /dev/null +++ b/src/System/PosixCompat/Types.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| +This module re-exports the types from @System.Posix.Types@ on all platforms. + +On Windows 'UserID', 'GroupID' and 'LinkCount' are missing, so they are +redefined by this module. +-} +module System.PosixCompat.Types ( +#ifdef mingw32_HOST_OS + module AllPosixTypesButFileID + , FileID + , UserID + , GroupID + , LinkCount +#else + module System.Posix.Types +#endif + ) where + +#ifdef mingw32_HOST_OS +-- Since CIno (FileID's underlying type) reflects ino_t, +-- which mingw defines as short int (int16), it must be overriden to +-- match the size of windows fileIndex (word64). +import System.Posix.Types as AllPosixTypesButFileID hiding (FileID) + +import Data.Word (Word32, Word64) + +newtype FileID = FileID Word64 + deriving (Eq, Ord, Enum, Bounded, Integral, Num, Real) +instance Show FileID where show (FileID x) = show x +instance Read FileID where readsPrec i s = [ (FileID x, s') + | (x,s') <- readsPrec i s] + +newtype UserID = UserID Word32 + deriving (Eq, Ord, Enum, Bounded, Integral, Num, Real) +instance Show UserID where show (UserID x) = show x +instance Read UserID where readsPrec i s = [ (UserID x, s') + | (x,s') <- readsPrec i s] + +newtype GroupID = GroupID Word32 + deriving (Eq, Ord, Enum, Bounded, Integral, Num, Real) +instance Show GroupID where show (GroupID x) = show x +instance Read GroupID where readsPrec i s = [ (GroupID x, s') + | (x,s') <- readsPrec i s] + +newtype LinkCount = LinkCount Word32 + deriving (Eq, Ord, Enum, Bounded, Integral, Num, Real) +instance Show LinkCount where show (LinkCount x) = show x +instance Read LinkCount where readsPrec i s = [ (LinkCount x, s') + | (x,s') <- readsPrec i s] + +#else +import System.Posix.Types +#endif diff --git a/src/System/PosixCompat/Unistd.hs b/src/System/PosixCompat/Unistd.hs new file mode 100644 index 0000000..3c9992f --- /dev/null +++ b/src/System/PosixCompat/Unistd.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +{-| +This module makes the operations exported by @System.Posix.Unistd@ +available on all platforms. On POSIX systems it re-exports operations from +@System.Posix.Unistd@, on other platforms it emulates the operations as far +as possible. +-} +module System.PosixCompat.Unistd ( + -- * System environment + SystemID(..) + , getSystemID + -- * Sleeping + , sleep + , usleep + , nanosleep + ) where + +#ifndef mingw32_HOST_OS + +import System.Posix.Unistd + +#else + +import Control.Concurrent (threadDelay) +import Foreign.C.String (CString, peekCString) +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.Marshal.Array (allocaArray) + +data SystemID = SystemID { + systemName :: String + , nodeName :: String + , release :: String + , version :: String + , machine :: String + } deriving (Eq, Read, Show) + +getSystemID :: IO SystemID +getSystemID = do + let bufSize = 256 + let call f = allocaArray bufSize $ \buf -> do + ok <- f buf (fromIntegral bufSize) + if ok == 1 + then peekCString buf + else return "" + display <- call c_os_display_string + vers <- call c_os_version_string + arch <- call c_os_arch_string + node <- call c_os_node_name + return SystemID { + systemName = "Windows" + , nodeName = node + , release = display + , version = vers + , machine = arch + } + +-- | Sleep for the specified duration (in seconds). Returns the time +-- remaining (if the sleep was interrupted by a signal, for example). +-- +-- On non-Unix systems, this is implemented in terms of +-- 'Control.Concurrent.threadDelay'. +-- +-- GHC Note: the comment for 'usleep' also applies here. +sleep :: Int -> IO Int +sleep secs = threadDelay (secs * 1000000) >> return 0 + +-- | Sleep for the specified duration (in microseconds). +-- +-- On non-Unix systems, this is implemented in terms of +-- 'Control.Concurrent.threadDelay'. +-- +-- GHC Note: 'Control.Concurrent.threadDelay' is a better +-- choice. Without the @-threaded@ option, 'usleep' will block all other +-- user threads. Even with the @-threaded@ option, 'usleep' requires a +-- full OS thread to itself. 'Control.Concurrent.threadDelay' has +-- neither of these shortcomings. +usleep :: Int -> IO () +usleep = threadDelay + +-- | Sleep for the specified duration (in nanoseconds). +-- +-- On non-Unix systems, this is implemented in terms of +-- 'Control.Concurrent.threadDelay'. +nanosleep :: Integer -> IO () +nanosleep nsecs = threadDelay (round (fromIntegral nsecs / 1000 :: Double)) + +foreign import ccall "unixcompat_os_display_string" + c_os_display_string :: CString -> CSize -> IO CInt + +foreign import ccall "unixcompat_os_version_string" + c_os_version_string :: CString -> CSize -> IO CInt + +foreign import ccall "unixcompat_os_arch_string" + c_os_arch_string :: CString -> CSize -> IO CInt + +foreign import ccall "unixcompat_os_node_name" + c_os_node_name :: CString -> CSize -> IO CInt + +#endif diff --git a/src/System/PosixCompat/User.hsc b/src/System/PosixCompat/User.hsc new file mode 100644 index 0000000..b5b07e2 --- /dev/null +++ b/src/System/PosixCompat/User.hsc @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} + +{-| +This module makes the operations exported by @System.Posix.User@ +available on all platforms. On POSIX systems it re-exports operations from +@System.Posix.User@. On other platforms it provides dummy implementations. +-} +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 + +#ifndef mingw32_HOST_OS + +#include "HsUnixCompat.h" + +import System.Posix.User + +#if __GLASGOW_HASKELL__<605 +getAllGroupEntries :: IO [GroupEntry] +getAllGroupEntries = return [] + +getAllUserEntries :: IO [UserEntry] +getAllUserEntries = return [] +#endif + +#else /* Portable implementation */ + +import System.IO.Error +import System.PosixCompat.Types + +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 _ = return () + +setGroupID :: GroupID -> IO () +setGroupID _ = 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 _ = unsupported "getGroupEntryForID" + +getGroupEntryForName :: String -> IO GroupEntry +getGroupEntryForName _ = 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 _ = unsupported "getUserEntryForID" + +getUserEntryForName :: String -> IO UserEntry +getUserEntryForName _ = unsupported "getUserEntryForName" + +getAllUserEntries :: IO [UserEntry] +getAllUserEntries = return [] + +#endif diff --git a/unix-compat.cabal b/unix-compat.cabal new file mode 100644 index 0000000..0af62fc --- /dev/null +++ b/unix-compat.cabal @@ -0,0 +1,72 @@ +name: unix-compat +version: 0.5.0.1 +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. + +homepage: http://github.com/jystic/unix-compat +license: BSD3 +license-file: LICENSE +author: Björn Bringert, Duncan Coutts, Jacob Stanley, Bryan O'Sullivan +maintainer: Jacob Stanley +category: System +build-type: Simple +cabal-version: >= 1.6 + +source-repository head + type: git + location: git://github.com/jystic/unix-compat.git + +flag old-time + description: build against old-time package + default: False + +Library + hs-source-dirs: src + ghc-options: -Wall + build-depends: base == 4.* + + exposed-modules: + System.PosixCompat + System.PosixCompat.Extensions + System.PosixCompat.Files + System.PosixCompat.Temp + System.PosixCompat.Time + System.PosixCompat.Types + System.PosixCompat.Unistd + System.PosixCompat.User + + if os(windows) + c-sources: + cbits/HsUname.c + cbits/mktemp.c + + extra-libraries: msvcrt + build-depends: Win32 >= 2.5.0.0 + + if flag(old-time) + build-depends: old-time >= 1.0.0.0 && < 1.2.0.0 + cpp-options: -DOLD_TIME + + if impl(ghc < 7) + build-depends: directory == 1.0.* + cpp-options: -DDIRECTORY_1_0 + else + build-depends: directory == 1.1.* + else + build-depends: time >= 1.0 && < 1.9 + build-depends: directory >= 1.2 && < 1.4 + + other-modules: + System.PosixCompat.Internal.Time + + else + build-depends: unix >= 2.4 && < 2.8 + include-dirs: include + includes: HsUnixCompat.h + install-includes: HsUnixCompat.h + c-sources: cbits/HsUnixCompat.c + if os(solaris) + cc-options: -DSOLARIS