hpath/src/HPath.hs

-- |
-- 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 #-}
{-# 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
  ,normalizeAbs
  ,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
  -- * ByteString Query functions
  ,hiddenFile
  -- * 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
import           Safe(initDef)


--------------------------------------------------------------------------------
-- 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

data PathException = RootDirHasNoBasename
  deriving (Show,Typeable)
instance Exception PathException

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 &&
     isValid filepath &&
     not (hasParentDir filepath)
     then return (MkPath $ normalise 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) &&
     filepath /= pathDot' && filepath /= pathDoubleDot &&
     not (hasParentDir filepath) &&
     isValid filepath
     then return (MkPath $ normalise filepath)
     else throwM (InvalidRel filepath)


-- | Parses a filename. Filenames must not contain slashes.
-- Excludes '.' and '..'.
--
-- Throws: 'PathParseException'
--
parseFn :: MonadThrow m
        => ByteString -> m (Path Fn)
parseFn filepath =
  if isFileName filepath &&
     filepath /= pathDot' && filepath /= pathDoubleDot &&
     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

-- | A variant for `normalize` for absolute paths which
-- also removes occurences of '..', which may behave
-- strange for symlinks though.
normalizeAbs :: Path Abs -> Path Abs
normalizeAbs (MkPath l) = MkPath . fromJust . normaliseAbs $ 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 ok -> if B.null ok
                 then throwM (Couldn'tStripPrefixTPS p' l)
                 else 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)
  | np == pathSeparator' = []
  | otherwise = dirname (MkPath np) : getAllParents (dirname $ MkPath np)
  where
    np = 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@
--
-- Throws: `PathException` if given the root path "/"
basename :: MonadThrow m => Path b -> m (Path Fn)
basename (MkPath l)
  | not (isAbsolute rl) = return $ MkPath rl
  | otherwise           = throwM RootDirHasNoBasename
  where
    rl = last . splitPath . dropTrailingPathSeparator $ l


--------------------------------------------------------------------------------
-- ByteString Query functions

hiddenFile :: Path Fn -> Bool
hiddenFile (MkPath fp)
  | fp == pathDoubleDot = False
  | fp == pathDot'      = False
  | otherwise           = pathDot' `B.isPrefixOf` fp
 

--------------------------------------------------------------------------------
-- ByteString/Word8 constants

pathSeparator :: Word8
pathSeparator = _slash

pathSeparator' :: ByteString
pathSeparator' = B.singleton pathSeparator


pathDot :: Word8
pathDot = _period


pathDot' :: ByteString
pathDot' = B.singleton pathDot


pathDoubleDot :: ByteString
pathDoubleDot = pathDot `B.cons` 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
      | B.null d && B.null 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
      | B.null p = B.empty
      | 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' /=)


-- | A variant of `normalise` for absolute paths, which removes
-- occurences of '..'. If a non-absolute path is passed, returns Nothing.
normaliseAbs :: ByteString -> Maybe ByteString
normaliseAbs filepath
  | isRelative filepath = Nothing
  | otherwise           =
      let nfp = normalise filepath
       in Just . joinPath . L.foldl' rmDbl [] . splitDirectories $ nfp
  where
    rmDbl x y
      | x == [pathSeparator'] && y == pathDoubleDot = [pathSeparator']
      | y == pathDoubleDot                          = initDef [] x
      | otherwise                                   = x ++ [y]


splitPath :: ByteString -> [ByteString]
splitPath filepath = [drv | drv /= B.empty] ++ f pth
  where
    (drv, pth) = splitDrive filepath
    f p
      | B.null 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 B.empty


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 pathDot `B.cons` pathSeparator'
                            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 provided 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 =
  ((pathSeparator `B.cons` pathDoubleDot)  `B.isSuffixOf` filepath) ||
  ((pathSeparator' `B.append` pathDoubleDot `B.append` pathSeparator')
      `B.isInfixOf`  filepath) ||
  ((pathDoubleDot `B.append` pathSeparator') `B.isPrefixOf` filepath)

hasDot :: ByteString -> Bool
hasDot filepath =
  ((pathSeparator `B.cons` pathDot')  `B.isSuffixOf` filepath) ||
  ((pathSeparator' `B.append` pathDot' `B.append` pathSeparator')
      `B.isInfixOf`  filepath) ||
  ((pathDot `B.cons` pathSeparator') `B.isPrefixOf` filepath)

hasDoublePS :: ByteString -> Bool
hasDoublePS filepath =
  ((pathSeparator `B.cons` pathSeparator') `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 (pathSeparator' `B.isInfixOf` filepath) &&
  not (B.null filepath) &&
  not (nullByte `B.elem` 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
  | 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