-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-|
Module      : CabalHelper.Compiletime.Types.RelativePath
License     : Apache-2.0
-}

module CabalHelper.Compiletime.Types.RelativePath
    ( RelativePath
    , mkRelativePath
    , unRelativePath
    ) where

import System.FilePath

-- | A path guaranteed to be relative and not escape the base path. The
-- constructor is not exposed, use the 'mkRelativePath' smart constructor.
newtype RelativePath = RelativePath { RelativePath -> FilePath
unRelativePath :: FilePath }
    deriving (Int -> RelativePath -> ShowS
[RelativePath] -> ShowS
RelativePath -> FilePath
(Int -> RelativePath -> ShowS)
-> (RelativePath -> FilePath)
-> ([RelativePath] -> ShowS)
-> Show RelativePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RelativePath] -> ShowS
$cshowList :: [RelativePath] -> ShowS
show :: RelativePath -> FilePath
$cshow :: RelativePath -> FilePath
showsPrec :: Int -> RelativePath -> ShowS
$cshowsPrec :: Int -> RelativePath -> ShowS
Show)

-- | Smart constructor for 'RelativePath'. Checks if the given path
-- satisfies the constraints and throws 'UserError' if not.
mkRelativePath :: FilePath -> RelativePath
mkRelativePath :: FilePath -> RelativePath
mkRelativePath FilePath
dir
  | FilePath -> Bool
isAbsolute FilePath
dir =
    FilePath -> RelativePath
forall a. HasCallStack => FilePath -> a
error (FilePath -> RelativePath) -> FilePath -> RelativePath
forall a b. (a -> b) -> a -> b
$ FilePath
"mkRelativePath: the path given was absolute! got: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dir
  | FilePath -> Bool
doesRelativePathEscapeCWD FilePath
dir =
    FilePath -> RelativePath
forall a. HasCallStack => FilePath -> a
error (FilePath -> RelativePath) -> FilePath -> RelativePath
forall a b. (a -> b) -> a -> b
$ FilePath
"mkRelativePath: the path given escapes the base dir! got: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dir
  | Bool
otherwise =
    FilePath -> RelativePath
RelativePath FilePath
dir

doesRelativePathEscapeCWD :: FilePath -> Bool
doesRelativePathEscapeCWD :: FilePath -> Bool
doesRelativePathEscapeCWD FilePath
path =
    [FilePath] -> [FilePath] -> Bool
go [] ([FilePath] -> Bool) -> [FilePath] -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ShowS
normalise FilePath
path
       -- normalise collapses '.' in path, this is very important or this
       -- check would be traivial to defeat. For example './../' would be
       -- able to escape.
  where
    go :: [FilePath] -> [FilePath] -> Bool
go (FilePath
_:[FilePath]
xs) (FilePath
"..":[FilePath]
ys) = [FilePath] -> [FilePath] -> Bool
go [FilePath]
xs [FilePath]
ys
    go    []  (FilePath
"..":[FilePath]
__) = Bool
True
    go    [FilePath]
xs  (FilePath
y   :[FilePath]
ys) = [FilePath] -> [FilePath] -> Bool
go (FilePath
yFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
xs) [FilePath]
ys
    go    [FilePath]
_         []  = Bool
False