-- | -- 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 CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module HPath ( -- * Types Abs ,Path ,Rel ,PathParseException ,PathException #if __GLASGOW_HASKELL__ >= 708 -- * PatternSynonyms/ViewPatterns ,pattern Path #endif -- * Path Construction ,parseAbs ,parseRel ,parseAny ,rootPath -- * Path Conversion ,fromAbs ,fromRel ,toFilePath ,fromAny -- * Path Operations ,() ,basename ,dirname ,getAllParents ,getAllComponents ,getAllComponentsAfterRoot ,stripDir -- * Path Examination ,isParentOf ,isRootPath -- * Path IO helpers ,withAbsPath ,withRelPath -- * Quasiquoters ,abs ,rel ) 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.ByteString.UTF8 import Data.Data import Data.Maybe import Data.Word8 import HPath.Internal import Language.Haskell.TH import Language.Haskell.TH.Syntax (Exp(..), Lift(..), lift) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Prelude hiding (abs, any) import System.Posix.FilePath hiding (()) -------------------------------------------------------------------------------- -- Types -- | An absolute path. data Abs deriving (Typeable) -- | A relative path; one without a root. data Rel deriving (Typeable) -- | Exception when parsing a location. data PathParseException = InvalidAbs ByteString | InvalidRel ByteString | Couldn'tStripPrefixTPS ByteString ByteString deriving (Show,Typeable) instance Exception PathParseException data PathException = RootDirHasNoBasename deriving (Show,Typeable) instance Exception PathException -------------------------------------------------------------------------------- -- 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 . dropTrailingPathSeparator . 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 . dropTrailingPathSeparator . normalise $ filepath) else throwM (InvalidRel filepath) -- | Parses a path, whether it's relative or absolute. Will lose -- information on whether it's relative or absolute. If you need to know, -- reparse it. -- -- Filenames must not contain slashes. -- Excludes '.' and '..'. -- -- Throws: 'PathParseException' -- -- >>> parseAny "/abc" :: Maybe (Either (Path Abs) (Path Rel)) -- Just (Left "/abc") -- >>> parseAny "..." :: Maybe (Either (Path Abs) (Path Rel)) -- Just (Right "...") -- >>> parseAny "abc/def" :: Maybe (Either (Path Abs) (Path Rel)) -- Just (Right "abc/def") -- >>> parseAny "abc/def/." :: Maybe (Either (Path Abs) (Path Rel)) -- Just (Right "abc/def") -- >>> parseAny "/abc" :: Maybe (Either (Path Abs) (Path Rel)) -- Just (Left "/abc") -- >>> parseAny "" :: Maybe (Either (Path Abs) (Path Rel)) -- Nothing -- >>> parseAny "abc/../foo" :: Maybe (Either (Path Abs) (Path Rel)) -- Nothing -- >>> parseAny "." :: Maybe (Either (Path Abs) (Path Rel)) -- Nothing -- >>> parseAny ".." :: Maybe (Either (Path Abs) (Path Rel)) -- Nothing parseAny :: MonadThrow m => ByteString -> m (Either (Path Abs) (Path Rel)) parseAny filepath = case parseAbs filepath of Just p -> pure $ Left p Nothing -> case parseRel filepath of Just p -> pure $ Right p Nothing -> throwM (InvalidRel filepath) rootPath :: Path Abs rootPath = (MkPath (BS.singleton _slash)) -------------------------------------------------------------------------------- -- 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 :: Path Rel -> ByteString fromRel = toFilePath fromAny :: Either (Path Abs) (Path Rel) -> ByteString fromAny = either toFilePath 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" () :: Path b -> Path Rel -> Path b () (MkPath a) (MkPath b) = MkPath (a' `BS.append` b) where a' = if hasTrailingPathSeparator a 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 -- |Get all parents of a path. -- -- >>> getAllParents (MkPath "/abs/def/dod") -- ["/abs/def","/abs","/"] -- >>> getAllParents (MkPath "/foo") -- ["/"] -- >>> getAllParents (MkPath "/") -- [] getAllParents :: Path Abs -> [Path Abs] getAllParents (MkPath p) | np == BS.singleton pathSeparator = [] | otherwise = dirname (MkPath np) : getAllParents (dirname $ MkPath np) where np = normalise p -- | Gets all path components. -- -- >>> getAllComponents (MkPath "abs/def/dod") -- ["abs","def","dod"] -- >>> getAllComponents (MkPath "abs") -- ["abs"] getAllComponents :: Path Rel -> [Path Rel] getAllComponents (MkPath p) = fmap MkPath . splitDirectories $ p -- | Gets all path components after the "/" root directory. -- -- >>> getAllComponentsAfterRoot (MkPath "/abs/def/dod") -- ["abs","def","dod"] -- >>> getAllComponentsAfterRoot (MkPath "/abs") -- ["abs"] getAllComponentsAfterRoot :: Path Abs -> [Path Rel] getAllComponentsAfterRoot p = getAllComponents (fromJust $ stripDir rootPath 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 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 Rel) -- Just "dod" -- >>> basename (MkPath "abc/def/dod") :: Maybe (Path Rel) -- Just "dod" -- >>> basename (MkPath "dod") :: Maybe (Path Rel) -- Just "dod" -- >>> basename (MkPath "/") :: Maybe (Path Rel) -- Nothing basename :: MonadThrow m => Path b -> m (Path Rel) basename (MkPath l) | not (isAbsolute rl) = return $ MkPath rl | otherwise = throwM RootDirHasNoBasename where rl = last . splitPath $ l -------------------------------------------------------------------------------- -- Path Examination -- | 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)) -- | Check whether the given Path is the root "/" path. -- -- >>> isRootPath (MkPath "/lal/lad") -- False -- >>> isRootPath (MkPath "/") -- True isRootPath :: Path Abs -> Bool isRootPath = (== rootPath) -------------------------------------------------------------------------------- -- 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 ------------------------ -- 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 ------------------------ -- QuasiQuoters instance Lift (Path a) where lift (MkPath bs) = AppE <$> [| MkPath . BS.pack |] <*> lift (BS.unpack bs) qq :: (ByteString -> Q Exp) -> QuasiQuoter qq quoteExp' = QuasiQuoter { quoteExp = (\s -> quoteExp' . fromString $ s) , quotePat = \_ -> fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" , quoteType = \_ -> fail "illegal QuasiQuote (allowed as expression only, used as a type)" , quoteDec = \_ -> fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" } mkAbs :: ByteString -> Q Exp mkAbs = either (error . show) lift . parseAbs mkRel :: ByteString -> Q Exp mkRel = either (error . show) lift . parseRel -- | Quasiquote an absolute Path. This accepts Unicode Chars and will encode as UTF-8. -- -- >>> [abs|/etc/profile|] :: Path Abs -- "/etc/profile" -- >>> [abs|/|] :: Path Abs -- "/" -- >>> [abs|/|] :: Path Abs -- "/\239\131\144" abs :: QuasiQuoter abs = qq mkAbs -- | Quasiquote a relative Path. This accepts Unicode Chars and will encode as UTF-8. -- -- >>> [rel|etc|] :: Path Rel -- "etc" -- >>> [rel|bar/baz|] :: Path Rel -- "bar/baz" -- >>> [rel||] :: Path Rel -- "\239\131\144" rel :: QuasiQuoter rel = qq mkRel