1 -- Copyright (C) 2005 David Roundy
    2 --
    3 -- This program is free software; you can redistribute it and/or modify
    4 -- it under the terms of the GNU General Public License as published by
    5 -- the Free Software Foundation; either version 2, or (at your option)
    6 -- any later version.
    7 --
    8 -- This program is distributed in the hope that it will be useful,
    9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 -- GNU General Public License for more details.
   12 --
   13 -- You should have received a copy of the GNU General Public License
   14 -- along with this program; see the file COPYING.  If not, write to
   15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 -- Boston, MA 02110-1301, USA.
   17 
   18 {-# OPTIONS_GHC -fglasgow-exts #-}
   19 module Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..),
   20                   TolerantIO, runTolerantly, runSilently,
   21                 ) where
   22 
   23 import Prelude hiding ( catch )
   24 import Data.Char ( toLower )
   25 import Data.List ( isSuffixOf )
   26 import System.IO.Error ( isDoesNotExistError, isPermissionError )
   27 import Control.Exception ( catch, catchJust, ioErrors )
   28 import Control.Monad.Error
   29 import System.Directory ( getDirectoryContents, createDirectory,
   30                           removeDirectory, removeFile,
   31                           renameFile, renameDirectory,
   32                           doesDirectoryExist, doesFileExist,
   33                         )
   34 
   35 import ByteStringUtils ( linesPS, unlinesPS)
   36 import qualified Data.ByteString as B (ByteString, empty, null, readFile)
   37 import qualified Data.ByteString.Char8 as BC (unpack, pack)
   38 
   39 import Darcs.Utils ( withCurrentDirectory, prettyException )
   40 import Darcs.External ( backupByCopying, backupByRenaming )
   41 import Printer ( Doc, renderPS )
   42 import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn )
   43 import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS )
   44 import Workaround ( setExecutable )
   45 
   46 class (Functor m, MonadPlus m) => ReadableDirectory m where
   47     mDoesDirectoryExist :: FileName -> m Bool
   48     mDoesFileExist :: FileName -> m Bool
   49     mInCurrentDirectory :: FileName -> m a -> m a
   50     mGetDirectoryContents :: m [FileName]
   51     mReadBinFile :: FileName -> m String
   52     mReadBinFile f = liftM BC.unpack $ mReadFilePS f
   53     mReadFilePS :: FileName -> m B.ByteString
   54     mReadFilePSs :: FileName -> m [B.ByteString]
   55     mReadFilePSs f = linesPS `liftM` mReadFilePS f
   56 
   57 class ReadableDirectory m => WriteableDirectory m where
   58     mWithCurrentDirectory :: FileName -> m a -> m a
   59     mSetFileExecutable :: FileName -> Bool -> m ()
   60     mWriteBinFile :: FileName -> String -> m ()
   61     mWriteBinFile fn s = mWriteFilePS fn $ BC.pack s
   62     mWriteFilePS :: FileName -> B.ByteString -> m ()
   63     mWriteFilePSs :: FileName -> [B.ByteString] -> m ()
   64     mWriteFilePSs f ss = mWriteFilePS f (unlinesPS ss)
   65     mCreateDirectory :: FileName -> m ()
   66     mRemoveDirectory :: FileName -> m ()
   67     mWriteDoc :: FileName -> Doc -> m ()
   68     mWriteDoc f d = mWriteFilePS f (renderPS d)
   69     mCreateFile :: FileName -> m ()
   70     mCreateFile f = mWriteFilePS f B.empty
   71     mRemoveFile :: FileName -> m ()
   72     mRename :: FileName -> FileName -> m ()
   73     mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m ()
   74     mModifyFilePS f j = do ps <- mReadFilePS f
   75                            ps' <- j ps
   76                            mWriteFilePS f ps'
   77     mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()
   78     mModifyFilePSs f j = do ps <- mReadFilePSs f
   79                             ps' <- j ps
   80                             mWriteFilePSs f ps'
   81 
   82 instance ReadableDirectory IO where
   83     mDoesDirectoryExist = doesDirectoryExist . fn2fp
   84     mDoesFileExist = doesFileExist . fn2fp
   85     mInCurrentDirectory = withCurrentDirectory . fn2fp
   86     mGetDirectoryContents = map fp2fn `liftM` getDirectoryContents "."
   87     mReadBinFile = readBinFile . fn2fp
   88     mReadFilePS = B.readFile . fn2fp
   89 
   90 instance WriteableDirectory IO where
   91     mWithCurrentDirectory = mInCurrentDirectory
   92     mSetFileExecutable = setExecutable . fn2fp
   93     mWriteBinFile = writeBinFile . fn2fp
   94     mWriteFilePS = writeAtomicFilePS . fn2fp
   95     mCreateDirectory = createDirectory . fn2fp
   96     mCreateFile f = do exf <- mDoesFileExist f
   97                        if exf then fail $ "File '"++fn2fp f++"' already exists!"
   98                               else do exd <- mDoesDirectoryExist f
   99                                       if exd then fail $ "File '"++fn2fp f++"' already exists!"
  100                                              else mWriteFilePS f B.empty
  101     mRemoveFile f = do let fp = fn2fp f
  102                        x <- B.readFile fp
  103                        when (not $ B.null x) $
  104                             fail $ "Cannot remove non-empty file "++fp
  105                        removeFile fp
  106     mRemoveDirectory = removeDirectory . fn2fp
  107     mRename a b = catchJust ioErrors
  108                   (renameDirectory x y `mplus` renameFile x y)
  109                   -- We need to catch does not exist errors, since older
  110                   -- versions of darcs allowed users to rename nonexistent
  111                   -- files.  :(
  112                   (\e -> if isDoesNotExistError e
  113                                  then return ()
  114                                  else ioError e)
  115       where x = fn2fp a
  116             y = fn2fp b
  117 
  118 class Monad m => TolerantMonad m where
  119     warning :: IO () -> m ()
  120     runIO :: m a -> IO a
  121     runTM :: IO a -> m a
  122 
  123 newtype TolerantIO a = TIO { runTolerantly :: IO a }
  124 instance TolerantMonad TolerantIO where
  125     warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e
  126     runIO (TIO io) = io
  127     runTM io = TIO io
  128 
  129 newtype SilentIO a = SIO { runSilently :: IO a }
  130 instance TolerantMonad SilentIO where
  131     warning io = SIO $ io `catch` \_ -> return ()
  132     runIO (SIO io) = io
  133     runTM io = SIO io
  134 
  135 -- NOTE: The following instance declarations are duplicated merely to avoid
  136 -- enabling -fallow-undecidable-instances.  If we used
  137 -- -fallow-undecidable-instances, we would write instead:
  138 
  139 -- instance TolerantMonad m => Monad m where
  140 --      ...
  141 
  142 -- etc.
  143 instance Functor TolerantIO where
  144     fmap f m = m >>= return . f
  145 
  146 instance Monad TolerantIO where
  147     f >>= g = runTM $ runIO f >>= runIO . g
  148     f >> g = runTM $ runIO f >> runIO g
  149     fail s = runTM $ fail s
  150     return x = runTM $ return x
  151 
  152 instance Functor SilentIO where
  153     fmap f m = m >>= return . f
  154 
  155 instance Monad SilentIO where
  156     f >>= g = runTM $ runIO f >>= runIO . g
  157     f >> g = runTM $ runIO f >> runIO g
  158     fail s = runTM $ fail s
  159     return x = runTM $ return x
  160 
  161 instance MonadPlus TolerantIO where
  162     mzero = runTM mzero
  163     mplus a b = runTM (mplus (runIO a) (runIO b))
  164 instance MonadPlus SilentIO where
  165     mzero = runTM mzero
  166     mplus a b = runTM (mplus (runIO a) (runIO b))
  167 
  168 instance ReadableDirectory TolerantIO where
  169     mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d
  170     mDoesFileExist f = runTM $ mDoesFileExist f
  171     mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)
  172     mGetDirectoryContents = runTM mGetDirectoryContents
  173     mReadBinFile f = runTM $ mReadBinFile f
  174     mReadFilePS f = runTM $ mReadFilePS f
  175 instance ReadableDirectory SilentIO where
  176     mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d
  177     mDoesFileExist f = runTM $ mDoesFileExist f
  178     mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)
  179     mGetDirectoryContents = runTM mGetDirectoryContents
  180     mReadBinFile f = runTM $ mReadBinFile f
  181     mReadFilePS f = runTM $ mReadFilePS f
  182 
  183 instance WriteableDirectory TolerantIO where
  184      mWithCurrentDirectory = mInCurrentDirectory
  185      mSetFileExecutable f e = warning $ mSetFileExecutable f e
  186      mWriteBinFile f s = warning $ mWriteBinFile f s
  187      mWriteFilePS f s = warning $ mWriteFilePS f s
  188      mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty
  189      mCreateDirectory d = warning $ backup d >> mCreateDirectory d
  190      mRemoveFile f = warning $ mRemoveFile f
  191      mRemoveDirectory d = warning $ catchJust ioErrors
  192                                  (mRemoveDirectory d)
  193                                  (\e ->
  194                                    if "(Directory not empty)" `isSuffixOf` show e
  195                                    then ioError $ userError $
  196                                             "Not deleting " ++ fn2fp d ++ " because it is not empty."
  197                                    else ioError $ userError $
  198                                             "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)
  199      mRename a b = warning $ catchJust ioErrors
  200                           (let do_backup = if (map toLower x == map toLower y)
  201                                            then backupByCopying y -- avoid making the original vanish
  202                                            else backupByRenaming y
  203                            in do_backup >> mRename a b)
  204                           (\e -> case () of
  205                                  _ | isPermissionError e -> ioError $ userError $
  206                                        couldNotRename ++ "."
  207                                    | isDoesNotExistError e -> ioError $ userError $
  208                                        couldNotRename ++ " because " ++ x ++ " does not exist."
  209                                    | otherwise -> ioError e
  210                           )
  211        where
  212         x = fn2fp a
  213         y = fn2fp b
  214         couldNotRename = "Could not rename " ++ x ++ " to " ++ y
  215 instance WriteableDirectory SilentIO where
  216      mWithCurrentDirectory = mInCurrentDirectory
  217      mSetFileExecutable f e = warning $ mSetFileExecutable f e
  218      mWriteBinFile f s = warning $ mWriteBinFile f s
  219      mWriteFilePS f s = warning $ mWriteFilePS f s
  220      mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty
  221      mCreateDirectory d = warning $ backup d >> mCreateDirectory d
  222      mRemoveFile f = warning $ mRemoveFile f
  223      mRemoveDirectory d = warning $ catchJust ioErrors
  224                                  (mRemoveDirectory d)
  225                                  (\e ->
  226                                    if "(Directory not empty)" `isSuffixOf` show e
  227                                    then ioError $ userError $
  228                                             "Not deleting " ++ fn2fp d ++ " because it is not empty."
  229                                    else ioError $ userError $
  230                                             "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)
  231      mRename a b = warning $ catchJust ioErrors
  232                           (let do_backup = if (map toLower x == map toLower y)
  233                                            then backupByCopying y -- avoid making the original vanish
  234                                            else backupByRenaming y
  235                            in do_backup >> mRename a b)
  236                           (\e -> case () of
  237                                  _ | isPermissionError e -> ioError $ userError $
  238                                        couldNotRename ++ "."
  239                                    | isDoesNotExistError e -> ioError $ userError $
  240                                        couldNotRename ++ " because " ++ x ++ " does not exist."
  241                                    | otherwise -> ioError e
  242                           )
  243        where
  244         x = fn2fp a
  245         y = fn2fp b
  246         couldNotRename = "Could not rename " ++ x ++ " to " ++ y
  247 
  248 backup :: FileName -> IO ()
  249 backup f = backupByRenaming $ fn2fp f