src/Darcs/IO.lhs

   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
  19 \documentclass{article}
  20
  21 \usepackage{verbatim}
  22 \newenvironment{code}{\verbatim}{\endverbatim}
  23
  24 \begin{document}
  25
  26 \title{The DarcsIO library}
  27 \author{David Roundy}
  28
  29 \maketitle
  30
  31 \begin{abstract}
  32 This paper hasn't been written.
  33 \end{abstract}
  34
  35 \begin{comment}
  36 \begin{code}
  37 {-# OPTIONS_GHC -fglasgow-exts #-}
  38 module Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..),
  39                   TolerantIO, runTolerantly, runSilently,
  40                 ) where
  41
  42 import Prelude hiding ( catch )
  43 import Data.Char ( toLower )
  44 import Data.List ( isSuffixOf )
  45 import System.IO.Error ( isDoesNotExistError, isPermissionError )
  46 import Control.Exception ( catch, catchJust, ioErrors )
  47 import Control.Monad.Error
  48 import System.Directory ( getDirectoryContents, createDirectory,
  49                           removeDirectory, removeFile,
  50                           renameFile, renameDirectory,
  51                           doesDirectoryExist, doesFileExist,
  52                         )
  53
  54 import ByteStringUtils ( linesPS, unlinesPS)
  55 import qualified Data.ByteString as B (ByteString, empty, null, readFile)
  56 import qualified Data.ByteString.Char8 as BC (unpack, pack)
  57
  58 import Darcs.Utils ( withCurrentDirectory, prettyException )
  59 import Darcs.External ( backupByCopying, backupByRenaming )
  60 import Printer ( Doc, renderPS )
  61 import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn )
  62 import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS )
  63 import Workaround ( setExecutable )
  64 \end{code}
  65 \end{comment}
  66
  67 \begin{comment}
  68 \begin{code}
  69
  70 class (Functor m, MonadPlus m) => ReadableDirectory m where
  71     mDoesDirectoryExist :: FileName -> m Bool
  72     mDoesFileExist :: FileName -> m Bool
  73     mInCurrentDirectory :: FileName -> m a -> m a
  74     mGetDirectoryContents :: m [FileName]
  75     mReadBinFile :: FileName -> m String
  76     mReadBinFile f = liftM BC.unpack $ mReadFilePS f
  77     mReadFilePS :: FileName -> m B.ByteString
  78     mReadFilePSs :: FileName -> m [B.ByteString]
  79     mReadFilePSs f = linesPS `liftM` mReadFilePS f
  80
  81 class ReadableDirectory m => WriteableDirectory m where
  82     mWithCurrentDirectory :: FileName -> m a -> m a
  83     mSetFileExecutable :: FileName -> Bool -> m ()
  84     mWriteBinFile :: FileName -> String -> m ()
  85     mWriteBinFile fn s = mWriteFilePS fn $ BC.pack s
  86     mWriteFilePS :: FileName -> B.ByteString -> m ()
  87     mWriteFilePSs :: FileName -> [B.ByteString] -> m ()
  88     mWriteFilePSs f ss = mWriteFilePS f (unlinesPS ss)
  89     mCreateDirectory :: FileName -> m ()
  90     mRemoveDirectory :: FileName -> m ()
  91     mWriteDoc :: FileName -> Doc -> m ()
  92     mWriteDoc f d = mWriteFilePS f (renderPS d)
  93     mCreateFile :: FileName -> m ()
  94     mCreateFile f = mWriteFilePS f B.empty
  95     mRemoveFile :: FileName -> m ()
  96     mRename :: FileName -> FileName -> m ()
  97     mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m ()
  98     mModifyFilePS f j = do ps <- mReadFilePS f
  99                            ps' <- j ps
 100                            mWriteFilePS f ps'
 101     mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()
 102     mModifyFilePSs f j = do ps <- mReadFilePSs f
 103                             ps' <- j ps
 104                             mWriteFilePSs f ps'
 105
 106 instance ReadableDirectory IO where
 107     mDoesDirectoryExist = doesDirectoryExist . fn2fp
 108     mDoesFileExist = doesFileExist . fn2fp
 109     mInCurrentDirectory = withCurrentDirectory . fn2fp
 110     mGetDirectoryContents = map fp2fn `liftM` getDirectoryContents "."
 111     mReadBinFile = readBinFile . fn2fp
 112     mReadFilePS = B.readFile . fn2fp
 113
 114 instance WriteableDirectory IO where
 115     mWithCurrentDirectory = mInCurrentDirectory
 116     mSetFileExecutable = setExecutable . fn2fp
 117     mWriteBinFile = writeBinFile . fn2fp
 118     mWriteFilePS = writeAtomicFilePS . fn2fp
 119     mCreateDirectory = createDirectory . fn2fp
 120     mCreateFile f = do exf <- mDoesFileExist f
 121                        if exf then fail $ "File '"++fn2fp f++"' already exists!"
 122                               else do exd <- mDoesDirectoryExist f
 123                                       if exd then fail $ "File '"++fn2fp f++"' already exists!"
 124                                              else mWriteFilePS f B.empty
 125     mRemoveFile f = do let fp = fn2fp f
 126                        x <- B.readFile fp
 127                        when (not $ B.null x) $
 128                             fail $ "Cannot remove non-empty file "++fp
 129                        removeFile fp
 130     mRemoveDirectory = removeDirectory . fn2fp
 131     mRename a b = catchJust ioErrors
 132                   (renameDirectory x y `mplus` renameFile x y)
 133                   -- We need to catch does not exist errors, since older
 134                   -- versions of darcs allowed users to rename nonexistent
 135                   -- files.  :(
 136                   (\e -> if isDoesNotExistError e
 137                                  then return ()
 138                                  else ioError e)
 139       where x = fn2fp a
 140             y = fn2fp b
 141
 142 class Monad m => TolerantMonad m where
 143     warning :: IO () -> m ()
 144     runIO :: m a -> IO a
 145     runTM :: IO a -> m a
 146
 147 newtype TolerantIO a = TIO { runTolerantly :: IO a }
 148 instance TolerantMonad TolerantIO where
 149     warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e
 150     runIO (TIO io) = io
 151     runTM io = TIO io
 152
 153 newtype SilentIO a = SIO { runSilently :: IO a }
 154 instance TolerantMonad SilentIO where
 155     warning io = SIO $ io `catch` \_ -> return ()
 156     runIO (SIO io) = io
 157     runTM io = SIO io
 158
 159 -- NOTE: The following instance declarations are duplicated merely to avoid
 160 -- enabling -fallow-undecidable-instances.  If we used
 161 -- -fallow-undecidable-instances, we would write instead:
 162
 163 -- instance TolerantMonad m => Monad m where
 164 --      ...
 165
 166 -- etc.
 167 instance Functor TolerantIO where
 168     fmap f m = m >>= return . f
 169
 170 instance Monad TolerantIO where
 171     f >>= g = runTM $ runIO f >>= runIO . g
 172     f >> g = runTM $ runIO f >> runIO g
 173     fail s = runTM $ fail s
 174     return x = runTM $ return x
 175
 176 instance Functor SilentIO where
 177     fmap f m = m >>= return . f
 178
 179 instance Monad SilentIO where
 180     f >>= g = runTM $ runIO f >>= runIO . g
 181     f >> g = runTM $ runIO f >> runIO g
 182     fail s = runTM $ fail s
 183     return x = runTM $ return x
 184
 185 instance MonadPlus TolerantIO where
 186     mzero = runTM mzero
 187     mplus a b = runTM (mplus (runIO a) (runIO b))
 188 instance MonadPlus SilentIO where
 189     mzero = runTM mzero
 190     mplus a b = runTM (mplus (runIO a) (runIO b))
 191
 192 instance ReadableDirectory TolerantIO where
 193     mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d
 194     mDoesFileExist f = runTM $ mDoesFileExist f
 195     mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)
 196     mGetDirectoryContents = runTM mGetDirectoryContents
 197     mReadBinFile f = runTM $ mReadBinFile f
 198     mReadFilePS f = runTM $ mReadFilePS f
 199 instance ReadableDirectory SilentIO where
 200     mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d
 201     mDoesFileExist f = runTM $ mDoesFileExist f
 202     mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)
 203     mGetDirectoryContents = runTM mGetDirectoryContents
 204     mReadBinFile f = runTM $ mReadBinFile f
 205     mReadFilePS f = runTM $ mReadFilePS f
 206
 207 instance WriteableDirectory TolerantIO where
 208      mWithCurrentDirectory = mInCurrentDirectory
 209      mSetFileExecutable f e = warning $ mSetFileExecutable f e
 210      mWriteBinFile f s = warning $ mWriteBinFile f s
 211      mWriteFilePS f s = warning $ mWriteFilePS f s
 212      mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty
 213      mCreateDirectory d = warning $ backup d >> mCreateDirectory d
 214      mRemoveFile f = warning $ mRemoveFile f
 215      mRemoveDirectory d = warning $ catchJust ioErrors
 216                                  (mRemoveDirectory d)
 217                                  (\e ->
 218                                    if "(Directory not empty)" `isSuffixOf` show e
 219                                    then ioError $ userError $
 220                                             "Not deleting " ++ fn2fp d ++ " because it is not empty."
 221                                    else ioError $ userError $
 222                                             "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)
 223      mRename a b = warning $ catchJust ioErrors
 224                           (let do_backup = if (map toLower x == map toLower y)
 225                                            then backupByCopying y -- avoid making the original vanish
 226                                            else backupByRenaming y
 227                            in do_backup >> mRename a b)
 228                           (\e -> case () of
 229                                  _ | isPermissionError e -> ioError $ userError $
 230                                        couldNotRename ++ "."
 231                                    | isDoesNotExistError e -> ioError $ userError $
 232                                        couldNotRename ++ " because " ++ x ++ " does not exist."
 233                                    | otherwise -> ioError e
 234                           )
 235        where
 236         x = fn2fp a
 237         y = fn2fp b
 238         couldNotRename = "Could not rename " ++ x ++ " to " ++ y
 239 instance WriteableDirectory SilentIO where
 240      mWithCurrentDirectory = mInCurrentDirectory
 241      mSetFileExecutable f e = warning $ mSetFileExecutable f e
 242      mWriteBinFile f s = warning $ mWriteBinFile f s
 243      mWriteFilePS f s = warning $ mWriteFilePS f s
 244      mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty
 245      mCreateDirectory d = warning $ backup d >> mCreateDirectory d
 246      mRemoveFile f = warning $ mRemoveFile f
 247      mRemoveDirectory d = warning $ catchJust ioErrors
 248                                  (mRemoveDirectory d)
 249                                  (\e ->
 250                                    if "(Directory not empty)" `isSuffixOf` show e
 251                                    then ioError $ userError $
 252                                             "Not deleting " ++ fn2fp d ++ " because it is not empty."
 253                                    else ioError $ userError $
 254                                             "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)
 255      mRename a b = warning $ catchJust ioErrors
 256                           (let do_backup = if (map toLower x == map toLower y)
 257                                            then backupByCopying y -- avoid making the original vanish
 258                                            else backupByRenaming y
 259                            in do_backup >> mRename a b)
 260                           (\e -> case () of
 261                                  _ | isPermissionError e -> ioError $ userError $
 262                                        couldNotRename ++ "."
 263                                    | isDoesNotExistError e -> ioError $ userError $
 264                                        couldNotRename ++ " because " ++ x ++ " does not exist."
 265                                    | otherwise -> ioError e
 266                           )
 267        where
 268         x = fn2fp a
 269         y = fn2fp b
 270         couldNotRename = "Could not rename " ++ x ++ " to " ++ y
 271
 272 backup :: FileName -> IO ()
 273 backup f = backupByRenaming $ fn2fp f
 274 \end{code}
 275 \end{comment}
 276
 277 \end{document}