-- | -- Module : HPath -- Copyright : © 2015–2016 FP Complete, 2016 Julian Ospald -- License : BSD 3 clause -- -- Maintainer : Julian Ospald -- 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 "�")) (\(_ :: 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 "�") 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