-- |
-- Module      :  HPath
-- Copyright   :  © 2015–2016 FP Complete, 2016 Julian Ospald
-- License     :  BSD 3 clause
--
-- Maintainer  :  Julian Ospald <hasufell@posteo.de>
-- Stability   :  experimental
-- Portability :  portable
--
-- Support for well-typed paths.


{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE PatternSynonyms #-}
#endif

module HPath
  (
  -- * Types
   Abs
  ,Path
  ,Rel
  ,Fn
  ,PathParseException
  ,PathException
  ,RelC
#if __GLASGOW_HASKELL__ >= 708
  -- * PatternSynonyms/ViewPatterns
  ,pattern Path
#endif
   -- * Path Parsing
  ,parseAbs
  ,parseFn
  ,parseRel
  -- * Path Conversion
  ,fromAbs
  ,fromRel
  ,toFilePath
  -- * Path Operations
  ,(</>)
  ,basename
  ,dirname
  ,isParentOf
  ,getAllParents
  ,stripDir
  -- * Path IO helpers
  ,withAbsPath
  ,withRelPath
  ,withFnPath
  )
  where

import           Control.Exception (Exception)
import           Control.Monad.Catch (MonadThrow(..))
#if MIN_VERSION_bytestring(0,10,8)
import           Data.ByteString(ByteString, stripPrefix)
#else
import           Data.ByteString(ByteString)
import qualified Data.List as L
#endif
import qualified Data.ByteString as BS
import           Data.Data
import           Data.Maybe
import           Data.Word8
import           HPath.Internal
import           System.Posix.FilePath hiding ((</>))


--------------------------------------------------------------------------------
-- Types

-- | An absolute path.
data Abs deriving (Typeable)

-- | A relative path; one without a root.
data Rel deriving (Typeable)

-- | A filename, without any '/'.
data Fn deriving (Typeable)

-- | Exception when parsing a location.
data PathParseException
  = InvalidAbs ByteString
  | InvalidRel ByteString
  | InvalidFn ByteString
  | Couldn'tStripPrefixTPS ByteString ByteString
  deriving (Int -> PathParseException -> ShowS
[PathParseException] -> ShowS
PathParseException -> String
(Int -> PathParseException -> ShowS)
-> (PathParseException -> String)
-> ([PathParseException] -> ShowS)
-> Show PathParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathParseException] -> ShowS
$cshowList :: [PathParseException] -> ShowS
show :: PathParseException -> String
$cshow :: PathParseException -> String
showsPrec :: Int -> PathParseException -> ShowS
$cshowsPrec :: Int -> PathParseException -> ShowS
Show,Typeable)
instance Exception PathParseException

data PathException = RootDirHasNoBasename
  deriving (Int -> PathException -> ShowS
[PathException] -> ShowS
PathException -> String
(Int -> PathException -> ShowS)
-> (PathException -> String)
-> ([PathException] -> ShowS)
-> Show PathException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathException] -> ShowS
$cshowList :: [PathException] -> ShowS
show :: PathException -> String
$cshow :: PathException -> String
showsPrec :: Int -> PathException -> ShowS
$cshowsPrec :: Int -> PathException -> ShowS
Show,Typeable)
instance Exception PathException

class RelC m

instance RelC Rel
instance RelC Fn

--------------------------------------------------------------------------------
-- PatternSynonyms

#if __GLASGOW_HASKELL__ >= 710
pattern Path :: ByteString -> Path a
#endif
#if __GLASGOW_HASKELL__ >= 708
pattern $mPath :: forall r a. Path a -> (ByteString -> r) -> (Void# -> r) -> r
Path x <- (MkPath x)
#endif

--------------------------------------------------------------------------------
-- Path Parsers



-- | Get a location for an absolute path. Produces a normalised path.
--
-- Throws: 'PathParseException'
--
-- >>> parseAbs "/abc"          :: Maybe (Path Abs)
-- Just "/abc"
-- >>> parseAbs "/"             :: Maybe (Path Abs)
-- Just "/"
-- >>> parseAbs "/abc/def"      :: Maybe (Path Abs)
-- Just "/abc/def"
-- >>> parseAbs "/abc/def/.///" :: Maybe (Path Abs)
-- Just "/abc/def/"
-- >>> parseAbs "abc"           :: Maybe (Path Abs)
-- Nothing
-- >>> parseAbs ""              :: Maybe (Path Abs)
-- Nothing
-- >>> parseAbs "/abc/../foo"   :: Maybe (Path Abs)
-- Nothing
parseAbs :: MonadThrow m
         => ByteString -> m (Path Abs)
parseAbs :: ByteString -> m (Path Abs)
parseAbs filepath :: ByteString
filepath =
  if ByteString -> Bool
isAbsolute ByteString
filepath Bool -> Bool -> Bool
&&
     ByteString -> Bool
isValid ByteString
filepath Bool -> Bool -> Bool
&&
     Bool -> Bool
not (ByteString -> Bool
hasParentDir ByteString
filepath)
     then Path Abs -> m (Path Abs)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath (ByteString -> Path Abs) -> ByteString -> Path Abs
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
normalise ByteString
filepath)
     else PathParseException -> m (Path Abs)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> PathParseException
InvalidAbs ByteString
filepath)


-- | Get a location for a relative path. Produces a normalised
-- path.
--
-- Note that @filepath@ may contain any number of @./@ but may not consist
-- solely of @./@.  It also may not contain a single @..@ anywhere.
--
-- Throws: 'PathParseException'
--
-- >>> parseRel "abc"        :: Maybe (Path Rel)
-- Just "abc"
-- >>> parseRel "def/"       :: Maybe (Path Rel)
-- Just "def/"
-- >>> parseRel "abc/def"    :: Maybe (Path Rel)
-- Just "abc/def"
-- >>> parseRel "abc/def/."  :: Maybe (Path Rel)
-- Just "abc/def/"
-- >>> parseRel "/abc"       :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel ""           :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel "abc/../foo" :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel "."          :: Maybe (Path Rel)
-- Nothing
-- >>> parseRel ".."         :: Maybe (Path Rel)
-- Nothing
parseRel :: MonadThrow m
         => ByteString -> m (Path Rel)
parseRel :: ByteString -> m (Path Rel)
parseRel filepath :: ByteString
filepath =
  if Bool -> Bool
not (ByteString -> Bool
isAbsolute ByteString
filepath) Bool -> Bool -> Bool
&&
     ByteString
filepath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8 -> ByteString
BS.singleton Word8
_period Bool -> Bool -> Bool
&&
     ByteString
filepath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= [Word8] -> ByteString
BS.pack [Word8
_period, Word8
_period] Bool -> Bool -> Bool
&&
     Bool -> Bool
not (ByteString -> Bool
hasParentDir ByteString
filepath) Bool -> Bool -> Bool
&&
     ByteString -> Bool
isValid ByteString
filepath
     then Path Rel -> m (Path Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath (ByteString -> Path Rel) -> ByteString -> Path Rel
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
normalise ByteString
filepath)
     else PathParseException -> m (Path Rel)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> PathParseException
InvalidRel ByteString
filepath)


-- | Parses a filename. Filenames must not contain slashes.
-- Excludes '.' and '..'.
--
-- Throws: 'PathParseException'
--
-- >>> parseFn "abc"        :: Maybe (Path Fn)
-- Just "abc"
-- >>> parseFn "..."        :: Maybe (Path Fn)
-- Just "..."
-- >>> parseFn "def/"       :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "abc/def"    :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "abc/def/."  :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "/abc"       :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn ""           :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "abc/../foo" :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn "."          :: Maybe (Path Fn)
-- Nothing
-- >>> parseFn ".."         :: Maybe (Path Fn)
-- Nothing
parseFn :: MonadThrow m
        => ByteString -> m (Path Fn)
parseFn :: ByteString -> m (Path Fn)
parseFn filepath :: ByteString
filepath =
  if ByteString -> Bool
isFileName ByteString
filepath Bool -> Bool -> Bool
&&
     ByteString
filepath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8 -> ByteString
BS.singleton Word8
_period Bool -> Bool -> Bool
&&
     ByteString
filepath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= [Word8] -> ByteString
BS.pack [Word8
_period, Word8
_period] Bool -> Bool -> Bool
&&
     ByteString -> Bool
isValid ByteString
filepath
     then Path Fn -> m (Path Fn)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Fn
forall b. ByteString -> Path b
MkPath ByteString
filepath)
     else PathParseException -> m (Path Fn)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> PathParseException
InvalidFn ByteString
filepath)



--------------------------------------------------------------------------------
-- Path Conversion

-- | Convert any Path to a ByteString type.
toFilePath :: Path b -> ByteString
toFilePath :: Path b -> ByteString
toFilePath (MkPath l :: ByteString
l) = ByteString
l

-- | Convert an absolute Path to a ByteString type.
fromAbs :: Path Abs -> ByteString
fromAbs :: Path Abs -> ByteString
fromAbs = Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath

-- | Convert a relative Path to a ByteString type.
fromRel :: RelC r => Path r -> ByteString
fromRel :: Path r -> ByteString
fromRel = Path r -> ByteString
forall b. Path b -> ByteString
toFilePath



--------------------------------------------------------------------------------
-- Path Operations

-- | Append two paths.
--
-- The second argument must always be a relative path, which ensures
-- that undefinable things like `"/abc" </> "/def"` cannot happen.
--
-- Technically, the first argument can be a path that points to a non-directory,
-- because this library is IO-agnostic and makes no assumptions about
-- file types.
--
-- >>> (MkPath "/")        </> (MkPath "file"     :: Path Rel)
-- "/file"
-- >>> (MkPath "/path/to") </> (MkPath "file"     :: Path Rel)
-- "/path/to/file"
-- >>> (MkPath "/")        </> (MkPath "file/lal" :: Path Rel)
-- "/file/lal"
-- >>> (MkPath "/")        </> (MkPath "file/"    :: Path Rel)
-- "/file/"
(</>) :: RelC r => Path b -> Path r -> Path b
</> :: Path b -> Path r -> Path b
(</>) (MkPath a :: ByteString
a) (MkPath b :: ByteString
b) = ByteString -> Path b
forall b. ByteString -> Path b
MkPath (ByteString
a' ByteString -> ByteString -> ByteString
`BS.append` ByteString
b)
  where
    a' :: ByteString
a' = if ByteString -> Word8
BS.last ByteString
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
pathSeparator
         then ByteString
a
         else ByteString -> ByteString
addTrailingPathSeparator ByteString
a

-- | Strip directory from path, making it relative to that directory.
-- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path.
--
-- The bases must match.
--
-- >>> (MkPath "/lal/lad")     `stripDir` (MkPath "/lal/lad/fad") :: Maybe (Path Rel)
-- Just "fad"
-- >>> (MkPath "lal/lad")      `stripDir` (MkPath "lal/lad/fad")  :: Maybe (Path Rel)
-- Just "fad"
-- >>> (MkPath "/")            `stripDir` (MkPath "/")            :: Maybe (Path Rel)
-- Nothing
-- >>> (MkPath "/lal/lad/fad") `stripDir` (MkPath "/lal/lad")     :: Maybe (Path Rel)
-- Nothing
-- >>> (MkPath "fad")          `stripDir` (MkPath "fad")          :: Maybe (Path Rel)
-- Nothing
stripDir :: MonadThrow m
         => Path b -> Path b -> m (Path Rel)
stripDir :: Path b -> Path b -> m (Path Rel)
stripDir (MkPath p :: ByteString
p) (MkPath l :: ByteString
l) =
  case ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
p' ByteString
l of
    Nothing -> PathParseException -> m (Path Rel)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> ByteString -> PathParseException
Couldn'tStripPrefixTPS ByteString
p' ByteString
l)
    Just ok :: ByteString
ok -> if ByteString -> Bool
BS.null ByteString
ok
                 then PathParseException -> m (Path Rel)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> ByteString -> PathParseException
Couldn'tStripPrefixTPS ByteString
p' ByteString
l)
                 else Path Rel -> m (Path Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath ByteString
ok)
  where
    p' :: ByteString
p' = ByteString -> ByteString
addTrailingPathSeparator ByteString
p

-- | Is p a parent of the given location? Implemented in terms of
-- 'stripDir'. The bases must match.
--
-- >>> (MkPath "/lal/lad")     `isParentOf` (MkPath "/lal/lad/fad")
-- True
-- >>> (MkPath "lal/lad")      `isParentOf` (MkPath "lal/lad/fad")
-- True
-- >>> (MkPath "/")            `isParentOf` (MkPath "/")
-- False
-- >>> (MkPath "/lal/lad/fad") `isParentOf` (MkPath "/lal/lad")
-- False
-- >>> (MkPath "fad")          `isParentOf` (MkPath "fad")
-- False
isParentOf :: Path b -> Path b -> Bool
isParentOf :: Path b -> Path b -> Bool
isParentOf p :: Path b
p l :: Path b
l = Maybe (Path Rel) -> Bool
forall a. Maybe a -> Bool
isJust (Path b -> Path b -> Maybe (Path Rel)
forall (m :: * -> *) b.
MonadThrow m =>
Path b -> Path b -> m (Path Rel)
stripDir Path b
p Path b
l :: Maybe (Path Rel))


-- |Get all parents of a path.
--
-- >>> getAllParents (MkPath "/abs/def/dod")
-- ["/abs/def","/abs","/"]
-- >>> getAllParents (MkPath "/")
-- []
getAllParents :: Path Abs -> [Path Abs]
getAllParents :: Path Abs -> [Path Abs]
getAllParents (MkPath p :: ByteString
p)
  | ByteString
np ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> ByteString
BS.singleton Word8
pathSeparator = []
  | Bool
otherwise = Path Abs -> Path Abs
dirname (ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath ByteString
np) Path Abs -> [Path Abs] -> [Path Abs]
forall a. a -> [a] -> [a]
: Path Abs -> [Path Abs]
getAllParents (Path Abs -> Path Abs
dirname (Path Abs -> Path Abs) -> Path Abs -> Path Abs
forall a b. (a -> b) -> a -> b
$ ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath ByteString
np)
  where
    np :: ByteString
np = ByteString -> ByteString
dropTrailingPathSeparator (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
normalise (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
p


-- | Extract the directory name of a path.
--
-- >>> dirname (MkPath "/abc/def/dod")
-- "/abc/def"
-- >>> dirname (MkPath "/")
-- "/"
dirname :: Path Abs -> Path Abs
dirname :: Path Abs -> Path Abs
dirname (MkPath fp :: ByteString
fp) = ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath (ByteString -> ByteString
takeDirectory (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropTrailingPathSeparator ByteString
fp)

-- | Extract the file part of a path.
--
--
-- The following properties hold:
--
-- @basename (p \<\/> a) == basename a@
--
-- Throws: `PathException` if given the root path "/"
--
-- >>> basename (MkPath "/abc/def/dod") :: Maybe (Path Fn)
-- Just "dod"
-- >>> basename (MkPath "/abc/def/dod/") :: Maybe (Path Fn)
-- Just "dod"
-- >>> basename (MkPath "/")            :: Maybe (Path Fn)
-- Nothing
basename :: MonadThrow m => Path b -> m (Path Fn)
basename :: Path b -> m (Path Fn)
basename (MkPath l :: ByteString
l)
  | Bool -> Bool
not (ByteString -> Bool
isAbsolute ByteString
rl) = Path Fn -> m (Path Fn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Fn -> m (Path Fn)) -> Path Fn -> m (Path Fn)
forall a b. (a -> b) -> a -> b
$ ByteString -> Path Fn
forall b. ByteString -> Path b
MkPath ByteString
rl
  | Bool
otherwise           = PathException -> m (Path Fn)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PathException
RootDirHasNoBasename
  where
    rl :: ByteString
rl = [ByteString] -> ByteString
forall a. [a] -> a
last ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitPath (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropTrailingPathSeparator (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
l


--------------------------------------------------------------------------------
-- Path IO helpers


withAbsPath :: Path Abs -> (ByteString -> IO a) -> IO a
withAbsPath :: Path Abs -> (ByteString -> IO a) -> IO a
withAbsPath (MkPath p :: ByteString
p) action :: ByteString -> IO a
action = ByteString -> IO a
action ByteString
p


withRelPath :: Path Rel -> (ByteString -> IO a) -> IO a
withRelPath :: Path Rel -> (ByteString -> IO a) -> IO a
withRelPath (MkPath p :: ByteString
p) action :: ByteString -> IO a
action = ByteString -> IO a
action ByteString
p


withFnPath :: Path Fn -> (ByteString -> IO a) -> IO a
withFnPath :: Path Fn -> (ByteString -> IO a) -> IO a
withFnPath (MkPath p :: ByteString
p) action :: ByteString -> IO a
action = ByteString -> IO a
action ByteString
p


------------------------
-- ByteString helpers

#if MIN_VERSION_bytestring(0,10,8)
#else
stripPrefix :: ByteString -> ByteString -> Maybe ByteString
stripPrefix a b = BS.pack `fmap` L.stripPrefix (BS.unpack a) (BS.unpack b)
#endif