{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.Export.FSTree(FSEntry,
FSTree,
filesToTree,
fstreeSource)
where
import Control.Conditional(whenM)
import Control.Monad(foldM)
import Control.Monad.Except(MonadError, throwError)
import Control.Monad.State(StateT, evalStateT, get, modify, withStateT)
import Data.Conduit(Sink, Source, yield)
import qualified Data.Conduit.List as CL
import Data.List.Safe(init, last)
import qualified Data.Text as T
import Data.Tree(Tree(..))
import System.FilePath(joinPath, splitDirectories)
import System.Posix.Files(directoryMode, fileTypeModes, intersectFileModes, symbolicLinkMode)
import System.Posix.Types(FileMode)
import BDCS.DB(Files(..))
import Prelude hiding(init, last)
type FSEntry = (FilePath, Maybe Files)
type FSTree = Tree FSEntry
filesToTree :: MonadError String m => Sink Files m FSTree
filesToTree =
let
rootTree = Node{rootLabel=("", Nothing), subForest=[]}
in
CL.foldM addFileToTree rootTree
addFileToTree :: MonadError String m => FSTree -> Files -> m FSTree
addFileToTree root object = do
let rootZipper = (root, [])
let pathComponents = splitDirectories $ T.unpack $ filesPath object
dirComponents <- maybe (throwError $ "Invalid path on " ++ show object) return $ init pathComponents
lastComponent <- maybe (throwError $ "Invalid path on " ++ show object) return $ last pathComponents
dirZipper <- evalStateT (findDirectory rootZipper dirComponents) 0
let newEntry = Node (lastComponent, Just object) []
getTree <$> evalStateT (addEntryToTree dirZipper newEntry) 0
where
findDirectory :: MonadError String m => FSZipper -> [FilePath] -> StateT Int m FSZipper
findDirectory zipper [] = return zipper
findDirectory zipper (".":xs) = findDirectory zipper xs
findDirectory zipper ("..":xs) = findDirectory (goUp zipper) xs
findDirectory zipper (pathComponent:xs) =
let
placeholder = Node (pathComponent, Nothing) []
in
case findChild pathComponent zipper of
Nothing -> findDirectory (addChild placeholder zipper) xs
Just childZipper@(Node{..}, _) -> case categorize rootLabel of
Placeholder -> findDirectory childZipper xs
Directory _ -> findDirectory childZipper xs
Symlink link -> do
whenM ((>= maxSymlinks) <$> get) $
throwError $ "Too many levels of symbolic links while resolving " ++ T.unpack (filesPath object)
linkZipper <- withStateT (+1) $ resolveSymlink zipper link
findDirectory linkZipper xs
Other existing -> throwError $ "Unable to resolve path " ++ T.unpack (filesPath object) ++
", non-directory object exists at " ++ T.unpack (filesPath existing)
resolveSymlink :: MonadError String m => FSZipper -> Files -> StateT Int m FSZipper
resolveSymlink zipper Files{..} = do
symlinkTarget <- maybe (throwError $ "Error: symlink with no target at " ++ T.unpack filesPath)
(return . T.unpack) filesTarget
let pathComponents = splitDirectories symlinkTarget
let startZipper = if head pathComponents == "/" then getRoot zipper else zipper
findDirectory startZipper pathComponents
addEntryToTree :: MonadError String m => FSZipper -> FSTree -> StateT Int m FSZipper
addEntryToTree zipper newEntry = do
let entryName = fst $ rootLabel newEntry
let maybeExisting = findChild entryName zipper
case maybeExisting of
Nothing -> return $ addChild newEntry zipper
Just existing@(self, crumbs) -> case ((categorize . rootLabel) self, (categorize . rootLabel) newEntry) of
(Placeholder, Placeholder) -> addChildren existing newEntry
(Placeholder, Directory _) -> addChildren (newEntry, crumbs) self
(Placeholder, Symlink s) -> do
let newZipper = (newEntry, crumbs)
targetZipper <- withStateT (+1) $ resolveSymlink (goUp newZipper) s
addChildren targetZipper self
(Placeholder, _) -> throwError $ "Unable to add " ++ T.unpack (filesPath object) ++
", directory added at path"
(Directory _, Placeholder) -> addChildren existing newEntry
(Directory d1, Directory d2) -> if compareDirs d1 d2 then addChildren existing newEntry
else throwError $ "Unable to add " ++ T.unpack (filesPath object) ++
", file already added at this location"
(Directory _, _) -> throwError $ "Unable to to add " ++ T.unpack (filesPath object) ++
", file already added at this location"
(Symlink s, _) -> do
whenM ((>= maxSymlinks) <$> get) $
throwError $ "Too many levels of symbolic links while resolving " ++ T.unpack (filesPath object)
modify (+1)
targetZipper <- resolveSymlink zipper s
addEntryToTree targetZipper newEntry
_ -> if self == newEntry then return existing
else throwError $ "Unable to add " ++ T.unpack (filesPath object) ++
", file already added at this location"
addChildren :: MonadError String m => FSZipper -> FSTree -> StateT Int m FSZipper
addChildren dirZipper newEntry = foldM (\z e -> goUp <$> addEntryToTree z e) dirZipper (subForest newEntry)
compareDirs :: Files -> Files -> Bool
compareDirs f1 f2 = f1{filesMtime=0, filesSize=0} == f2{filesMtime=0, filesSize=0}
fstreeSource :: Monad m => FSTree -> Source m Files
fstreeSource root = fstreeSource' [] root
where
fstreeSource' :: Monad m => [FilePath] -> FSTree -> Source m Files
fstreeSource' prefix Node{rootLabel=(pathComponent, maybeFile), ..} =
let newPrefix = prefix ++ [pathComponent]
in yieldEntry (joinPath newPrefix) maybeFile >>
mapM_ (fstreeSource' newPrefix) subForest
yieldEntry _ Nothing = return ()
yieldEntry realPath (Just f) = yield f{filesPath=T.pack realPath}
type FSCrumb = (FSEntry, [FSTree], [FSTree])
type FSZipper = (FSTree, [FSCrumb])
goUp :: FSZipper -> FSZipper
goUp (self, (entry, left, right):crumbs) = (Node entry (left ++ [self] ++ right), crumbs)
goUp zipper@(_, []) = zipper
getRoot :: FSZipper -> FSZipper
getRoot zipper@(_, []) = zipper
getRoot zipper = getRoot $ goUp zipper
getTree :: FSZipper -> FSTree
getTree zipper = fst $ getRoot zipper
findChild :: FilePath -> FSZipper -> Maybe FSZipper
findChild pathComponent (self, crumbs) =
case break ((== pathComponent) . fst . rootLabel) $ subForest self of
(_, []) -> Nothing
(left, node:right) -> let newCrumb = (rootLabel self, left, right)
in Just (node, newCrumb:crumbs)
addChild :: FSTree -> FSZipper -> FSZipper
addChild subTree (Node{..}, crumbs) =
let newCrumb = (rootLabel, subForest, [])
in (subTree, newCrumb:crumbs)
data FSCategory = Placeholder
| Directory Files
| Symlink Files
| Other Files
categorize :: FSEntry -> FSCategory
categorize (_, Nothing) = Placeholder
categorize (_, Just f@Files{..}) =
if | isDirectory -> Directory f
| isSymlink -> Symlink f
| otherwise -> Other f
where
getFileMode :: FileMode
getFileMode = fromIntegral filesMode `intersectFileModes` fileTypeModes
isDirectory :: Bool
isDirectory = getFileMode == directoryMode
isSymlink :: Bool
isSymlink = getFileMode == symbolicLinkMode
maxSymlinks :: Int
maxSymlinks = 40