System/Directory/Internal/Common.hs

    module System.Directory.Internal.Common where
    import Prelude ()
    import System.Directory.Internal.Prelude
    import System.FilePath
      ( addTrailingPathSeparator
      , hasTrailingPathSeparator
      , isPathSeparator
      , isRelative
      , joinDrive
      , joinPath
      , normalise
      , pathSeparator
      , pathSeparators
      , splitDirectories
      , splitDrive
      )

    -- | A generator with side-effects.
    newtype ListT m a = ListT { unListT :: m (Maybe (a, ListT m a)) }

    emptyListT :: Applicative m => ListT m a
    emptyListT = ListT (pure Nothing)

    maybeToListT :: Applicative m => m (Maybe a) -> ListT m a
    maybeToListT m = ListT (((\ x -> (x, emptyListT)) <$>) <$> m)

    listToListT :: Applicative m => [a] -> ListT m a
    listToListT [] = emptyListT
    listToListT (x : xs) = ListT (pure (Just (x, listToListT xs)))

    liftJoinListT :: Monad m => m (ListT m a) -> ListT m a
    liftJoinListT m = ListT (m >>= unListT)

    listTHead :: Functor m => ListT m a -> m (Maybe a)
    listTHead (ListT m) = (fst <$>) <$> m

    listTToList :: Monad m => ListT m a -> m [a]
    listTToList (ListT m) = do
      mx <- m
      case mx of
        Nothing -> return []
        Just (x, m') -> do
          xs <- listTToList m'
          return (x : xs)

    andM :: Monad m => m Bool -> m Bool -> m Bool
    andM mx my = do
      x <- mx
      if x
        then my
        else return x

    sequenceWithIOErrors_ :: [IO ()] -> IO ()
    sequenceWithIOErrors_ actions = go (Right ()) actions
      where

        go :: Either IOError () -> [IO ()] -> IO ()
        go (Left e)   []       = ioError e
        go (Right ()) []       = pure ()
        go s          (m : ms) = s `seq` do
          r <- tryIOError m
          go (thenEither s r) ms

        -- equivalent to (*>) for Either, defined here to retain compatibility
        -- with base prior to 4.3
        thenEither :: Either b a -> Either b a -> Either b a
        thenEither x@(Left _) _ = x
        thenEither _          y = y

    -- | Similar to 'try' but only catches a specify kind of 'IOError' as
    --   specified by the predicate.
    tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a)
    tryIOErrorType check action = do
      result <- tryIOError action
      case result of
        Left  err -> if check err then pure (Left err) else throwIO err
        Right val -> pure (Right val)

    -- | Attempt to perform the given action, silencing any IO exception thrown by
    -- it.
    ignoreIOExceptions :: IO () -> IO ()
    ignoreIOExceptions io = io `catchIOError` (\_ -> pure ())

    specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a
    specializeErrorString str errType action = do
      mx <- tryIOErrorType errType action
      case mx of
        Left  e -> throwIO (ioeSetErrorString e str)
        Right x -> pure x

    ioeAddLocation :: IOError -> String -> IOError
    ioeAddLocation e loc = do
      ioeSetLocation e newLoc
      where
        newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
        oldLoc = ioeGetLocation e

    -- | Given a list of path segments, expand @.@ and @..@.  The path segments
    -- must not contain path separators.
    expandDots :: [FilePath] -> [FilePath]
    expandDots = reverse . go []
      where
        go ys' xs' =
          case xs' of
            [] -> ys'
            x : xs ->
              case x of
                "." -> go ys' xs
                ".." ->
                  case ys' of
                    [] -> go (x : ys') xs
                    ".." : _ -> go (x : ys') xs
                    _ : ys -> go ys xs
                _ -> go (x : ys') xs

    -- | Convert to the right kind of slashes.
    normalisePathSeps :: FilePath -> FilePath
    normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p

    -- | Remove redundant trailing slashes and pick the right kind of slash.
    normaliseTrailingSep :: FilePath -> FilePath
    normaliseTrailingSep path = do
      let path' = reverse path
      let (sep, path'') = span isPathSeparator path'
      let addSep = if null sep then id else (pathSeparator :)
      reverse (addSep path'')

    -- | Convert empty paths to the current directory, otherwise leave it
    -- unchanged.
    emptyToCurDir :: FilePath -> FilePath
    emptyToCurDir ""   = "."
    emptyToCurDir path = path

    -- | Similar to 'normalise' but empty paths stay empty.
    simplifyPosix :: FilePath -> FilePath
    simplifyPosix ""   = ""
    simplifyPosix path = normalise path

    -- | Similar to 'normalise' but:
    --
    -- * empty paths stay empty,
    -- * parent dirs (@..@) are expanded, and
    -- * paths starting with @\\\\?\\@ are preserved.
    --
    -- The goal is to preserve the meaning of paths better than 'normalise'.
    simplifyWindows :: FilePath -> FilePath
    simplifyWindows "" = ""
    simplifyWindows path =
      case drive' of
        "\\\\?\\" -> drive' <> subpath
        _ -> simplifiedPath
      where
        simplifiedPath = joinDrive drive' subpath'
        (drive, subpath) = splitDrive path
        drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
        subpath' = appendSep . avoidEmpty . prependSep . joinPath .
                   stripPardirs . expandDots . skipSeps .
                   splitDirectories $ subpath

        upperDrive d = case d of
          c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s
          _ -> d
        skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
        stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
                     | otherwise = id
        prependSep | subpathIsAbsolute = (pathSeparator :)
                   | otherwise = id
        avoidEmpty | not pathIsAbsolute
                     && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
                     = emptyToCurDir
                   | otherwise = id
        appendSep p | hasTrailingPathSep
                      && not (pathIsAbsolute && null p)
                      = addTrailingPathSeparator p
                    | otherwise = p
        pathIsAbsolute = not (isRelative path)
        subpathIsAbsolute = any isPathSeparator (take 1 subpath)
        hasTrailingPathSep = hasTrailingPathSeparator subpath

    data FileType = File
                  | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link
                  | Directory
                  | DirectoryLink -- ^ Windows only: directory link
                  deriving (Bounded, Enum, Eq, Ord, Read, Show)

    -- | Check whether the given 'FileType' is considered a directory by the
    -- operating system.  This affects the choice of certain functions
    -- e.g. 'System.Directory.removeDirectory' vs 'System.Directory.removeFile'.
    fileTypeIsDirectory :: FileType -> Bool
    fileTypeIsDirectory Directory     = True
    fileTypeIsDirectory DirectoryLink = True
    fileTypeIsDirectory _             = False

    -- | Return whether the given 'FileType' is a link.
    fileTypeIsLink :: FileType -> Bool
    fileTypeIsLink SymbolicLink  = True
    fileTypeIsLink DirectoryLink = True
    fileTypeIsLink _             = False

    data Permissions
      = Permissions
      { readable :: Bool
      , writable :: Bool
      , executable :: Bool
      , searchable :: Bool
      } deriving (Eq, Ord, Read, Show)

    -- | Truncate the destination file and then copy the contents of the source
    -- file to the destination file.  If the destination file already exists, its
    -- attributes shall remain unchanged.  Otherwise, its attributes are reset to
    -- the defaults.
    copyFileContents :: FilePath            -- ^ Source filename
                     -> FilePath            -- ^ Destination filename
                     -> IO ()
    copyFileContents fromFPath toFPath =
      (`ioeAddLocation` "copyFileContents") `modifyIOError` do
        withBinaryFile toFPath WriteMode $ \ hTo ->
          copyFileToHandle fromFPath hTo

    -- | Copy all data from a file to a handle.
    copyFileToHandle :: FilePath            -- ^ Source file
                     -> Handle              -- ^ Destination handle
                     -> IO ()
    copyFileToHandle fromFPath hTo =
      (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do
        withBinaryFile fromFPath ReadMode $ \ hFrom ->
          copyHandleData hFrom hTo

    -- | Copy data from one handle to another until end of file.
    copyHandleData :: Handle                -- ^ Source handle
                   -> Handle                -- ^ Destination handle
                   -> IO ()
    copyHandleData hFrom hTo =
      (`ioeAddLocation` "copyData") `modifyIOError` do
        allocaBytes bufferSize go
      where
        bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)
        go buffer = do
          count <- hGetBuf hFrom buffer bufferSize
          when (count > 0) $ do
            hPutBuf hTo buffer count
            go buffer

    -- | Special directories for storing user-specific application data,
    -- configuration, and cache files, as specified by the
    -- <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
    --
    -- Note: On Windows, 'XdgData' and 'XdgConfig' usually map to the same
    -- directory.
    --
    -- @since 1.2.3.0
    data XdgDirectory
      = XdgData
        -- ^ For data files (e.g. images).
        -- It uses the @XDG_DATA_HOME@ environment variable.
        -- On non-Windows systems, the default is @~\/.local\/share@.
        -- On Windows, the default is @%APPDATA%@
        -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
        -- Can be considered as the user-specific equivalent of @\/usr\/share@.
      | XdgConfig
        -- ^ For configuration files.
        -- It uses the @XDG_CONFIG_HOME@ environment variable.
        -- On non-Windows systems, the default is @~\/.config@.
        -- On Windows, the default is @%APPDATA%@
        -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
        -- Can be considered as the user-specific equivalent of @\/etc@.
      | XdgCache
        -- ^ For non-essential files (e.g. cache).
        -- It uses the @XDG_CACHE_HOME@ environment variable.
        -- On non-Windows systems, the default is @~\/.cache@.
        -- On Windows, the default is @%LOCALAPPDATA%@
        -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@).
        -- Can be considered as the user-specific equivalent of @\/var\/cache@.
      deriving (Bounded, Enum, Eq, Ord, Read, Show)

    -- | Search paths for various application data, as specified by the
    -- <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
    --
    -- The list of paths is split using 'System.FilePath.searchPathSeparator',
    -- which on Windows is a semicolon.
    --
    -- Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' usually yield the same
    -- result.
    --
    -- @since 1.3.2.0
    data XdgDirectoryList
      = XdgDataDirs
        -- ^ For data files (e.g. images).
        -- It uses the @XDG_DATA_DIRS@ environment variable.
        -- On non-Windows systems, the default is @\/usr\/local\/share\/@ and
        -- @\/usr\/share\/@.
        -- On Windows, the default is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
        -- (e.g. @C:\/ProgramData@).
      | XdgConfigDirs
        -- ^ For configuration files.
        -- It uses the @XDG_CONFIG_DIRS@ environment variable.
        -- On non-Windows systems, the default is @\/etc\/xdg@.
        -- On Windows, the default is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
        -- (e.g. @C:\/ProgramData@).
      deriving (Bounded, Enum, Eq, Ord, Read, Show)