module IO.Filesystem (
module System.FilePath,module Definitive,
File(..),DirEntry(..),
getFile,
workingDirectory,
Location(..),
pathTo,getConfig,
FS(..),Filesystem,file,
modTime,
contents,children,child,descendant,subEntry,anyEntry,entryName,entryFile,
named,withExtension,
fileName,entry,text,bytes
) where
import Definitive
import Control.DeepSeq
import IO.Time
import System.Directory
import System.FilePath ((</>),FilePath)
import System.IO.Unsafe
import System.Posix.Process (getProcessID)
import Data.Time.Clock.POSIX
import qualified Prelude as P
data File = File (Maybe String) (Maybe Bytes)
| Directory (Map String File)
instance Show File where
show (File _ _) = "File"
show (Directory d) = show d
instance Semigroup File where
Directory d + Directory d' = Directory ((d*d')+(d+d'))
a + _ = a
instance Monoid File where zero = File zero zero
data DirEntry = DirEntry FilePath File
deriving Show
instance Lens1 String String DirEntry DirEntry where
l'1 = from _DirEntry.l'1
instance Lens2 File File DirEntry DirEntry where
l'2 = from _DirEntry.l'2
fileName :: Lens' DirEntry String
fileName = l'1
entry :: Lens' DirEntry File
entry = l'2
il :: IO a -> IO a
il = unsafeInterleaveIO
getFile :: FilePath -> IO File
getFile path = do
d <- doesDirectoryExist path
if d then do
files <- unsafeInterleaveIO (getDirectoryContents path)
return $ Directory $ fromList [
(name,unsafePerformIO (getFile (path</>name)))
| name <- files, not (name`elem`[".",".."])]
else File<$>il (tryMay $ force<$>P.readFile path)
<*>il (tryMay $ readBytes path)
_File :: ((Maybe String,Maybe Bytes):+:Map String File) :<->: File
_File = iso f' f
where f (File x y) = Left (x,y)
f (Directory d) = Right d
f' = uncurry File <|> Directory
_DirEntry :: (FilePath,File) :<->: DirEntry
_DirEntry = iso (uncurry DirEntry) (\ ~(DirEntry p f) -> (p,f))
contents :: Traversal' File (Maybe String,Maybe Bytes)
contents = from _File.t'l
children :: Traversal' File (Map String File)
children = from _File.t'r
child :: Traversal' File File
child = children.traverse
descendant :: Fold' File File
descendant = id .+ child.descendant
subEntry :: Traversal' DirEntry DirEntry
subEntry = entryFile.children.keyed.traverse._DirEntry
anyEntry :: Fold' DirEntry DirEntry
anyEntry = id .+ subEntry.anyEntry
entryName :: Lens' DirEntry String
entryName = from _DirEntry.l'1
entryFile :: Lens' DirEntry File
entryFile = from _DirEntry.l'2
text :: Traversal' File String
text = contents.lens fst (const (,zero)).folded
bytes :: Traversal' File Bytes
bytes = contents.l'2.folded
named :: (String -> Bool) -> Traversal' DirEntry DirEntry
named p = sat (\(DirEntry name _) -> p name)
withExtension :: String -> Traversal' DirEntry DirEntry
withExtension e = named (\s -> drop (length s(length e+1)) s==('.':e))
workingDirectory :: IO DirEntry
workingDirectory = DirEntry "." <$> (getFile =<< getCurrentDirectory)
modTime :: FilePath -> IO (TimeVal Seconds)
modTime p = try (return minBound) (getModificationTime p <&> pure . realToFrac . utcTimeToPOSIXSeconds)
data Location = Here | Cache | Owner | System
pathTo :: ( ?progName :: FilePath ) => Location -> FilePath
pathTo Here = getCurrentDirectory^.thunk
pathTo Cache = (getTemporaryDirectory^.thunk) </> ?progName + "-" + show (getProcessID^.thunk)
pathTo Owner = getHomeDirectory^.thunk </> "." + ?progName
pathTo System = "/usr/share" </> ?progName
getConfig :: ( ?progName :: FilePath ) => IO File
getConfig = sum<$>sequence [getFile (pathTo d) | d <- [Owner,System]]
instance NFData File where
rnf (File _ (Just b)) = rnf b
rnf (File (Just a) _) = rnf a
rnf (Directory d) = rnf d
rnf _ = ()
newtype FS a = FS { runFS :: IO a }
deriving (Functor,Unit,Applicative,Monad,MonadFix)
instance MonadState Filesystem FS where
get = FS (return zero)
put (Filesystem fs) = FS $ fs`deepseq`for_ (fs^.keyed) $ \(k,f) -> remove k >> putFile k f
where putFile k (File _ (Just b)) = writeBytes k b
putFile k (File (Just s) _) = P.writeFile k s
putFile _ (File _ _) = unit
putFile k (Directory d) = for_ (d^.keyed) $ \(k',f) -> putFile (k+k') f
remove f = doesDirectoryExist f >>= \case
True -> getDirectoryContents f >>= \c -> traverse_ (remove . (f+)) ([]+refuse (`elem`[".",".."]) c)
>> removeDirectory f
False -> try unit (removeFile f)
newtype Filesystem = Filesystem (Map String File)
deriving (Semigroup,Monoid)
instance DataMap Filesystem String File where
at k = lens f g
where f (Filesystem m) = Just $ fromMaybe (getFile k^.thunk) $ m^.at k
g (Filesystem m) x = Filesystem (insert k (fold x) m)
file :: String -> Lens' Filesystem File
file f = at f.folded