module Hackage.Security.Util.Path (
Path(..)
, castRoot
, takeDirectory
, takeFileName
, (<.>)
, splitExtension
, Unrooted
, (</>)
, rootPath
, unrootPath
, toUnrootedFilePath
, fromUnrootedFilePath
, fragment
, joinFragments
, isPathPrefixOf
, Relative
, Absolute
, HomeDir
, FsRoot(..)
, FsPath(..)
, toFilePath
, fromFilePath
, makeAbsolute
, fromAbsoluteFilePath
, withFile
, openTempFile'
, readLazyByteString
, readStrictByteString
, writeLazyByteString
, writeStrictByteString
, copyFile
, createDirectory
, createDirectoryIfMissing
, removeDirectory
, doesFileExist
, doesDirectoryExist
, removeFile
, getTemporaryDirectory
, getDirectoryContents
, getRecursiveContents
, renameFile
, getCurrentDirectory
, Tar
, tarIndexLookup
, tarAppend
, Web
, toURIPath
, fromURIPath
, uriPath
, modifyUriPath
, IOMode(..)
, BufferMode(..)
, Handle
, SeekMode(..)
, IO.hSetBuffering
, IO.hClose
, IO.hFileSize
, IO.hSeek
) where
import Control.Monad
import Data.List (isPrefixOf)
import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..))
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.L
import qualified System.FilePath as FP
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 Path a = Path { unPath :: FilePath }
deriving (Show, Eq, Ord)
castRoot :: Path root -> Path root'
castRoot (Path fp) = Path fp
takeDirectory :: Path a -> Path a
takeDirectory = liftFP FP.takeDirectory
takeFileName :: Path a -> String
takeFileName = liftFromFP FP.takeFileName
(<.>) :: Path a -> String -> Path a
fp <.> ext = liftFP (FP.<.> ext) fp
splitExtension :: Path a -> (Path a, String)
splitExtension (Path fp) = (Path fp', ext)
where
(fp', ext) = FP.splitExtension fp
data Unrooted
instance Pretty (Path Unrooted) where
pretty (Path fp) = fp
(</>) :: Path a -> Path Unrooted -> Path a
(</>) = liftFP2 (FP.</>)
rootPath :: Path Unrooted -> Path root
rootPath (Path fp) = Path fp
unrootPath :: Path root -> Path Unrooted
unrootPath (Path fp) = Path fp
toUnrootedFilePath :: Path Unrooted -> FilePath
toUnrootedFilePath = unPath
fromUnrootedFilePath :: FilePath -> Path Unrooted
fromUnrootedFilePath = Path
fragment :: String -> Path Unrooted
fragment = fromUnrootedFilePath
joinFragments :: [String] -> Path Unrooted
joinFragments = liftToFP FP.joinPath
isPathPrefixOf :: Path Unrooted -> Path Unrooted -> Bool
isPathPrefixOf = liftFromFP2 isPrefixOf
data Relative
data Absolute
data HomeDir
instance Pretty (Path Absolute) where
pretty (Path fp) = fp
instance Pretty (Path Relative) where
pretty (Path fp) = "./" ++ fp
instance Pretty (Path HomeDir) where
pretty (Path fp) = "~/" ++ fp
class FsRoot root where
toAbsoluteFilePath :: Path root -> IO FilePath
instance FsRoot Relative where
toAbsoluteFilePath (Path fp) = go fp
where
go :: FilePath -> IO FilePath
#if MIN_VERSION_directory(1,2,2)
go = Dir.makeAbsolute
#else
go = (FP.normalise <$>) . absolutize
absolutize path
| FP.isRelative path = (FP.</> path) . FP.addTrailingPathSeparator <$>
Dir.getCurrentDirectory
| otherwise = return path
#endif
instance FsRoot Absolute where
toAbsoluteFilePath (Path fp) = return fp
instance FsRoot HomeDir where
toAbsoluteFilePath (Path fp) = do
home <- Dir.getHomeDirectory
return $ home FP.</> fp
data FsPath = forall root. FsRoot root => FsPath (Path root)
toFilePath :: Path Absolute -> FilePath
toFilePath (Path fp) = fp
fromFilePath :: FilePath -> FsPath
fromFilePath fp
| FP.isAbsolute fp = FsPath (Path fp :: Path Absolute)
| Just fp' <- atHome fp = FsPath (Path fp' :: Path HomeDir)
| otherwise = FsPath (Path fp :: Path Relative)
where
atHome :: FilePath -> Maybe FilePath
atHome "~" = Just ""
atHome ('~':sep:fp') | FP.isPathSeparator sep = Just fp'
atHome _otherwise = Nothing
makeAbsolute :: FsPath -> IO (Path Absolute)
makeAbsolute (FsPath p) = Path <$> toAbsoluteFilePath p
fromAbsoluteFilePath :: FilePath -> Path Absolute
fromAbsoluteFilePath fp
| FP.isAbsolute fp = Path fp
| otherwise = error "fromAbsoluteFilePath: not an absolute path"
withFile :: FsRoot root => Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile path mode callback = do
filePath <- toAbsoluteFilePath path
IO.withFile filePath mode callback
openTempFile' :: FsRoot root => Path root -> String -> IO (Path Absolute, Handle)
openTempFile' path template = do
filePath <- toAbsoluteFilePath path
(tempFilePath, h) <- IO.openBinaryTempFileWithDefaultPermissions filePath template
return (fromAbsoluteFilePath tempFilePath, h)
readLazyByteString :: FsRoot root => Path root -> IO BS.L.ByteString
readLazyByteString path = do
filePath <- toAbsoluteFilePath path
BS.L.readFile filePath
readStrictByteString :: FsRoot root => Path root -> IO BS.ByteString
readStrictByteString path = do
filePath <- toAbsoluteFilePath path
BS.readFile filePath
writeLazyByteString :: FsRoot root => Path root -> BS.L.ByteString -> IO ()
writeLazyByteString path bs = do
filePath <- toAbsoluteFilePath path
BS.L.writeFile filePath bs
writeStrictByteString :: FsRoot root => Path root -> BS.ByteString -> IO ()
writeStrictByteString path bs = do
filePath <- toAbsoluteFilePath path
BS.writeFile filePath bs
copyFile :: (FsRoot root, FsRoot root') => Path root -> Path root' -> IO ()
copyFile src dst = do
src' <- toAbsoluteFilePath src
dst' <- toAbsoluteFilePath dst
Dir.copyFile src' dst'
createDirectory :: FsRoot root => Path root -> IO ()
createDirectory path = Dir.createDirectory =<< toAbsoluteFilePath path
createDirectoryIfMissing :: FsRoot root => Bool -> Path root -> IO ()
createDirectoryIfMissing createParents path = do
filePath <- toAbsoluteFilePath path
Dir.createDirectoryIfMissing createParents filePath
removeDirectory :: FsRoot root => Path root -> IO ()
removeDirectory path = Dir.removeDirectory =<< toAbsoluteFilePath path
doesFileExist :: FsRoot root => Path root -> IO Bool
doesFileExist path = do
filePath <- toAbsoluteFilePath path
Dir.doesFileExist filePath
doesDirectoryExist :: FsRoot root => Path root -> IO Bool
doesDirectoryExist path = do
filePath <- toAbsoluteFilePath path
Dir.doesDirectoryExist filePath
removeFile :: FsRoot root => Path root -> IO ()
removeFile path = do
filePath <- toAbsoluteFilePath path
Dir.removeFile filePath
getTemporaryDirectory :: IO (Path Absolute)
getTemporaryDirectory = fromAbsoluteFilePath <$> Dir.getTemporaryDirectory
getDirectoryContents :: FsRoot root => Path root -> IO [Path Unrooted]
getDirectoryContents path = do
filePath <- toAbsoluteFilePath path
fragments <$> Dir.getDirectoryContents filePath
where
fragments :: [String] -> [Path Unrooted]
fragments = map fromUnrootedFilePath . filter (not . skip)
skip :: String -> Bool
skip "." = True
skip ".." = True
skip _ = False
getRecursiveContents :: FsRoot root => Path root -> IO [Path Unrooted]
getRecursiveContents root = go emptyPath
where
go :: Path Unrooted -> IO [Path Unrooted]
go subdir = unsafeInterleaveIO $ 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]
emptyPath :: Path Unrooted
emptyPath = Path (FP.joinPath [])
renameFile :: (FsRoot root, FsRoot root')
=> Path root
-> Path root'
-> IO ()
renameFile old new = do
old' <- toAbsoluteFilePath old
new' <- toAbsoluteFilePath new
Dir.renameFile old' new'
getCurrentDirectory :: IO (Path Absolute)
getCurrentDirectory = do
cwd <- Dir.getCurrentDirectory
makeAbsolute $ fromFilePath cwd
data Tar
instance Pretty (Path Tar) where
pretty (Path fp) = "<tarball>/" ++ fp
tarIndexLookup :: TarIndex.TarIndex -> Path Tar -> Maybe TarIndex.TarIndexEntry
tarIndexLookup index path = TarIndex.lookup index path'
where
path' :: FilePath
path' = toUnrootedFilePath $ unrootPath path
tarAppend :: (FsRoot root, FsRoot root')
=> Path root
-> Path root'
-> [Path Tar]
-> 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 Web
toURIPath :: FilePath -> Path Web
toURIPath = rootPath . fromUnrootedFilePath
fromURIPath :: Path Web -> FilePath
fromURIPath = toUnrootedFilePath . unrootPath
uriPath :: URI.URI -> Path Web
uriPath = toURIPath . URI.uriPath
modifyUriPath :: URI.URI -> (Path Web -> Path Web) -> URI.URI
modifyUriPath uri f = uri { URI.uriPath = f' (URI.uriPath uri) }
where
f' :: FilePath -> FilePath
f' = fromURIPath . f . toURIPath
liftFP :: (FilePath -> FilePath) -> Path a -> Path b
liftFP f (Path fp) = Path (f fp)
liftFP2 :: (FilePath -> FilePath -> FilePath) -> Path a -> Path b -> Path c
liftFP2 f (Path fp) (Path fp') = Path (f fp fp')
liftFromFP :: (FilePath -> x) -> Path a -> x
liftFromFP f (Path fp) = f fp
liftFromFP2 :: (FilePath -> FilePath -> x) -> Path a -> Path b -> x
liftFromFP2 f (Path fp) (Path fp') = f fp fp'
liftToFP :: (x -> FilePath) -> x -> Path a
liftToFP f x = Path (f x)