src/Darcs/Repository/Pristine.lhs

   1 %  Copyright (C) 2002-2005 David Roundy
   2 %  Copyright (C) 2004 Juliusz Chroboczek
   3 %
   4 %  This program is free software; you can redistribute it and/or modify
   5 %  it under the terms of the GNU General Public License as published by
   6 %  the Free Software Foundation; either version 2, or (at your option)
   7 %  any later version.
   8 %
   9 %  This program is distributed in the hope that it will be useful,
  10 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 %  GNU General Public License for more details.
  13 %
  14 %  You should have received a copy of the GNU General Public License
  15 %  along with this program; see the file COPYING.  If not, write to
  16 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  17 %  Boston, MA 02110-1301, USA.
  18
  19
  20 \begin{code}
  21 {-# OPTIONS_GHC -cpp #-}
  22 {-# LANGUAGE CPP #-}
  23
  24 #include "gadts.h"
  25
  26 module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine,
  27                  createPristine, removePristine, identifyPristine,
  28                  checkPristine, slurpPristine,
  29                  applyPristine, createPristineFromWorking,
  30                  syncPristine, replacePristine, replacePristineFromSlurpy,
  31                  getPristinePop,
  32                  pristineDirectory, pristineToFlagString,
  33                  easyCreatePristineDirectoryTree,
  34                  easyCreatePartialsPristineDirectoryTree
  35                ) where
  36
  37 import Data.Maybe ( isJust )
  38 import Control.Monad ( when, liftM )
  39 import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist,
  40                    renameDirectory, removeFile )
  41 import Darcs.Lock ( rm_recursive, writeBinFile )
  42 import Darcs.Diff ( cmp, sync )
  43 import Workaround ( getCurrentDirectory )
  44 import Darcs.SlurpDirectory ( Slurpy,  mmap_slurp, co_slurp, writeSlurpy )
  45 import Darcs.Utils ( catchall )
  46
  47 import Darcs.PopulationData ( Population, getPopFrom )
  48 import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) )
  49 import Darcs.Repository.Format ( RepoFormat, format_has,
  50                                  RepoProperty(HashedInventory) )
  51 import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) )
  52 import Darcs.Patch ( Patchy, apply )
  53 import Darcs.Patch.Info ( PatchInfo )
  54 import Darcs.Patch.FileName ( fp2fn )
  55 import qualified Data.ByteString as B (empty)
  56 import Darcs.RepoPath ( FilePathLike, toFilePath )
  57 import SHA1 ( sha1PS )
  58 import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree )
  59 import Darcs.Repository.InternalTypes ( Pristine(..) )
  60 import Darcs.Global ( darcsdir )
  61 #include "impossible.h"
  62
  63 nopristine :: Pristine
  64 nopristine = NoPristine "aack?"
  65
  66 pristineName :: String
  67 pristineName = "pristine"
  68
  69 identifyPristine :: IO (Pristine)
  70 identifyPristine = do mp <- reallyIdentifyPristine
  71                       case mp of
  72                           Nothing -> fail "Pristine tree doesn't exist."
  73                           Just pristine -> return pristine
  74
  75 reallyIdentifyPristine :: IO (Maybe Pristine)
  76 reallyIdentifyPristine =
  77     do dir <- findpristine doesDirectoryExist ""
  78        none <- findpristine doesFileExist ".none"
  79        hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"
  80        hashpris <- doesDirectoryExist hashedPristineDirectory
  81        case (dir, none, hashinv && hashpris) of
  82            (Nothing, Nothing, False) -> return Nothing
  83            (Just n, Nothing, False) ->
  84                return (Just (PlainPristine n))
  85            (Nothing, Just n, False) ->
  86                return (Just (NoPristine n))
  87            (Nothing, Nothing, True) ->
  88                return (Just HashedPristine)
  89            _ -> fail "Multiple pristine trees."
  90     where findpristine fn ext =
  91               do e1 <- fn n1
  92                  e2 <- fn n2
  93                  case (e1, e2) of
  94                      (False, False) -> return Nothing
  95                      (True, False) -> return (Just n1)
  96                      (False, True) -> return (Just n2)
  97                      (True, True) -> fail "Multiple pristine trees."
  98               where  n1 = darcsdir++"/pristine" ++ ext
  99                      n2 = darcsdir++"/current" ++ ext
 100
 101 flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine
 102 flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine
 103 flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none")
 104 flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName)
 105 flagsToPristine (_ : t) rf = flagsToPristine t rf
 106 flagsToPristine [] rf = flagsToPristine [PristinePlain] rf
 107
 108 createPristine :: Pristine -> IO Pristine
 109 createPristine p =
 110     do oldpristine <- reallyIdentifyPristine
 111        when (isJust oldpristine) $ fail "Pristine tree already exists."
 112        case p of
 113            NoPristine n -> writeBinFile n "Do not delete this file.\n"
 114            PlainPristine n -> createDirectory n
 115            HashedPristine -> do createDirectory hashedPristineDirectory
 116                                 writeFile (hashedPristineDirectory++"/"++sha1PS B.empty) ""
 117        return p
 118
 119 hashedPristineDirectory :: String
 120 hashedPristineDirectory = darcsdir++"/pristine.hashed"
 121
 122 removePristine :: Pristine -> IO ()
 123 removePristine (NoPristine n) = removeFile n
 124 removePristine (PlainPristine n) = rm_recursive n
 125 removePristine HashedPristine = rm_recursive hashedPristineDirectory
 126
 127 checkPristine :: FilePath -> Pristine -> IO Bool
 128 checkPristine _ (NoPristine _) = return True
 129 checkPristine path (PlainPristine n) = do cwd <- getCurrentDirectory
 130                                           cmp (cwd ++ "/" ++ n) path
 131 checkPristine _ HashedPristine =
 132     bug "HashedPristine is not implemented yet."
 133
 134 slurpPristine :: Pristine -> IO (Maybe Slurpy)
 135 slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory
 136                                      slurpy <- mmap_slurp (cwd ++ "/" ++ n)
 137                                      return (Just slurpy)
 138 slurpPristine (NoPristine _) = return Nothing
 139 slurpPristine HashedPristine =
 140     bug "HashedPristine is not implemented yet."
 141
 142 applyPristine :: Patchy p => Pristine -> p C(x y) -> IO ()
 143 applyPristine (NoPristine _) _ = return ()
 144 -- We don't need flags for now, since we don't care about
 145 -- SetScriptsExecutable for the pristine cache.
 146 applyPristine (PlainPristine n) p =
 147     mWithCurrentDirectory (fp2fn n) $ apply [] p
 148 applyPristine HashedPristine _ =
 149     bug "3 HashedPristine is not implemented yet."
 150
 151 createPristineFromWorking :: Pristine -> IO ()
 152 createPristineFromWorking (NoPristine _) = return ()
 153 createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n
 154 createPristineFromWorking HashedPristine =
 155     bug "HashedPristine is not implemented yet."
 156
 157 syncPristine :: Pristine -> IO ()
 158 syncPristine (NoPristine _) = return ()
 159 syncPristine (PlainPristine n) =
 160     do ocur <- mmap_slurp n
 161        owork <- co_slurp ocur "."
 162        sync n ocur owork
 163 syncPristine HashedPristine = return () -- FIXME this should be implemented!
 164
 165 replacePristine :: FilePath -> Pristine -> IO ()
 166 replacePristine _ (NoPristine _) = return ()
 167 replacePristine newcur (PlainPristine n) =
 168     do rm_recursive nold
 169            `catchall` return ()
 170        renameDirectory n nold
 171        renameDirectory newcur n
 172        return ()
 173            where nold = darcsdir ++ "/" ++ pristineName ++ "-old"
 174 replacePristine _ HashedPristine =
 175     bug "HashedPristine is not implemented yet."
 176
 177 replacePristineFromSlurpy :: Slurpy -> Pristine -> IO ()
 178 replacePristineFromSlurpy _ (NoPristine _) = return ()
 179 replacePristineFromSlurpy s (PlainPristine n) =
 180     do rm_recursive nold
 181            `catchall` return ()
 182        writeSlurpy s ntmp
 183        renameDirectory n nold
 184        renameDirectory ntmp n
 185        return ()
 186            where nold = darcsdir ++ "/" ++ pristineName ++ "-old"
 187                  ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp"
 188 replacePristineFromSlurpy _ HashedPristine =
 189     bug "HashedPristine is not implemented yet."
 190
 191 getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population)
 192 getPristinePop pinfo (PlainPristine n) =
 193     Just `liftM` getPopFrom n pinfo
 194 getPristinePop _ _ = return Nothing
 195
 196 pristineDirectory :: Pristine -> Maybe String
 197 pristineDirectory (PlainPristine n) = Just n
 198 pristineDirectory _ = Nothing
 199
 200 pristineToFlagString :: Pristine -> String
 201 pristineToFlagString (NoPristine _) = "--no-pristine-tree"
 202 pristineToFlagString (PlainPristine _) = "--plain-pristine-tree"
 203 pristineToFlagString HashedPristine =
 204     bug "HashedPristine is not implemented yet."
 205
 206 easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool
 207 easyCreatePristineDirectoryTree (NoPristine _) _ = return False
 208 easyCreatePristineDirectoryTree (PlainPristine n) p
 209  = cloneTree n p >> return True
 210 easyCreatePristineDirectoryTree HashedPristine _ =
 211     bug "HashedPristine is not implemented yet."
 212
 213 easyCreatePartialsPristineDirectoryTree :: FilePathLike fp => [fp] -> Pristine
 214                                         -> FilePath -> IO Bool
 215 easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False
 216 easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p
 217  = clonePartialsTree n p (map toFilePath prefs) >> return True
 218 easyCreatePartialsPristineDirectoryTree _ HashedPristine _ =
 219     bug "HashedPristine is not implemented yet."
 220 \end{code}
 221