542 lines
14 KiB
Haskell
542 lines
14 KiB
Haskell
-- |
|
||
-- 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 TemplateHaskell #-}
|
||
{-# LANGUAGE DeriveDataTypeable #-}
|
||
{-# LANGUAGE EmptyDataDecls #-}
|
||
{-# LANGUAGE PatternSynonyms #-}
|
||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||
|
||
module HPath
|
||
(
|
||
-- * Types
|
||
Abs
|
||
,Path
|
||
,Rel
|
||
,Fn
|
||
,PathParseException
|
||
-- * PatternSynonyms/ViewPatterns
|
||
,pattern Path
|
||
-- * Path Parsing
|
||
,parseAbs
|
||
,parseFn
|
||
,parseRel
|
||
-- * Path Constructors
|
||
,mkAbs
|
||
,mkFn
|
||
,mkRel
|
||
-- * Path Conversion
|
||
,canonicalizePath
|
||
,fromAbs
|
||
,fromRel
|
||
,normalize
|
||
,toFilePath
|
||
-- * Path Operations
|
||
,(</>)
|
||
,basename
|
||
,dirname
|
||
,isParentOf
|
||
,getAllParents
|
||
,stripDir
|
||
-- * ByteString/Word8 constants
|
||
,nullByte
|
||
,pathDot
|
||
,pathDot'
|
||
,pathSeparator
|
||
,pathSeparator'
|
||
-- * ByteString operations
|
||
,addTrailingPathSeparator
|
||
,combine
|
||
,dropFileName
|
||
,dropTrailingPathSeparator
|
||
,dropWhileEnd
|
||
,equalFilePath
|
||
,fpToString
|
||
,joinPath
|
||
,normalise
|
||
,splitDirectories
|
||
,splitFileName
|
||
,splitPath
|
||
,stripPrefix
|
||
,takeDirectory
|
||
,userStringToFP
|
||
-- * Queries
|
||
,hasDot
|
||
,hasDoublePS
|
||
,hasLeadingPathSeparator
|
||
,hasParentDir
|
||
,hasTrailingPathSeparator
|
||
,isAbsolute
|
||
,isFileName
|
||
,isRelative
|
||
,isValid
|
||
-- * String based functions
|
||
,realPath
|
||
)
|
||
where
|
||
|
||
import Control.Exception (Exception)
|
||
import Control.Monad(void)
|
||
import Control.Monad.Catch (MonadThrow(..))
|
||
import Data.ByteString(ByteString)
|
||
import qualified Data.ByteString as B
|
||
import Data.Data
|
||
import Data.Encoding(decodeStrictByteString, encodeStrictByteString)
|
||
import Data.Encoding.UTF8(UTF8(..))
|
||
import qualified Data.List as L
|
||
import Data.Maybe
|
||
import Data.Word8
|
||
import Foreign.C.Error
|
||
import Foreign.C.String
|
||
import Foreign.Marshal.Alloc(allocaBytes)
|
||
import HPath.Foreign
|
||
import HPath.Internal
|
||
import Language.Haskell.TH
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- 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 (Show,Typeable)
|
||
instance Exception PathParseException
|
||
|
||
instance RelC Rel
|
||
instance RelC Fn
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- PatternSynonyms
|
||
|
||
pattern Path x <- (MkPath x)
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- Path Parsers
|
||
|
||
-- | Get a location for an absolute path.
|
||
--
|
||
-- Throws: 'PathParseException'
|
||
--
|
||
parseAbs :: MonadThrow m
|
||
=> ByteString -> m (Path Abs)
|
||
parseAbs filepath =
|
||
if isAbsolute filepath &&
|
||
not (B.null filepath) &&
|
||
isValid filepath
|
||
then return (MkPath filepath)
|
||
else throwM (InvalidAbs filepath)
|
||
|
||
-- | Get a location for a relative path. Produces a normalized
|
||
-- path which always ends in a path separator.
|
||
--
|
||
-- 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 :: MonadThrow m
|
||
=> ByteString -> m (Path Rel)
|
||
parseRel filepath =
|
||
if not (isAbsolute filepath) &&
|
||
not (B.null filepath) &&
|
||
isValid filepath
|
||
then return (MkPath filepath)
|
||
else throwM (InvalidRel filepath)
|
||
|
||
parseFn :: MonadThrow m
|
||
=> ByteString -> m (Path Fn)
|
||
parseFn filepath =
|
||
if not (isAbsolute filepath) &&
|
||
not (B.null filepath) &&
|
||
isFileName filepath &&
|
||
isValid filepath
|
||
then return (MkPath filepath)
|
||
else throwM (InvalidFn filepath)
|
||
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- Constructors
|
||
|
||
-- | Make a 'Path Abs TPS'.
|
||
--
|
||
-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
|
||
-- may compile on your platform, but it may not compile on another
|
||
-- platform (Windows).
|
||
mkAbs :: ByteString -> Q Exp
|
||
mkAbs s =
|
||
case parseAbs s of
|
||
Left err -> error (show err)
|
||
Right (MkPath str) ->
|
||
[|MkPath $(return (LitE (StringL (show str)))) :: Path Abs|]
|
||
|
||
-- | Make a 'Path Rel TPS'.
|
||
mkRel :: ByteString -> Q Exp
|
||
mkRel s =
|
||
case parseRel s of
|
||
Left err -> error (show err)
|
||
Right (MkPath str) ->
|
||
[|MkPath $(return (LitE (StringL (show str)))) :: Path Rel|]
|
||
|
||
-- | Make a 'Path Rel TPS'.
|
||
mkFn :: ByteString -> Q Exp
|
||
mkFn s =
|
||
case parseFn s of
|
||
Left err -> error (show err)
|
||
Right (MkPath str) ->
|
||
[|MkPath $(return (LitE (StringL (show str)))) :: Path Fn|]
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- Path Conversion
|
||
|
||
-- | Convert to a ByteString type.
|
||
--
|
||
-- All TPS data types have a trailing slash, so if you want no trailing
|
||
-- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from
|
||
-- the filepath package.
|
||
toFilePath :: Path b -> ByteString
|
||
toFilePath (MkPath l) = l
|
||
|
||
fromAbs :: Path Abs -> ByteString
|
||
fromAbs = toFilePath
|
||
|
||
fromRel :: RelC r => Path r -> ByteString
|
||
fromRel = toFilePath
|
||
|
||
normalize :: Path t -> Path t
|
||
normalize (MkPath l) = MkPath $ normalise l
|
||
|
||
-- | May fail on `realPath`.
|
||
canonicalizePath :: Path Abs -> IO (Path Abs)
|
||
canonicalizePath (MkPath l) = do
|
||
nl <- realPath l
|
||
return $ MkPath nl
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- 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.
|
||
(</>) :: RelC r => Path b -> Path r -> Path b
|
||
(</>) (MkPath a) (MkPath b) = MkPath (a' `B.append` b)
|
||
where
|
||
a' = addTrailingPathSeparator 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.
|
||
--
|
||
stripDir :: MonadThrow m
|
||
=> Path b -> Path b -> m (Path Rel)
|
||
stripDir (MkPath p) (MkPath l) =
|
||
case stripPrefix p' l of
|
||
Nothing -> throwM (Couldn'tStripPrefixTPS p' l)
|
||
Just "" -> throwM (Couldn'tStripPrefixTPS p' l)
|
||
Just ok -> return (MkPath ok)
|
||
where
|
||
p' = addTrailingPathSeparator p
|
||
|
||
-- | Is p a parent of the given location? Implemented in terms of
|
||
-- 'stripDir'. The bases must match.
|
||
isParentOf :: Path b -> Path b -> Bool
|
||
isParentOf p l = isJust (stripDir p l :: Maybe (Path Rel))
|
||
|
||
|
||
getAllParents :: Path Abs -> [Path Abs]
|
||
getAllParents (MkPath p) =
|
||
case np of
|
||
(MkPath "/") -> []
|
||
_ -> dirname np : getAllParents (dirname np)
|
||
where
|
||
np = MkPath . dropTrailingPathSeparator . normalise $ p
|
||
|
||
|
||
-- | Extract the directory name of a path.
|
||
--
|
||
-- The following properties hold:
|
||
--
|
||
-- @dirname (p \<\/> a) == dirname p@
|
||
--
|
||
dirname :: Path Abs -> Path Abs
|
||
dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp)
|
||
|
||
-- | Extract the file part of a path.
|
||
--
|
||
--
|
||
-- The following properties hold:
|
||
--
|
||
-- @basename (p \<\/> a) == basename a@
|
||
--
|
||
-- Except when "/" is passed in which case the filename "." is returned.
|
||
basename :: Path b -> Path Fn
|
||
basename (MkPath l)
|
||
| not (isAbsolute rl) = MkPath rl
|
||
| otherwise = MkPath "."
|
||
where
|
||
rl = last . splitPath . dropTrailingPathSeparator $ l
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ByteString/Word8 constants
|
||
|
||
pathSeparator :: Word8
|
||
pathSeparator = _slash
|
||
|
||
pathSeparator' :: ByteString
|
||
pathSeparator' = B.singleton pathSeparator
|
||
|
||
|
||
pathDot :: Word8
|
||
pathDot = _period
|
||
|
||
|
||
pathDot' :: ByteString
|
||
pathDot' = B.singleton pathDot
|
||
|
||
|
||
nullByte :: Word8
|
||
nullByte = _nul
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ByteString Operations
|
||
|
||
|
||
dropWhileEnd :: (Word8 -> Bool) -> ByteString -> ByteString
|
||
dropWhileEnd p = B.reverse . B.dropWhile p . B.reverse
|
||
|
||
|
||
dropTrailingPathSeparator :: ByteString -> ByteString
|
||
dropTrailingPathSeparator filepath =
|
||
if hasTrailingPathSeparator filepath
|
||
then let filepath' = dropWhileEnd (== pathSeparator) filepath
|
||
in if B.null filepath' then B.singleton . B.last $ filepath else filepath'
|
||
else filepath
|
||
|
||
|
||
addTrailingPathSeparator :: ByteString -> ByteString
|
||
addTrailingPathSeparator filepath
|
||
| B.null filepath = filepath
|
||
| filepath == pathSeparator' = filepath
|
||
| not (hasTrailingPathSeparator filepath)
|
||
= filepath `B.append` pathSeparator'
|
||
| otherwise = filepath
|
||
|
||
|
||
normalise :: ByteString -> ByteString
|
||
normalise filepath = result `B.append`
|
||
(if addPathSeparator then pathSeparator' else B.empty)
|
||
where
|
||
(drv, pth) = splitDrive filepath
|
||
result = joinDrive' (normaliseDrive drv) (f pth)
|
||
joinDrive' d p
|
||
| d == "" && p == "" = B.singleton pathDot
|
||
| otherwise = joinDrive d p
|
||
addPathSeparator = isDirPath pth && not (hasTrailingPathSeparator result)
|
||
isDirPath xs = hasTrailingPathSeparator xs
|
||
|| not (B.null xs) && B.last xs == pathDot
|
||
&& hasTrailingPathSeparator (B.init xs)
|
||
normaliseDrive p
|
||
| p == "" = ""
|
||
| otherwise = B.singleton pathSeparator
|
||
f = joinPath . dropDots . propSep . splitDirectories
|
||
propSep :: [ByteString] -> [ByteString]
|
||
propSep (x:xs)
|
||
| B.all (== pathSeparator) x = pathSeparator' : xs
|
||
| otherwise = x : xs
|
||
propSep [] = []
|
||
dropDots = filter (pathDot' /=)
|
||
|
||
|
||
splitPath :: ByteString -> [ByteString]
|
||
splitPath filepath = [drv | drv /= ""] ++ f pth
|
||
where
|
||
(drv, pth) = splitDrive filepath
|
||
f p
|
||
| p == "" = []
|
||
| otherwise = (a `B.append` c) : f d
|
||
where
|
||
(a, b) = B.break (== pathSeparator) p
|
||
(c, d) = splitDrive b
|
||
|
||
|
||
joinPath :: [ByteString] -> ByteString
|
||
joinPath = foldr combine ""
|
||
|
||
|
||
splitDrive :: ByteString -> (ByteString, ByteString)
|
||
splitDrive = B.span (== pathSeparator)
|
||
|
||
|
||
joinDrive :: ByteString -> ByteString -> ByteString
|
||
joinDrive = combineAlways
|
||
|
||
|
||
splitDirectories :: ByteString -> [ByteString]
|
||
splitDirectories = map dropTrailingPathSeparator . splitPath
|
||
|
||
|
||
combine :: ByteString -> ByteString -> ByteString
|
||
combine d p
|
||
| hasLeadingPathSeparator p = p
|
||
| otherwise = combineAlways d p
|
||
|
||
|
||
combineAlways :: ByteString -> ByteString -> ByteString
|
||
combineAlways d p
|
||
| B.null d = p
|
||
| B.null p = d
|
||
| hasTrailingPathSeparator d = d `B.append` p
|
||
| otherwise = d `B.append` B.singleton pathSeparator `B.append` p
|
||
|
||
|
||
takeDirectory :: ByteString -> ByteString
|
||
takeDirectory = dropTrailingPathSeparator . dropFileName
|
||
|
||
|
||
dropFileName :: ByteString -> ByteString
|
||
dropFileName = fst . splitFileName
|
||
|
||
|
||
splitFileName :: ByteString -> (ByteString, ByteString)
|
||
splitFileName filepath = (if B.null dir then "./" else dir, name)
|
||
where
|
||
(dir, name) = splitFileName_ filepath
|
||
splitFileName_ p = (drv `B.append` dir', file)
|
||
where
|
||
(drv, pth) = splitDrive p
|
||
(dir', file) = B.breakEnd (== pathSeparator) pth
|
||
|
||
|
||
stripPrefix :: ByteString -> ByteString -> Maybe ByteString
|
||
stripPrefix a b = B.pack `fmap` L.stripPrefix (B.unpack a) (B.unpack b)
|
||
|
||
|
||
-- |Uses UTF-8 decoding to convert the bytestring into a String.
|
||
fpToString :: ByteString -> String
|
||
fpToString = decodeStrictByteString UTF8
|
||
|
||
|
||
-- |Uses UTF-8 encoding to convert a user provides String into
|
||
-- a ByteString, which represents a filepath.
|
||
userStringToFP :: String -> ByteString
|
||
userStringToFP = encodeStrictByteString UTF8
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ByteString Query functions
|
||
|
||
-- | Helper function: check if the filepath has any parent directories in it.
|
||
hasParentDir :: ByteString -> Bool
|
||
hasParentDir filepath =
|
||
("/.." `B.isSuffixOf` filepath) ||
|
||
("/../" `B.isInfixOf` filepath) ||
|
||
("../" `B.isPrefixOf` filepath)
|
||
|
||
hasDot :: ByteString -> Bool
|
||
hasDot filepath =
|
||
("/." `B.isSuffixOf` filepath) ||
|
||
("/./" `B.isInfixOf` filepath) ||
|
||
("./" `B.isPrefixOf` filepath)
|
||
|
||
hasDoublePS :: ByteString -> Bool
|
||
hasDoublePS filepath =
|
||
("//" `B.isInfixOf` filepath)
|
||
|
||
|
||
hasTrailingPathSeparator :: ByteString -> Bool
|
||
hasTrailingPathSeparator filepath
|
||
| B.null filepath = False
|
||
| B.last filepath == pathSeparator = True
|
||
| otherwise = False
|
||
|
||
|
||
hasLeadingPathSeparator :: ByteString -> Bool
|
||
hasLeadingPathSeparator filepath
|
||
| B.null filepath = False
|
||
| B.head filepath == pathSeparator = True
|
||
| otherwise = False
|
||
|
||
|
||
isFileName :: ByteString -> Bool
|
||
isFileName filepath =
|
||
not ("/" `B.isInfixOf` filepath)
|
||
|
||
|
||
isAbsolute :: ByteString -> Bool
|
||
isAbsolute filepath
|
||
| B.null filepath = False
|
||
| B.head filepath == pathSeparator = True
|
||
| otherwise = False
|
||
|
||
|
||
isRelative :: ByteString -> Bool
|
||
isRelative = not . isAbsolute
|
||
|
||
|
||
isValid :: ByteString -> Bool
|
||
isValid filepath
|
||
| B.null filepath = False
|
||
| filepath == "" = False
|
||
| nullByte `B.elem` filepath = False
|
||
| otherwise = True
|
||
|
||
|
||
equalFilePath :: ByteString -> ByteString -> Bool
|
||
equalFilePath p1 p2 = f p1 == f p2
|
||
where
|
||
f x = dropTrailingPathSeparator $ normalise x
|
||
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- String based path functions
|
||
|
||
foreign import ccall "realpath"
|
||
c_realpath :: CString -> CString -> IO CString
|
||
|
||
-- | return the canonicalized absolute pathname
|
||
--
|
||
-- like canonicalizePath, but uses realpath(3)
|
||
realPath :: ByteString -> IO ByteString
|
||
realPath inp =
|
||
allocaBytes pathMax $ \tmp -> do
|
||
void $ B.useAsCString inp
|
||
$ \cstr -> throwErrnoIfNull "realpath"
|
||
$ c_realpath cstr tmp
|
||
B.packCString tmp
|
||
|