{-# LANGUAGE FlexibleContexts #-}
module Backstop (backstop) where
import Control.Applicative ((<$>))
import Control.Exception (try)
import Control.Monad.Reader (ask,ReaderT,runReaderT,withReaderT)
import Control.Monad.State.Strict (put,lift,when,evalStateT,get,StateT,runStateT,filterM)
import Control.Monad.Trans (liftIO)
import Data.List ((\\),sort,delete)
import Data.Monoid
import Environment (Environment(..),defaultEnv)
import System.Exit (exitWith,ExitCode(..))
import System.FilePath ((</>),isAbsolute)
import System.Directory (createDirectory,removeDirectory,removeFile,getDirectoryContents)
import System.IO (stderr,hPutStrLn)
import System.IO.Error hiding (try)
import System.Posix.Files (readSymbolicLink,isDirectory,isSymbolicLink,createSymbolicLink,getSymbolicLinkStatus)
import Utils (aDirectory,compElems,absoluteLink,relativeLink,subdirectory,dot,dotdot,anObject)
backstop :: Environment -> IO ()
backstop e =
do bs <- runReaderT (if deBackstop e then _unbackstop else _backstop) e
when (report e) $ putBackstop bs
exitWith $ if errs bs > 0
then ExitFailure (if errs bs < 251 then errs bs else 255)
else ExitSuccess
data Backstop =
BS { calls :: Int
, depth :: Int
, breadth :: Int
, symlinks :: Int
, dirs :: Int
, errs :: Int
} deriving Eq
instance Semigroup Backstop where
bs1 <> bs2 = let add f = f bs1 + f bs2
biggest f = max (f bs1) (f bs2)
in BS (add calls)
(add depth)
(biggest breadth)
(add symlinks)
(add dirs)
(add errs)
instance Monoid Backstop where
mempty = BS 0 0 0 0 0 0
putBackstop :: Backstop -> IO ()
putBackstop bs =
hPutStrLn stderr ("Symlinks: " ++ (justify 5.show.symlinks) bs ++ "; " ++
"Dirs: " ++ (justify 4.show.dirs) bs ++ "; " ++
"Calls: " ++ (justify 4.show.calls) bs ++ "; " ++
"Depth: " ++ (justify 4.show.depth) bs ++ "; " ++
"Breadth: " ++ (justify 3.show.breadth) bs ++ "; " ++
"Errs: " ++ (justify 3.show.errs) bs
)
where
justify w s = let l = length s in (if l < w then (replicate (w-l) ' ' ++) else id) s
_backstop :: ReaderT Environment IO Backstop
_backstop =
do e <- ask
if (length.operands) e < 2
then return oneCall
else do bs1 <- __backstop
bs2 <- withReaderT nextSource _backstop
return (bs1 `mappend` bs2)
where
__backstop =
do e <- ask
let t = operands e !! 0
let s = operands e !! 1
(bs1, ts) <- listDirectoryContents t
(bs2, ss) <- listDirectoryContents s
let (ps12, _, ps2) = compElems ts ss
bs3 <- createObjects ps2
ds <- listDirectories (ps12++ps2)
bs4 <- mconcat <$> mapM (\d -> withReaderT (nextDepth d) __backstop) ds
(return.mconcat) [bs4, bs3, bs2, bs1, oneCall, if null ds then mempty else oneDepth]
createObjects :: [FilePath] -> ReaderT Environment IO Backstop
createObjects = fmap mconcat . mapM createObject
createObject :: FilePath -> ReaderT Environment IO Backstop
createObject p =
do e <- ask
if (length.operands) e < 2 then return mempty else _createObject p
where
prt p t s = liftIO $ putStr $ if p
then "mkdir " ++ "\"" ++ t ++ "\"\n"
else "ln -s " ++ "\"" ++ s ++ "\" " ++ "\"" ++ t ++ "\"\n"
_createObject p =
do e <- ask
let d = pwd e
let t = (operands e !! 0) </> p
let s = (operands e !! 1) </> p
let s_ = (if absolute e then absoluteLink else relativeLink) d t s
p <- liftIO $ fmap (populate e &&) (aDirectory s)
let one = if p then oneDir else oneSymlink
when (trace e) $ prt p t s_
if noAction e
then return one
else do (bs, _) <- tryOperation $ if p
then createDirectory t
else createSymbolicLink s_ t
return $ if bs /= mempty then bs else one
data DirectoryContentStatus = Occupied
| Emptied
| Empty
deriving Eq
instance Semigroup DirectoryContentStatus where
dcs1 <> dcs2 = case (dcs1, dcs2) of
(Occupied, _) -> Occupied
(_, Occupied) -> Occupied
(Empty, _) -> Empty
(_, Empty) -> Empty
(_,_) -> Emptied
instance Monoid DirectoryContentStatus where
mempty = Emptied
type DCS = DirectoryContentStatus
_unbackstop :: ReaderT Environment IO Backstop
_unbackstop =
do e <- ask
if (length.operands) e < 2
then return oneCall
else do
bs1 <- evalStateT __unbackstop Emptied
bs2 <- withReaderT nextSource _unbackstop
return (bs1 `mappend` bs2)
where
__unbackstop :: StateT DCS (ReaderT Environment IO) Backstop
__unbackstop =
do e <- ask
let t = operands e !! 0
(bs1, ts) <- lift $ listDirectoryContents t
ds <- lift $ listDirectories ts
let os = ts \\ ds
bs2 <- destroyObjects os
if null ds
then do put $ if symlinks bs2 /= length os then Occupied
else if null os then Empty else Emptied
(return.mconcat) [bs2, bs1, oneCall]
else do bs3 <- mconcat <$> mapM recurse ds
dcs <- get
put $ dcs `mappend` if symlinks bs2 /= length os then Occupied
else if null os then Empty else Emptied
(return.mconcat) [bs3, bs2, bs1, oneCall, oneDepth]
recurse :: FilePath -> StateT DCS (ReaderT Environment IO) Backstop
recurse d = do s1 <- get
(bs1, s2) <- lift $ withReaderT (nextDepth d) (runStateT __unbackstop Emptied)
put s2
bs2 <- destroyObjects [d]
s3 <- get
put (mconcat [s1, s2, s3])
(return.mconcat) [bs2, bs1]
destroyObjects :: [FilePath] -> StateT DCS (ReaderT Environment IO) Backstop
destroyObjects = fmap mconcat . mapM destroyObject
destroyObject :: FilePath -> StateT DCS (ReaderT Environment IO) Backstop
destroyObject p =
do e <- ask
if (length.operands) e < 2 then return mempty else _destroyObject p
where
_destroyObject p =
do e <- ask
let trg = (operands e !! 0) </> p
(bs, fs) <- lift $ tryOperation (getSymbolicLinkStatus trg)
if bs /= mempty
then return bs
else if isSymbolicLink fs
then destroySymlink p
else if isDirectory fs
then destroyDir p
else return mempty
destroySymlink :: FilePath -> StateT DCS (ReaderT Environment IO) Backstop
destroySymlink p =
do e <- ask
if (length.operands) e < 2 then return mempty else _destroySymlink p
where
prt sym = liftIO $ putStr ("rm -f " ++ "\"" ++ sym ++ "\"\n")
abs d p f = (if isAbsolute f then id else (d</>).(p</>)) f
rm e sym = do when (trace e) $ prt sym
if noAction e
then return oneSymlink
else do (bs, _) <- lift $ tryOperation (removeFile sym)
return $ if bs /= mempty then bs else oneSymlink
_destroySymlink p =
do e <- ask
let cwd = pwd e
let trg = operands e !! 0
let src = operands e !! 1
let sym = trg </> p
(bs, p) <- lift $ tryOperation (readSymbolicLink sym)
if bs /= mempty
then return bs
else if not $ abs cwd trg p `subdirectory` abs cwd "" src
then return mempty
else rm e sym
destroyDir :: FilePath -> StateT DCS (ReaderT Environment IO) Backstop
destroyDir p =
do e <- ask
if (length.operands) e < 2 || (not.populate) e then return mempty else _destroyDir p
where
prt dir = liftIO $ putStr ("rmdir \"" ++ dir ++"\"\n")
_destroyDir p =
do e <- ask
let trg = (operands e !! 0) </> p
let src = (operands e !! 1) </> p
sDir <- liftIO $ aDirectory src
dcs <- get
if ((dcs == Empty) && not sDir) || (dcs == Occupied)
then return mempty
else do when (trace e) $ prt trg
if noAction e
then return oneDir
else do (bs, _) <- lift $ tryOperation (removeDirectory trg)
if bs /= mempty
then do { put Occupied; return bs }
else do { put Emptied; return oneDir }
listDirectoryContents :: FilePath -> ReaderT Environment IO (Backstop, [FilePath])
listDirectoryContents p =
do directory <- liftIO $ aDirectory p
if directory
then do (bs, ps) <- tryOperation (sort . delete dotdot . delete dot <$> getDirectoryContents p)
return $ if bs /= mempty then (bs, []) else (mempty{breadth = length ps}, ps)
else return (mempty, [])
listDirectories :: [FilePath] -> ReaderT Environment IO [FilePath]
listDirectories ps =
let dir e p =
let t = (operands e !! 0) </> p
s = (operands e !! 1) </> p
in do tDir <- aDirectory t
sDir <- aDirectory s
tObj <- anObject t
return $ if deBackstop e then tDir
else if noAction e && populate e && not tObj
then sDir else tDir && sDir
in do e <- ask
if (length.operands) e < 2 then return [] else liftIO $ filterM (dir e) ps
tryOperation :: IO a -> ReaderT Environment IO (Backstop, a)
tryOperation io =
liftIO (try io) >>=
either (\ioe -> putIOE ioe >> return (oneErr, error "N/A")) (\x -> return (mempty, x))
putIOE :: IOError -> ReaderT Environment IO ()
putIOE ioe =
do e <- ask
let ln = ioeGetLocation ioe
let fn = ioeGetFileName ioe
let es = ioeGetErrorString ioe
let s = command e ++ ": " ++ ln ++ ": " ++ maybe es (++": "++es) fn
liftIO $ hPutStrLn stderr s
nextDepth :: FilePath -> Environment -> Environment
nextDepth p e =
if (length.operands) e < 2
then e
else let t = operands e !! 0
s = operands e !! 1
in e{operands=[t </> p, s </> p]}
nextSource :: Environment -> Environment
nextSource e =
if (length.operands) e < 2
then e
else e{operands=(head.operands) e : (tail.tail.operands) e}
oneCall :: Backstop
oneCall = mempty{calls = 1}
oneDepth :: Backstop
oneDepth = mempty{depth = 1}
oneSymlink :: Backstop
oneSymlink = mempty{symlinks = 1}
oneDir :: Backstop
oneDir = mempty{dirs = 1}
oneErr :: Backstop
oneErr = mempty{errs = 1}