Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • bgamari/cabal-build-test
  • samuela/cabal-build-test
  • emilypi/cabal-build-test
3 results
Show changes
Showing
with 0 additions and 2448 deletions
{-# LANGUAGE CPP #-}
module Distribution.Compat.Directory
( listDirectory
, makeAbsolute
, doesPathExist
) where
#if MIN_VERSION_directory(1,2,7)
import System.Directory as Dir hiding (doesPathExist)
import System.Directory (doesPathExist)
#else
import System.Directory as Dir
#endif
#if !MIN_VERSION_directory(1,2,2)
import System.FilePath as Path
#endif
#if !MIN_VERSION_directory(1,2,5)
listDirectory :: FilePath -> IO [FilePath]
listDirectory path =
filter f `fmap` Dir.getDirectoryContents path
where f filename = filename /= "." && filename /= ".."
#endif
#if !MIN_VERSION_directory(1,2,2)
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p | Path.isAbsolute p = return p
| otherwise = do
cwd <- Dir.getCurrentDirectory
return $ cwd </> p
#endif
#if !MIN_VERSION_directory(1,2,7)
doesPathExist :: FilePath -> IO Bool
doesPathExist path = do
-- not using Applicative, as this way we can do less IO
e <- doesDirectoryExist path
if e
then return True
else doesFileExist path
#endif
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.Environment
( getEnvironment, lookupEnv, setEnv, unsetEnv )
where
import Prelude ()
import qualified Prelude
import Distribution.Compat.Prelude
#ifndef mingw32_HOST_OS
#if __GLASGOW_HASKELL__ < 708
import Foreign.C.Error (throwErrnoIf_)
#endif
#endif
import qualified System.Environment as System
import System.Environment (lookupEnv)
#if __GLASGOW_HASKELL__ >= 708
import System.Environment (unsetEnv)
#endif
import Distribution.Compat.Stack
#ifdef mingw32_HOST_OS
import Foreign.C
#if __GLASGOW_HASKELL__ < 708
import Foreign.Ptr (nullPtr)
#endif
import GHC.Windows
#else
import Foreign.C.Types
import Foreign.C.String
import Foreign.C.Error (throwErrnoIfMinus1_)
import System.Posix.Internals ( withFilePath )
#endif /* mingw32_HOST_OS */
getEnvironment :: IO [(String, String)]
#ifdef mingw32_HOST_OS
-- On Windows, the names of environment variables are case-insensitive, but are
-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise
-- them.
getEnvironment = fmap upcaseVars System.getEnvironment
where
upcaseVars = map upcaseVar
upcaseVar (var, val) = (map toUpper var, val)
#else
getEnvironment = System.getEnvironment
#endif
-- | @setEnv name value@ sets the specified environment variable to @value@.
--
-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the
-- empty string or contains an equals sign.
setEnv :: String -> String -> IO ()
setEnv key value_ = setEnv_ key value
where
-- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We
-- still strip it manually so that the null check above succeeds if a value
-- starts with NUL.
value = takeWhile (/= '\NUL') value_
setEnv_ :: String -> String -> IO ()
#ifdef mingw32_HOST_OS
setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
success <- c_SetEnvironmentVariable k v
unless success (throwGetLastError "setEnv")
where
_ = callStack -- TODO: attach CallStack to exception
# if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
# else
# error Unknown mingw32 arch
# endif /* i386_HOST_ARCH */
foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool
#else
setEnv_ key value = do
withFilePath key $ \ keyP ->
withFilePath value $ \ valueP ->
throwErrnoIfMinus1_ "setenv" $
c_setenv keyP valueP (fromIntegral (fromEnum True))
where
_ = callStack -- TODO: attach CallStack to exception
foreign import ccall unsafe "setenv"
c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt
#endif /* mingw32_HOST_OS */
#if __GLASGOW_HASKELL__ < 708
-- | @unsetEnv name@ removes the specified environment variable from the
-- environment of the current process.
--
-- Throws `Control.Exception.IOException` if @name@ is the empty string or
-- contains an equals sign.
--
-- @since 4.7.0.0
unsetEnv :: String -> IO ()
#ifdef mingw32_HOST_OS
unsetEnv key = withCWString key $ \k -> do
success <- c_SetEnvironmentVariable k nullPtr
unless success $ do
-- We consider unsetting an environment variable that does not exist not as
-- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
err <- c_GetLastError
unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
throwGetLastError "unsetEnv"
eRROR_ENVVAR_NOT_FOUND :: DWORD
eRROR_ENVVAR_NOT_FOUND = 203
foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
c_GetLastError:: IO DWORD
#else
unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
#if __GLASGOW_HASKELL__ > 706
foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt
#else
-- HACK: We hope very hard that !UNSETENV_RETURNS_VOID
foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt
#endif
#endif
#endif
{-# LANGUAGE CPP #-}
module Distribution.Compat.Exception (
catchIO,
catchExit,
tryIO,
displayException,
) where
import System.Exit
import qualified Control.Exception as Exception
#if __GLASGOW_HASKELL__ >= 710
import Control.Exception (displayException)
#endif
tryIO :: IO a -> IO (Either Exception.IOException a)
tryIO = Exception.try
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
catchIO = Exception.catch
catchExit :: IO a -> (ExitCode -> IO a) -> IO a
catchExit = Exception.catch
#if __GLASGOW_HASKELL__ < 710
displayException :: Exception.Exception e => e -> String
displayException = show
#endif
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Distribution.Compat.FilePath
( isExtensionOf
, stripExtension
) where
import Data.List ( isSuffixOf, stripPrefix )
import System.FilePath
#if !MIN_VERSION_filepath(1,4,2)
isExtensionOf :: String -> FilePath -> Bool
isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions
isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions
#endif
#if !MIN_VERSION_filepath(1,4,1)
stripExtension :: String -> FilePath -> Maybe FilePath
stripExtension [] path = Just path
stripExtension ext@(x:_) path = stripSuffix dotExt path
where
dotExt = if isExtSeparator x then ext else '.':ext
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)
#endif
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.GetShortPathName
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : Windows-only
--
-- Win32 API 'GetShortPathName' function.
module Distribution.Compat.GetShortPathName ( getShortPathName )
where
import Prelude ()
import Distribution.Compat.Prelude
#ifdef mingw32_HOST_OS
import qualified Prelude
import qualified System.Win32 as Win32
import System.Win32 (LPCTSTR, LPTSTR, DWORD)
import Foreign.Marshal.Array (allocaArray)
#ifdef x86_64_HOST_ARCH
#define WINAPI ccall
#else
#define WINAPI stdcall
#endif
foreign import WINAPI unsafe "windows.h GetShortPathNameW"
c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD
-- | On Windows, retrieves the short path form of the specified path. On
-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185.
--
-- From MS's GetShortPathName docs:
--
-- Passing NULL for [the second] parameter and zero for cchBuffer
-- will always return the required buffer size for a
-- specified lpszLongPath.
--
getShortPathName :: FilePath -> IO FilePath
getShortPathName path =
Win32.withTString path $ \c_path -> do
c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $
c_GetShortPathName c_path Win32.nullPtr 0
let arr_len = fromIntegral c_len
allocaArray arr_len $ \c_out -> do
void $ Win32.failIfZero "GetShortPathName #2 failed!" $
c_GetShortPathName c_path c_out c_len
Win32.peekTString c_out
#else
getShortPathName :: FilePath -> IO FilePath
getShortPathName path = return path
#endif
This diff is collapsed.
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.Internal.TempFile (
openTempFile,
openBinaryTempFile,
openNewBinaryFile,
createTempDirectory,
) where
import Distribution.Compat.Exception
import System.FilePath ((</>))
import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError)
import System.IO (Handle, openTempFile, openBinaryTempFile)
import Data.Bits ((.|.))
import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
o_BINARY, o_NONBLOCK, o_NOCTTY,
withFilePath, c_getpid)
import System.IO.Error (isAlreadyExistsError)
import GHC.IO.Handle.FD (fdToHandle)
import Control.Exception (onException)
#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
import System.Directory ( createDirectory )
#else
import qualified System.Posix
#endif
-- ------------------------------------------------------------
-- * temporary files
-- ------------------------------------------------------------
-- This is here for Haskell implementations that do not come with
-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
-- TODO: This file should probably be removed.
-- This is a copy/paste of the openBinaryTempFile definition, but
-- if uses 666 rather than 600 for the permissions. The base library
-- needs to be changed to make this better.
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile dir template = do
pid <- c_getpid
findTempName pid
where
-- We split off the last extension, so we can use .foo.ext files
-- for temporary files (hidden on Unix OSes). Unfortunately we're
-- below file path in the hierarchy here.
(prefix,suffix) =
case break (== '.') $ reverse template of
-- First case: template contains no '.'s. Just re-reverse it.
(rev_suffix, "") -> (reverse rev_suffix, "")
-- Second case: template contains at least one '.'. Strip the
-- dot from the prefix and prepend it to the suffix (if we don't
-- do this, the unique number will get added after the '.' and
-- thus be part of the extension, which is wrong.)
(rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
-- Otherwise, something is wrong, because (break (== '.')) should
-- always return a pair with either the empty string or a string
-- beginning with '.' as the second component.
_ -> error "bug in System.IO.openTempFile"
oflags = rw_flags .|. o_EXCL .|. o_BINARY
findTempName x = do
fd <- withFilePath filepath $ \ f ->
c_open f oflags 0o666
if fd < 0
then do
errno <- getErrno
if errno == eEXIST
then findTempName (x+1)
else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
else do
-- TODO: We want to tell fdToHandle what the file path is,
-- as any exceptions etc will only be able to report the
-- FD currently
h <- fdToHandle fd `onException` c_close fd
return (filepath, h)
where
filename = prefix ++ show x ++ suffix
filepath = dir `combine` filename
-- FIXME: bits copied from System.FilePath
combine a b
| null b = a
| null a = b
| last a == pathSeparator = a ++ b
| otherwise = a ++ [pathSeparator] ++ b
-- FIXME: Should use System.FilePath library
pathSeparator :: Char
#ifdef mingw32_HOST_OS
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
-- FIXME: Copied from GHC.Handle
std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
rw_flags = output_flags .|. o_RDWR
createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory dir template = do
pid <- c_getpid
findTempName pid
where
findTempName x = do
let dirpath = dir </> template ++ "-" ++ show x
r <- tryIO $ mkPrivateDir dirpath
case r of
Right _ -> return dirpath
Left e | isAlreadyExistsError e -> findTempName (x+1)
| otherwise -> ioError e
mkPrivateDir :: String -> IO ()
#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
mkPrivateDir s = createDirectory s
#else
mkPrivateDir s = System.Posix.createDirectory s 0o700
#endif
This diff is collapsed.
{-# LANGUAGE CPP #-}
-- | Compatibility layer for "Control.Monad.Fail"
module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where
import Control.Monad.Fail
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
-- | This module re-exports the non-exposed
-- "Distribution.Compat.Prelude" module for
-- reuse by @cabal-install@'s
-- "Distribution.Client.Compat.Prelude" module.
--
-- It is highly discouraged to rely on this module
-- for @Setup.hs@ scripts since its API is /not/
-- stable.
module Distribution.Compat.Prelude.Internal
{-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}
( module Distribution.Compat.Prelude
) where
import Distribution.Compat.Prelude
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.