{-# LANGUAGE OverloadedStrings #-}

-- | A file system confined to one directory of another.
module Test.Util.FS.Subdirectory (subdirectoryHasFS) where

import System.FS.API (HasFS (..))
import System.FS.API.Types (FsPath, fsPathToList, (</>))

-- | The given file system, with every path taken relative to the given
-- directory in it, as 'System.FS.IO.ioHasFS' takes every path relative to its
-- 'System.FS.API.Types.MountPoint'.
--
-- Neither the directory nor any path may have a @..@ component, since that
-- could escape the directory.
subdirectoryHasFS :: FsPath -> HasFS m h -> HasFS m h
subdirectoryHasFS :: forall (m :: * -> *) h. FsPath -> HasFS m h -> HasFS m h
subdirectoryHasFS FsPath
dir HasFS m h
fs =
  HasFS m h
fs
    { hOpen = \FsPath
path OpenMode
mode -> HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hOpen HasFS m h
fs (FsPath -> FsPath
under FsPath
path) OpenMode
mode
    , createDirectory = \FsPath
path -> HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
createDirectory HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , createDirectoryIfMissing = \Bool
parents FsPath
path -> HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
fs Bool
parents (FsPath -> FsPath
under FsPath
path)
    , listDirectory = \FsPath
path -> HasFS m h -> HasCallStack => FsPath -> m (Set [Char])
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set [Char])
listDirectory HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , doesDirectoryExist = \FsPath
path -> HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , doesFileExist = \FsPath
path -> HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , removeDirectoryRecursive = \FsPath
path -> HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeDirectoryRecursive HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , removeFile = \FsPath
path -> HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , renameFile = \FsPath
from FsPath
to -> HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
renameFile HasFS m h
fs (FsPath -> FsPath
under FsPath
from) (FsPath -> FsPath
under FsPath
to)
    , mkFsErrorPath = \FsPath
path -> HasFS m h -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
mkFsErrorPath HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    , unsafeToFilePath = \FsPath
path -> HasFS m h -> FsPath -> m [Char]
forall (m :: * -> *) h. HasFS m h -> FsPath -> m [Char]
unsafeToFilePath HasFS m h
fs (FsPath -> FsPath
under FsPath
path)
    }
 where
  under :: FsPath -> FsPath
under FsPath
path = FsPath -> FsPath
noParent FsPath
dir FsPath -> FsPath -> FsPath
</> FsPath -> FsPath
noParent FsPath
path

noParent :: FsPath -> FsPath
noParent :: FsPath -> FsPath
noParent FsPath
path
  | Text
".." Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FsPath -> [Text]
fsPathToList FsPath
path =
      [Char] -> FsPath
forall a. HasCallStack => [Char] -> a
error ([Char] -> FsPath) -> [Char] -> FsPath
forall a b. (a -> b) -> a -> b
$ [Char]
"subdirectoryHasFS: a path has a .. component: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FsPath -> [Char]
forall a. Show a => a -> [Char]
show FsPath
path
  | Bool
otherwise = FsPath
path