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 BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE PatternSynonyms #-}
#endif
{-# LANGUAGE ScopedTypeVariables #-}

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
  ,unsafeToString
  ,unsafeToString'
  -- * Path Operations
  ,(</>)
  ,basename
  ,dirname
  ,isParentOf
  ,getAllParents
  ,stripDir
  -- * Path IO helpers
  ,withAbsPath
  ,withRelPath
  ,withFnPath
  )
  where

import           Control.Exception (IOException, Exception, catch)
import           Control.Monad ((<$!>))
import           Control.Monad.Catch (MonadThrow(..))
import           Data.ByteString.Unsafe(unsafeUseAsCStringLen)
#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           GHC.Foreign(peekCStringLen)
import           GHC.IO.Encoding(getLocaleEncoding, TextEncoding)
import           HPath.Internal
import           System.IO.Unsafe(unsafePerformIO)
import           System.Posix.FilePath hiding ((</>))


-- $setup
-- >>> import GHC.IO.Encoding(utf8)


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

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 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 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 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 filepath =
  if not (isAbsolute filepath) &&
     filepath /= BS.singleton _period &&
     filepath /= BS.pack [_period, _period] &&
     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 "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 filepath =
  if isFileName filepath &&
     filepath /= BS.singleton _period &&
     filepath /= BS.pack [_period, _period] &&
     isValid filepath
     then return (MkPath filepath)
     else throwM (InvalidFn filepath)



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

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

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

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

-- | This converts the underlying bytestring of the path to an unsafe
-- FilePath by assuming the encoding of the current locale setting. This
-- may be utterly wrong, but isn't particularly worse than what the
-- base library does. Blows up on decoding errors.
--
-- >>> unsafeToString (MkPath "/lal/lad")
-- "/lal/lad"
-- >>> unsafeToString (MkPath "/")
-- "/"
-- >>> unsafeToString (MkPath "lad")
-- "lad"
-- >>> catch (Just <$> unsafeToString (MkPath "<22>")) (\(_ :: IOException) -> pure Nothing)
-- Nothing
unsafeToString :: Path b -> IO FilePath
unsafeToString (MkPath p) = do
  enc <- getLocaleEncoding
  unsafeUseAsCStringLen p (peekCStringLen enc)

-- | Same as @unsafeToString@, except requires the encoding
-- to be passed explicitly. This uses 'unsafePerformIO' and
-- returns 'Nothing' on decoding errors.
--
-- >>> unsafeToString' (MkPath "/lal/lad") utf8
-- Just "/lal/lad"
-- >>> unsafeToString' (MkPath "/") utf8
-- Just "/"
-- >>> unsafeToString' (MkPath "lad") utf8
-- Just "lad"
-- >>> unsafeToString' (MkPath "<22>") utf8
-- Nothing
unsafeToString' :: Path b -> TextEncoding -> Maybe FilePath
unsafeToString' (MkPath !p) enc =
  unsafePerformIO $!
    catch (Just <$!> unsafeUseAsCStringLen p (peekCStringLen enc))
          (\(_ :: IOException) -> pure Nothing)


--------------------------------------------------------------------------------
-- 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
(</>) (MkPath a) (MkPath b) = MkPath (a' `BS.append` b)
  where
    a' = if BS.last a == pathSeparator
         then a
         else 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.
--
-- >>> (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 (MkPath p) (MkPath l) =
  case stripPrefix p' l of
    Nothing -> throwM (Couldn'tStripPrefixTPS p' l)
    Just ok -> if BS.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.
--
-- >>> (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 p l = isJust (stripDir p 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 (MkPath p)
  | np == BS.singleton pathSeparator = []
  | otherwise = dirname (MkPath np) : getAllParents (dirname $ MkPath np)
  where
    np = dropTrailingPathSeparator . normalise $ p


-- | Extract the directory name of a path.
--
-- >>> dirname (MkPath "/abc/def/dod")
-- "/abc/def"
-- >>> dirname (MkPath "/")
-- "/"
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 (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 (MkPath l)
  | not (isAbsolute rl) = return $ MkPath rl
  | otherwise           = throwM RootDirHasNoBasename
  where
    rl = last . splitPath . dropTrailingPathSeparator $ l


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


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


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


withFnPath :: Path Fn -> (ByteString -> IO a) -> IO a
withFnPath (MkPath p) action = action 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