module Hackage.Security.Util.Path (
Fragment
, mkFragment
, unFragment
, Path
, Unrooted
, Rooted(..)
, UnrootedPath
, IsRoot(..)
, fragment
, fragment'
, (</>)
, rootPath
, unrootPath
, unrootPath'
, castRoot
, joinFragments
, splitFragments
, toUnrootedFilePath
, fromUnrootedFilePath
, isPathPrefixOf
, takeDirectory
, takeFileName
, (<.>)
, splitExtension
, IsFileSystemRoot
, Relative
, Absolute
, HomeDir
, AbsolutePath
, RelativePath
, FileSystemPath(..)
, toFilePath
, fromFilePath
, makeAbsolute
, toAbsoluteFilePath
, fromAbsoluteFilePath
, openTempFile
, withFileInReadMode
, readLazyByteString
, readStrictByteString
, createDirectoryIfMissing
, doesDirectoryExist
, doesFileExist
, getCurrentDirectory
, getDirectoryContents
, getRecursiveContents
, getTemporaryDirectory
, removeFile
, renameFile
, TarballRoot
, TarballPath
, tarIndexLookup
, tarAppend
, WebRoot
, URIPath
, uriPath
, modifyUriPath
, IO.IOMode(..)
, IO.BufferMode(..)
, IO.Handle
, IO.hSetBuffering
, IO.hClose
, IO.hFileSize
) where
import Control.Monad
import Data.Function (on)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.L
import qualified System.FilePath as FilePath hiding (splitPath)
import qualified System.IO as IO
import qualified System.Directory as Dir
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Index as TarIndex
import qualified Network.URI as URI
import Hackage.Security.Util.Pretty
newtype Fragment = Fragment { unFragment :: String }
deriving (Show, Eq, Ord)
instance Pretty Fragment where
pretty = unFragment
mkFragment :: String -> Fragment
mkFragment str
| hasSep str = invalid "fragment contains path separators"
| null str = invalid "empty fragment"
| otherwise = Fragment str
where
invalid :: String -> a
invalid msg = error $ "mkFragment: " ++ show str ++ ": " ++ msg
hasSep :: String -> Bool
hasSep = any FilePath.isPathSeparator
data Unrooted
data Rooted a = Rooted
deriving (Show)
data Path a where
PathRoot :: Rooted root -> Path (Rooted root)
PathNil :: Path Unrooted
PathSnoc :: Path a -> Fragment -> Path a
deriving instance Show (Path a)
class IsRoot root where
showRoot :: Rooted root -> String
type UnrootedPath = Path Unrooted
instance Eq (Path a) where
(==) = (==) `on` (splitFragments . unrootPath')
instance Ord (Path a) where
(<=) = (<=) `on` (splitFragments . unrootPath')
instance IsRoot root => Pretty (Path (Rooted root)) where
pretty path = showRoot root FilePath.</> toUnrootedFilePath unrooted
where
(root, unrooted) = unrootPath path
fragment :: Fragment -> UnrootedPath
fragment = PathSnoc PathNil
fragment' :: String -> UnrootedPath
fragment' = fragment . mkFragment
(</>) :: Path a -> UnrootedPath -> Path a
ps </> PathNil = ps
ps </> PathSnoc qs q = PathSnoc (ps </> qs) q
rootPath :: forall root. Rooted root -> UnrootedPath -> Path (Rooted root)
rootPath root = go
where
go :: UnrootedPath -> Path (Rooted root)
go PathNil = PathRoot root
go (PathSnoc qs q) = PathSnoc (go qs) q
unrootPath :: Path (Rooted root) -> (Rooted root, UnrootedPath)
unrootPath (PathRoot root) = (root, PathNil)
unrootPath (PathSnoc qs q) = let (root, unrooted) = unrootPath qs
in (root, PathSnoc unrooted q)
unrootPath' :: Path a -> UnrootedPath
unrootPath' (PathRoot _) = PathNil
unrootPath' PathNil = PathNil
unrootPath' (PathSnoc qs q) = PathSnoc (unrootPath' qs) q
castRoot :: Path (Rooted root) -> Path (Rooted root')
castRoot (PathRoot _) = PathRoot Rooted
castRoot (PathSnoc qs q) = PathSnoc (castRoot qs) q
joinFragments :: [Fragment] -> UnrootedPath
joinFragments = go PathNil
where
go :: UnrootedPath -> [Fragment] -> UnrootedPath
go acc [] = acc
go acc (p:ps) = go (PathSnoc acc p) ps
splitFragments :: UnrootedPath -> [Fragment]
splitFragments = go []
where
go :: [Fragment] -> UnrootedPath -> [Fragment]
go acc PathNil = acc
go acc (PathSnoc ps p) = go (p:acc) ps
toUnrootedFilePath :: UnrootedPath -> FilePath
toUnrootedFilePath = FilePath.joinPath . map unFragment . splitFragments
fromUnrootedFilePath :: FilePath -> UnrootedPath
fromUnrootedFilePath = joinFragments . map mkFragment . splitPath
isPathPrefixOf :: UnrootedPath -> UnrootedPath -> Bool
isPathPrefixOf = go `on` splitFragments
where
go :: [Fragment] -> [Fragment] -> Bool
go [] _ = True
go _ [] = False
go (p:ps) (q:qs) = p == q && go ps qs
takeDirectory :: Path a -> Path a
takeDirectory (PathRoot root) = PathRoot root
takeDirectory PathNil = PathNil
takeDirectory (PathSnoc ps _) = ps
takeFileName :: Path a -> Fragment
takeFileName (PathRoot _) = error "takeFileName: empty path"
takeFileName PathNil = error "takeFileName: empty path"
takeFileName (PathSnoc _ p) = p
(<.>) :: Path a -> String -> Path a
PathRoot _ <.> _ = error "(<.>): empty path"
PathNil <.> _ = error "(<.>): empty path"
PathSnoc ps p <.> ext = PathSnoc ps p'
where
p' = mkFragment $ unFragment p FilePath.<.> ext
splitExtension :: Path a -> (Path a, String)
splitExtension (PathRoot _) = error "splitExtension: empty path"
splitExtension PathNil = error "splitExtension: empty path"
splitExtension (PathSnoc ps p) =
let (p', ext) = FilePath.splitExtension (unFragment p)
in (PathSnoc ps (mkFragment p'), ext)
class IsRoot root => IsFileSystemRoot root where
interpretRoot :: Rooted root -> IO FilePath
data Relative
data Absolute
data HomeDir
type AbsolutePath = Path (Rooted Absolute)
type RelativePath = Path (Rooted Relative)
instance IsRoot Relative where showRoot _ = "."
instance IsRoot Absolute where showRoot _ = "/"
instance IsRoot HomeDir where showRoot _ = "~"
instance IsFileSystemRoot Relative where
interpretRoot _ = Dir.getCurrentDirectory
instance IsFileSystemRoot Absolute where
interpretRoot _ = return "/"
instance IsFileSystemRoot HomeDir where
interpretRoot _ = Dir.getHomeDirectory
data FileSystemPath where
FileSystemPath :: IsFileSystemRoot root => Path (Rooted root) -> FileSystemPath
toFilePath :: AbsolutePath -> FilePath
toFilePath path = "/" FilePath.</> toUnrootedFilePath (unrootPath' path)
fromFilePath :: FilePath -> FileSystemPath
fromFilePath ('/':path) = FileSystemPath $
rootPath (Rooted :: Rooted Absolute) (fromUnrootedFilePath path)
fromFilePath ('~':'/':path) = FileSystemPath $
rootPath (Rooted :: Rooted HomeDir) (fromUnrootedFilePath path)
fromFilePath path = FileSystemPath $
rootPath (Rooted :: Rooted Relative) (fromUnrootedFilePath path)
makeAbsolute :: FileSystemPath -> IO AbsolutePath
makeAbsolute (FileSystemPath path) = do
let (root, unrooted) = unrootPath path
rootFilePath <- fromUnrootedFilePath <$> interpretRoot root
return $ rootPath Rooted (rootFilePath </> unrooted)
toAbsoluteFilePath :: IsFileSystemRoot root => Path (Rooted root) -> IO FilePath
toAbsoluteFilePath = fmap toFilePath . makeAbsolute . FileSystemPath
fromAbsoluteFilePath :: FilePath -> AbsolutePath
fromAbsoluteFilePath ('/':path) = rootPath Rooted (fromUnrootedFilePath path)
fromAbsoluteFilePath _ = error "fromAbsoluteFilePath: not an absolute path"
withFileInReadMode :: IsFileSystemRoot root
=> Path (Rooted root) -> (IO.Handle -> IO r) -> IO r
withFileInReadMode path callback = do
filePath <- toAbsoluteFilePath path
IO.withFile filePath IO.ReadMode callback
openTempFile :: forall root. IsFileSystemRoot root
=> Path (Rooted root) -> String -> IO (AbsolutePath, IO.Handle)
openTempFile path template = do
filePath <- toAbsoluteFilePath path
(tempFilePath, h) <- IO.openBinaryTempFileWithDefaultPermissions filePath template
return (fromAbsoluteFilePath tempFilePath, h)
readLazyByteString :: IsFileSystemRoot root
=> Path (Rooted root) -> IO BS.L.ByteString
readLazyByteString path = do
filePath <- toAbsoluteFilePath path
BS.L.readFile filePath
readStrictByteString :: IsFileSystemRoot root
=> Path (Rooted root) -> IO BS.ByteString
readStrictByteString path = do
filePath <- toAbsoluteFilePath path
BS.readFile filePath
createDirectoryIfMissing :: IsFileSystemRoot root
=> Bool -> Path (Rooted root) -> IO ()
createDirectoryIfMissing createParents path = do
filePath <- toAbsoluteFilePath path
Dir.createDirectoryIfMissing createParents filePath
doesFileExist :: IsFileSystemRoot root => Path (Rooted root) -> IO Bool
doesFileExist path = do
filePath <- toAbsoluteFilePath path
Dir.doesFileExist filePath
doesDirectoryExist :: IsFileSystemRoot root => Path (Rooted root) -> IO Bool
doesDirectoryExist path = do
filePath <- toAbsoluteFilePath path
Dir.doesDirectoryExist filePath
removeFile :: IsFileSystemRoot root => Path (Rooted root) -> IO ()
removeFile path = do
filePath <- toAbsoluteFilePath path
Dir.removeFile filePath
getTemporaryDirectory :: IO AbsolutePath
getTemporaryDirectory = fromAbsoluteFilePath <$> Dir.getTemporaryDirectory
getDirectoryContents :: IsFileSystemRoot root
=> Path (Rooted root) -> IO [UnrootedPath]
getDirectoryContents path = do
filePath <- toAbsoluteFilePath path
fragments <$> Dir.getDirectoryContents filePath
where
fragments :: [String] -> [UnrootedPath]
fragments = map fragment' . filter (not . skip)
skip :: String -> Bool
skip "." = True
skip ".." = True
skip _ = False
getRecursiveContents :: IsFileSystemRoot root
=> Path (Rooted root)
-> IO [UnrootedPath]
getRecursiveContents root = go PathNil
where
go :: UnrootedPath -> IO [UnrootedPath]
go subdir = do
entries <- getDirectoryContents (root </> subdir)
liftM concat $ forM entries $ \entry -> do
let path = subdir </> entry
isDirectory <- doesDirectoryExist (root </> path)
if isDirectory then go path
else return [path]
renameFile :: (IsFileSystemRoot root, IsFileSystemRoot root1)
=> Path (Rooted root)
-> Path (Rooted root1)
-> IO ()
renameFile old new = do
old' <- toAbsoluteFilePath old
new' <- toAbsoluteFilePath new
Dir.renameFile old' new'
getCurrentDirectory :: IO AbsolutePath
getCurrentDirectory = do
cwd <- Dir.getCurrentDirectory
makeAbsolute $ fromFilePath cwd
data TarballRoot
type TarballPath = Path (Rooted TarballRoot)
instance Show (Rooted TarballRoot) where show _ = "<tarball>"
tarIndexLookup :: TarIndex.TarIndex -> TarballPath -> Maybe TarIndex.TarIndexEntry
tarIndexLookup index path = TarIndex.lookup index path'
where
path' :: FilePath
path' = toUnrootedFilePath $ unrootPath' path
tarAppend :: (IsFileSystemRoot root, IsFileSystemRoot root')
=> Path (Rooted root)
-> Path (Rooted root')
-> [TarballPath]
-> IO ()
tarAppend tarFile baseDir contents = do
tarFile' <- toAbsoluteFilePath tarFile
baseDir' <- toAbsoluteFilePath baseDir
Tar.append tarFile' baseDir' contents'
where
contents' :: [FilePath]
contents' = map (toUnrootedFilePath . unrootPath') contents
data WebRoot
type URIPath = Path (Rooted WebRoot)
toURIPath :: FilePath -> URIPath
toURIPath = rootPath Rooted . fromUnrootedFilePath
fromURIPath :: URIPath -> FilePath
fromURIPath = toUnrootedFilePath . unrootPath'
uriPath :: URI.URI -> URIPath
uriPath = toURIPath . URI.uriPath
modifyUriPath :: URI.URI -> (URIPath -> URIPath) -> URI.URI
modifyUriPath uri f = uri { URI.uriPath = f' (URI.uriPath uri) }
where
f' :: FilePath -> FilePath
f' = fromURIPath . f . toURIPath
splitPath :: FilePath -> [FilePath]
splitPath = go []
where
go :: [FilePath] -> FilePath -> [FilePath]
go acc fp = case break FilePath.isPathSeparator fp of
("", []) -> reverse acc
(fr, []) -> reverse (fr:acc)
("", _:fp') -> go acc fp'
(fr, _:fp') -> go (fr:acc) fp'