-- |
-- Module      :  Distribution.PackageDescription.Check.Paths
-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2023
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Functions to check filepaths, directories, globs, etc.
module Distribution.PackageDescription.Check.Paths
  ( checkGlob
  , checkPath
  , fileExtensionSupportedLanguage
  , isGoodRelativeDirectoryPath
  , isGoodRelativeFilePath
  , isGoodRelativeGlob
  , isInsideDist
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.PackageDescription.Check.Common
import Distribution.PackageDescription.Check.Monad
import Distribution.Simple.CCompiler
import Distribution.Simple.Glob
  ( Glob
  , explainGlobSyntaxError
  , isRecursiveInRoot
  , parseFileGlob
  )
import Distribution.Simple.Utils hiding (findPackageDesc, notice)
import System.FilePath (splitDirectories, splitPath, takeExtension)

import qualified System.FilePath.Windows as FilePath.Windows (isValid)

fileExtensionSupportedLanguage :: FilePath -> Bool
fileExtensionSupportedLanguage :: FilePath -> Bool
fileExtensionSupportedLanguage FilePath
path =
  Bool
isHaskell Bool -> Bool -> Bool
|| Bool
isC
  where
    extension :: FilePath
extension = FilePath -> FilePath
takeExtension FilePath
path
    isHaskell :: Bool
isHaskell = FilePath
extension FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".hs", FilePath
".lhs"]
    isC :: Bool
isC = Maybe (CDialect, Bool) -> Bool
forall a. Maybe a -> Bool
isJust (FilePath -> Maybe (CDialect, Bool)
filenameCDialect FilePath
extension)

-- Boolean: are absolute paths allowed?
checkPath
  :: Monad m
  => Bool -- Can be absolute path?
  -> CabalField -- .cabal field that we are checking.
  -> PathKind -- Path type.
  -> FilePath -- Path.
  -> CheckM m ()
checkPath :: forall (m :: * -> *).
Monad m =>
Bool -> FilePath -> PathKind -> FilePath -> CheckM m ()
checkPath Bool
isAbs FilePath
title PathKind
kind FilePath
path = do
  Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
    (FilePath -> Bool
isOutsideTree FilePath
path)
    (CheckExplanation -> PackageCheck
PackageBuildWarning (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> CheckExplanation
RelativeOutside FilePath
title FilePath
path)
  Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
    (FilePath -> Bool
isInsideDist FilePath
path)
    (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath -> CheckExplanation
DistPoint (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
title) FilePath
path)
  PathKind -> FilePath -> CheckM m ()
forall (m :: * -> *).
Monad m =>
PathKind -> FilePath -> CheckM m ()
checkPackageFileNamesWithGlob PathKind
kind FilePath
path

  -- Skip if "can be absolute path".
  Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
    (Bool -> Bool
not Bool
isAbs Bool -> Bool -> Bool
&& FilePath -> Bool
isAbsoluteOnAnyPlatform FilePath
path)
    (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> CheckExplanation
AbsolutePath FilePath
title FilePath
path)
  case FilePath -> PathKind -> Maybe FilePath
grl FilePath
path PathKind
kind of
    Just FilePath
e ->
      Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
        (Bool -> Bool
not Bool
isAbs)
        (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> CheckExplanation
BadRelativePath FilePath
title FilePath
path FilePath
e)
    Maybe FilePath
Nothing -> () -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool -> FilePath -> CheckM m ()
forall (m :: * -> *). Monad m => Bool -> FilePath -> CheckM m ()
checkWindowsPath (PathKind
kind PathKind -> PathKind -> Bool
forall a. Eq a => a -> a -> Bool
== PathKind
PathKindGlob) FilePath
path
  where
    isOutsideTree :: FilePath -> Bool
isOutsideTree FilePath
wpath = case FilePath -> [FilePath]
splitDirectories FilePath
wpath of
      FilePath
".." : [FilePath]
_ -> Bool
True
      FilePath
"." : FilePath
".." : [FilePath]
_ -> Bool
True
      [FilePath]
_ -> Bool
False

    -- These are not paths, but globs...
    grl :: FilePath -> PathKind -> Maybe FilePath
grl FilePath
wfp PathKind
PathKindFile = FilePath -> Maybe FilePath
isGoodRelativeFilePath FilePath
wfp
    grl FilePath
wfp PathKind
PathKindGlob = FilePath -> Maybe FilePath
isGoodRelativeGlob FilePath
wfp
    grl FilePath
wfp PathKind
PathKindDirectory = FilePath -> Maybe FilePath
isGoodRelativeDirectoryPath FilePath
wfp

-- | Is a 'FilePath' inside `dist`, `dist-newstyle` and friends?
isInsideDist :: FilePath -> Bool
isInsideDist :: FilePath -> Bool
isInsideDist FilePath
path =
  case (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
lowercase (FilePath -> [FilePath]
splitDirectories FilePath
path) of
    FilePath
"dist" : [FilePath]
_ -> Bool
True
    FilePath
"." : FilePath
"dist" : [FilePath]
_ -> Bool
True
    FilePath
"dist-newstyle" : [FilePath]
_ -> Bool
True
    FilePath
"." : FilePath
"dist-newstyle" : [FilePath]
_ -> Bool
True
    [FilePath]
_ -> Bool
False

checkPackageFileNamesWithGlob
  :: Monad m
  => PathKind
  -> FilePath -- Filepath or possibly a glob pattern.
  -> CheckM m ()
checkPackageFileNamesWithGlob :: forall (m :: * -> *).
Monad m =>
PathKind -> FilePath -> CheckM m ()
checkPackageFileNamesWithGlob PathKind
kind FilePath
fp = do
  Bool -> FilePath -> CheckM m ()
forall (m :: * -> *). Monad m => Bool -> FilePath -> CheckM m ()
checkWindowsPath (PathKind
kind PathKind -> PathKind -> Bool
forall a. Eq a => a -> a -> Bool
== PathKind
PathKindGlob) FilePath
fp
  FilePath -> CheckM m ()
forall (m :: * -> *). Monad m => FilePath -> CheckM m ()
checkTarPath FilePath
fp

checkWindowsPath
  :: Monad m
  => Bool -- Is it a glob pattern?
  -> FilePath -- Path.
  -> CheckM m ()
checkWindowsPath :: forall (m :: * -> *). Monad m => Bool -> FilePath -> CheckM m ()
checkWindowsPath Bool
isGlob FilePath
path =
  Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
    (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
FilePath.Windows.isValid (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> FilePath
escape Bool
isGlob FilePath
path)
    (CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$ [FilePath] -> CheckExplanation
InvalidOnWin [FilePath
path])
  where
    -- Force a relative name to catch invalid file names like "f:oo" which
    -- otherwise parse as file "oo" in the current directory on the 'f' drive.
    escape :: Bool -> String -> String
    escape :: Bool -> FilePath -> FilePath
escape Bool
wisGlob FilePath
wpath =
      (FilePath
".\\" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
      -- Glob paths will be expanded before being dereferenced, so asterisks
      -- shouldn't count against them.
      (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
        (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
&& Bool
wisGlob then Char
'x' else Char
c) FilePath
wpath

-- | Check a file name is valid for the portable POSIX tar format.
--
-- The POSIX tar format has a restriction on the length of file names. It is
-- unfortunately not a simple restriction like a maximum length. The exact
-- restriction is that either the whole path be 100 characters or less, or it
-- be possible to split the path on a directory separator such that the first
-- part is 155 characters or less and the second part 100 characters or less.
checkTarPath :: Monad m => FilePath -> CheckM m ()
checkTarPath :: forall (m :: * -> *). Monad m => FilePath -> CheckM m ()
checkTarPath FilePath
path
  | FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
path Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255 = PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP PackageCheck
longPath
  | Bool
otherwise = case Int -> [FilePath] -> Either PackageCheck [FilePath]
forall {t :: * -> *} {a}.
Foldable t =>
Int -> [t a] -> Either PackageCheck [t a]
pack Int
nameMax ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse (FilePath -> [FilePath]
splitPath FilePath
path)) of
      Left PackageCheck
err -> PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP PackageCheck
err
      Right [] -> () -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (FilePath
h : [FilePath]
rest) -> case Int -> [FilePath] -> Either PackageCheck [FilePath]
forall {t :: * -> *} {a}.
Foldable t =>
Int -> [t a] -> Either PackageCheck [t a]
pack Int
prefixMax [FilePath]
remainder of
        Left PackageCheck
err -> PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP PackageCheck
err
        Right [] -> () -> CheckM m ()
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Right (FilePath
_ : [FilePath]
_) -> PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP PackageCheck
noSplit
        where
          -- drop the '/' between the name and prefix:
          remainder :: [FilePath]
remainder = FilePath -> FilePath
forall a. [a] -> [a]
safeInit FilePath
h FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
rest
  where
    nameMax, prefixMax :: Int
    nameMax :: Int
nameMax = Int
100
    prefixMax :: Int
prefixMax = Int
155

    pack :: Int -> [t a] -> Either PackageCheck [t a]
pack Int
_ [] = PackageCheck -> Either PackageCheck [t a]
forall a b. a -> Either a b
Left PackageCheck
emptyName
    pack Int
maxLen (t a
c : [t a]
cs)
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLen = PackageCheck -> Either PackageCheck [t a]
forall a b. a -> Either a b
Left PackageCheck
longName
      | Bool
otherwise = [t a] -> Either PackageCheck [t a]
forall a b. b -> Either a b
Right (Int -> Int -> [t a] -> [t a]
forall {t :: * -> *} {a}.
Foldable t =>
Int -> Int -> [t a] -> [t a]
pack' Int
maxLen Int
n [t a]
cs)
      where
        n :: Int
n = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
c

    pack' :: Int -> Int -> [t a] -> [t a]
pack' Int
maxLen Int
n (t a
c : [t a]
cs)
      | Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxLen = Int -> Int -> [t a] -> [t a]
pack' Int
maxLen Int
n' [t a]
cs
      where
        n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
c
    pack' Int
_ Int
_ [t a]
cs = [t a]
cs

    longPath :: PackageCheck
longPath = CheckExplanation -> PackageCheck
PackageDistInexcusable (FilePath -> CheckExplanation
FilePathTooLong FilePath
path)
    longName :: PackageCheck
longName = CheckExplanation -> PackageCheck
PackageDistInexcusable (FilePath -> CheckExplanation
FilePathNameTooLong FilePath
path)
    noSplit :: PackageCheck
noSplit = CheckExplanation -> PackageCheck
PackageDistInexcusable (FilePath -> CheckExplanation
FilePathSplitTooLong FilePath
path)
    emptyName :: PackageCheck
emptyName = CheckExplanation -> PackageCheck
PackageDistInexcusable CheckExplanation
FilePathEmpty

-- `checkGlob` checks glob patterns and returns good ones for further
-- processing.
checkGlob
  :: Monad m
  => CabalField -- .cabal field we are checking.
  -> FilePath -- glob filepath pattern
  -> CheckM m (Maybe Glob)
checkGlob :: forall (m :: * -> *).
Monad m =>
FilePath -> FilePath -> CheckM m (Maybe Glob)
checkGlob FilePath
title FilePath
pat = do
  CabalSpecVersion
ver <- (CheckCtx m -> CabalSpecVersion) -> CheckM m CabalSpecVersion
forall (m :: * -> *) a. Monad m => (CheckCtx m -> a) -> CheckM m a
asksCM CheckCtx m -> CabalSpecVersion
forall (m :: * -> *). CheckCtx m -> CabalSpecVersion
ccSpecVersion

  -- Glob sanity check.
  case CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob
parseFileGlob CabalSpecVersion
ver FilePath
pat of
    Left GlobSyntaxError
e -> do
      PackageCheck -> CheckM m ()
forall (m :: * -> *). Monad m => PackageCheck -> CheckM m ()
tellP
        ( CheckExplanation -> PackageCheck
PackageDistInexcusable (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$
            FilePath -> FilePath -> CheckExplanation
GlobSyntaxError FilePath
title (FilePath -> GlobSyntaxError -> FilePath
explainGlobSyntaxError FilePath
pat GlobSyntaxError
e)
        )
      Maybe Glob -> CheckM m (Maybe Glob)
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Glob
forall a. Maybe a
Nothing
    Right Glob
wglob -> do
      -- \* Miscellaneous checks on sane glob.
      -- Checks for recursive glob in root.
      Bool -> PackageCheck -> CheckM m ()
forall (m :: * -> *).
Monad m =>
Bool -> PackageCheck -> CheckM m ()
checkP
        (Glob -> Bool
isRecursiveInRoot Glob
wglob)
        ( CheckExplanation -> PackageCheck
PackageDistSuspiciousWarn (CheckExplanation -> PackageCheck)
-> CheckExplanation -> PackageCheck
forall a b. (a -> b) -> a -> b
$
            FilePath -> FilePath -> CheckExplanation
RecursiveGlobInRoot FilePath
title FilePath
pat
        )
      Maybe Glob -> CheckM m (Maybe Glob)
forall a. a -> CheckM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Glob -> Maybe Glob
forall a. a -> Maybe a
Just Glob
wglob)

-- | Whether a path is a good relative path.  We aren't worried about perfect
-- cross-platform compatibility here; this function just checks the paths in
-- the (local) @.cabal@ file, while only Hackage needs the portability.
--
-- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp)
--
-- Note that "foo./bar.hs" would be invalid on Windows.
--
-- >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"]
-- Nothing; Nothing
-- Nothing; Nothing
-- Nothing; Nothing
--
-- Trailing slash is not allowed for files, for directories it is ok.
--
-- >>> test "foo/"
-- Nothing; Just "trailing slash"
--
-- Leading @./@ is fine, but @.@ and @./@ are not valid files.
--
-- >>> traverse_ test [".", "./", "./foo/bar"]
-- Nothing; Just "trailing dot segment"
-- Nothing; Just "trailing slash"
-- Nothing; Nothing
--
-- Lastly, not good file nor directory cases:
--
-- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"]
-- Just "empty path"; Just "empty path"
-- Just "posix absolute path"; Just "posix absolute path"
-- Just "empty path segment"; Just "empty path segment"
-- Just "trailing same directory segment: ."; Just "trailing same directory segment: ."
-- Just "same directory segment: ."; Just "same directory segment: ."
-- Just "parent directory segment: .."; Just "parent directory segment: .."
--
-- For the last case, 'isGoodRelativeGlob' doesn't warn:
--
-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"]
-- Just "parent directory segment: .."
isGoodRelativeFilePath :: FilePath -> Maybe String
isGoodRelativeFilePath :: FilePath -> Maybe FilePath
isGoodRelativeFilePath = FilePath -> Maybe FilePath
state0
  where
    -- initial state
    state0 :: FilePath -> Maybe FilePath
state0 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"empty path"
    state0 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state1 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"posix absolute path"
      | Bool
otherwise = FilePath -> Maybe FilePath
state5 FilePath
cs

    -- after initial .
    state1 :: FilePath -> Maybe FilePath
state1 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"trailing dot segment"
    state1 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state4 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
state2 FilePath
cs
      | Bool
otherwise = FilePath -> Maybe FilePath
state5 FilePath
cs

    -- after ./ or after / between segments
    state2 :: FilePath -> Maybe FilePath
state2 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"trailing slash"
    state2 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state3 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"empty path segment"
      | Bool
otherwise = FilePath -> Maybe FilePath
state5 FilePath
cs

    -- after non-first segment's .
    state3 :: FilePath -> Maybe FilePath
state3 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"trailing same directory segment: ."
    state3 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state4 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"same directory segment: ."
      | Bool
otherwise = FilePath -> Maybe FilePath
state5 FilePath
cs

    -- after ..
    state4 :: FilePath -> Maybe FilePath
state4 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"trailing parent directory segment: .."
    state4 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state5 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"parent directory segment: .."
      | Bool
otherwise = FilePath -> Maybe FilePath
state5 FilePath
cs

    -- in a segment which is ok.
    state5 :: FilePath -> Maybe FilePath
state5 [] = Maybe FilePath
forall a. Maybe a
Nothing
    state5 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state5 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
state2 FilePath
cs
      | Bool
otherwise = FilePath -> Maybe FilePath
state5 FilePath
cs

-- | See 'isGoodRelativeFilePath'.
--
-- This is barebones function. We check whether the glob is a valid file
-- by replacing stars @*@ with @x@ses.
isGoodRelativeGlob :: FilePath -> Maybe String
isGoodRelativeGlob :: FilePath -> Maybe FilePath
isGoodRelativeGlob = FilePath -> Maybe FilePath
isGoodRelativeFilePath (FilePath -> Maybe FilePath)
-> (FilePath -> FilePath) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f
  where
    f :: Char -> Char
f Char
'*' = Char
'x'
    f Char
c = Char
c

-- | See 'isGoodRelativeFilePath'.
isGoodRelativeDirectoryPath :: FilePath -> Maybe String
isGoodRelativeDirectoryPath :: FilePath -> Maybe FilePath
isGoodRelativeDirectoryPath = FilePath -> Maybe FilePath
state0
  where
    -- initial state
    state0 :: FilePath -> Maybe FilePath
state0 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"empty path"
    state0 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state5 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"posix absolute path"
      | Bool
otherwise = FilePath -> Maybe FilePath
state4 FilePath
cs

    -- after initial ./ or after / between segments
    state1 :: FilePath -> Maybe FilePath
state1 [] = Maybe FilePath
forall a. Maybe a
Nothing
    state1 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state2 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"empty path segment"
      | Bool
otherwise = FilePath -> Maybe FilePath
state4 FilePath
cs

    -- after non-first setgment's .
    state2 :: FilePath -> Maybe FilePath
state2 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"trailing same directory segment: ."
    state2 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state3 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"same directory segment: ."
      | Bool
otherwise = FilePath -> Maybe FilePath
state4 FilePath
cs

    -- after ..
    state3 :: FilePath -> Maybe FilePath
state3 [] = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"trailing parent directory segment: .."
    state3 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state4 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"parent directory segment: .."
      | Bool
otherwise = FilePath -> Maybe FilePath
state4 FilePath
cs

    -- in a segment which is ok.
    state4 :: FilePath -> Maybe FilePath
state4 [] = Maybe FilePath
forall a. Maybe a
Nothing
    state4 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state4 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
state1 FilePath
cs
      | Bool
otherwise = FilePath -> Maybe FilePath
state4 FilePath
cs

    -- after initial .
    state5 :: FilePath -> Maybe FilePath
state5 [] = Maybe FilePath
forall a. Maybe a
Nothing -- "."
    state5 (Char
c : FilePath
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = FilePath -> Maybe FilePath
state3 FilePath
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = FilePath -> Maybe FilePath
state1 FilePath
cs
      | Bool
otherwise = FilePath -> Maybe FilePath
state4 FilePath
cs

-- [Note: Good relative paths]
--
-- Using @kleene@ we can define an extended regex:
--
-- @
-- import Algebra.Lattice
-- import Kleene
-- import Kleene.ERE (ERE (..), intersections)
--
-- data C = CDot | CSlash | CChar
--   deriving (Eq, Ord, Enum, Bounded, Show)
--
-- reservedR :: ERE C
-- reservedR = notChar CSlash
--
-- pathPieceR :: ERE C
-- pathPieceR = intersections
--     [ plus reservedR
--     , ERENot (string [CDot])
--     , ERENot (string [CDot,CDot])
--     ]
--
-- filePathR :: ERE C
-- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR)
--
-- dirPathR :: ERE C
-- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash)
--
-- plus :: ERE C -> ERE C
-- plus r = r <> star r
--
-- optional :: ERE C -> ERE C
-- optional r = mempty \/ r
-- @
--
-- Results in following state machine for @filePathR@
--
-- @
-- 0 -> \x -> if
--     | x <= CDot           -> 1
--     | otherwise           -> 5
-- 1 -> \x -> if
--     | x <= CDot           -> 4
--     | x <= CSlash         -> 2
--     | otherwise           -> 5
-- 2 -> \x -> if
--     | x <= CDot           -> 3
--     | otherwise           -> 5
-- 3 -> \x -> if
--     | x <= CDot           -> 4
--     | otherwise           -> 5
-- 4 -> \x -> if
--     | x <= CDot           -> 5
--     | otherwise           -> 5
-- 5+ -> \x -> if
--     | x <= CDot           -> 5
--     | x <= CSlash         -> 2
--     | otherwise           -> 5
-- @
--
-- and @dirPathR@:
--
-- @
-- 0 -> \x -> if
--     | x <= CDot           -> 5
--     | otherwise           -> 4
-- 1+ -> \x -> if
--     | x <= CDot           -> 2
--     | otherwise           -> 4
-- 2 -> \x -> if
--     | x <= CDot           -> 3
--     | otherwise           -> 4
-- 3 -> \x -> if
--     | x <= CDot           -> 4
--     | otherwise           -> 4
-- 4+ -> \x -> if
--     | x <= CDot           -> 4
--     | x <= CSlash         -> 1
--     | otherwise           -> 4
-- 5+ -> \x -> if
--     | x <= CDot           -> 3
--     | x <= CSlash         -> 1
--     | otherwise           -> 4
-- @