src/Darcs/Repository/Checkpoint.lhs

   1
   2 %  Copyright (C) 2002-2005 David Roundy
   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 \chapter{Checkpoints}
  20 \label{checkpoints}
  21
  22 There should be a discussion of checkpoints here.
  23
  24 \begin{code}
  25 {-# OPTIONS_GHC -cpp #-}
  26 {-# LANGUAGE CPP #-}
  27
  28 #include "gadts.h"
  29
  30 module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default,
  31                                      identify_checkpoint,
  32                                      write_checkpoint, write_recorded_checkpoint,
  33                                      write_checkpoint_patch,
  34                                    ) where
  35
  36 import System.Directory ( setCurrentDirectory, createDirectoryIfMissing )
  37 import Workaround ( getCurrentDirectory )
  38 import System.IO.Unsafe ( unsafeInterleaveIO )
  39 import Data.Maybe ( listToMaybe, catMaybes )
  40 import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )
  41 import qualified Data.ByteString as B ( null, empty, ByteString )
  42
  43 import Darcs.Lock ( withTempDir, writeDocBinFile )
  44 import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, )
  45 import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo,
  46                      apply_to_slurpy, patchcontents,
  47                      effect, fromPrims,
  48                      is_setpref, infopatch,
  49                      readPatch,
  50                      gzWritePatch
  51                    )
  52 import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq),
  53                              (+>+), filterFL, unsafeCoerceP,
  54                              mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL )
  55 import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded )
  56 import Darcs.Repository.ApplyPatches ( apply_patches )
  57 import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,
  58                           showPatchInfo
  59                         )
  60 import Darcs.Diff ( unsafeDiff )
  61 import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) )
  62 import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) )
  63 import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag )
  64 import Darcs.Repository.Prefs ( filetype_function )
  65 import Darcs.Utils ( catchall )
  66 import Darcs.FilePathUtils ( absolute_dir )
  67 import Darcs.Global ( darcsdir )
  68 import Printer ( Doc, ($$), empty )
  69 #include "impossible.h"
  70 import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 )
  71 import Control.Monad ( liftM )
  72 \end{code}
  73
  74 \begin{code}
  75 read_patch_ids :: B.ByteString -> [PatchInfo]
  76 read_patch_ids inv | B.null inv = []
  77 read_patch_ids inv = case readPatchInfo inv of
  78                      Just (pinfo,r) -> pinfo : read_patch_ids r
  79                      Nothing -> []
  80 \end{code}
  81
  82 \begin{code}
  83 read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)]
  84 read_checkpoints d = do
  85   realdir <- absolute_dir d
  86   pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable
  87            `catchall` return B.empty
  88   pis <- return $ reverse $ read_patch_ids pistr
  89   slurpies <- sequence $ map (fetch_checkpoint realdir) pis
  90   return $ zip pis slurpies
  91       where fetch_checkpoint r pinfo =
  92                 unsafeInterleaveIO $ do
  93                 pstr <- gzFetchFilePS
  94                     (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable
  95                 case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of
  96                   Nothing -> return Nothing
  97                   Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy
  98
  99 get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
 100 get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts
 101                                               then get_check_internal repository
 102                                               else return Nothing
 103
 104 get_checkpoint_by_default :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
 105 get_checkpoint_by_default repository@(Repo _ opts _ _) = if Complete `elem` opts
 106                                                          then return Nothing
 107                                                          else get_check_internal repository
 108
 109 identify_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo)
 110 identify_checkpoint repository@(Repo r _ _ _) = do
 111   pis <- (map sp2i . catMaybes . mapRL lastRL) `liftM` read_repo repository
 112   pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable
 113            `catchall` return B.empty
 114   return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr
 115     where lastRL :: RL a C(x y) -> Maybe (Sealed2 a)
 116           lastRL as = do Sealed ps <- headFL (reverseRL as)
 117                          return $ seal2 ps
 118           headFL :: FL a C(x y) -> Maybe (Sealed (a C(x)))
 119           headFL (x:>:_) = Just $ seal x
 120           headFL NilFL = Nothing
 121           sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo
 122           sp2i (Sealed2 p) = info p
 123
 124 get_check_internal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
 125 get_check_internal repository@(Repo r _ _ _) = do
 126   mc <- identify_checkpoint repository
 127   case mc of
 128     Nothing -> return Nothing
 129     Just pinfo ->  do ps <- gzFetchFilePS
 130                             (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable
 131                       return $ case readPatch ps of
 132                                Just (p, _) -> Just p
 133                                Nothing -> Nothing
 134
 135 format_inv :: [PatchInfo] -> Doc
 136 format_inv [] = empty
 137 format_inv (pinfo:ps) = showPatchInfo pinfo
 138                      $$ format_inv ps
 139
 140 write_recorded_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()
 141 write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do
 142     Sealed ps <- (seal . mapFL_FL hopefully.reverseRL.concatRL) `liftM` read_repo r
 143     ftf <- filetype_function
 144     s <- slurp_recorded r
 145     write_checkpoint_patch $ infopatch pinfo
 146         (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))
 147     where changeps = filterFL is_setprefFL .
 148                      effect . patchcontents
 149           changepps = concatFL . mapFL_FL changeps
 150
 151 is_setprefFL :: Prim C(x y) -> EqCheck C(x y)
 152 is_setprefFL p | is_setpref p = unsafeCoerceP IsEq
 153                | otherwise = NotEq
 154
 155 write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()
 156 write_checkpoint repo@(Repo _ _ _ _) pinfo = do
 157     repodir <- getCurrentDirectory
 158     Sealed pit <- get_patches_in_tag pinfo `liftM` read_repo repo
 159     let ps = (reverseRL.mapRL_RL hopefully.concatRL) pit
 160     ftf <- filetype_function
 161     with_tag repo pinfo $ do
 162       s <- mmap_slurp "."
 163       setCurrentDirectory repodir
 164       write_checkpoint_patch $ infopatch pinfo $
 165           (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))
 166     where changeps = filterFL is_setprefFL .
 167                      effect . patchcontents
 168           changepps = concatFL . mapFL_FL changeps
 169
 170 write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO ()
 171 write_checkpoint_patch p =
 172  do createDirectoryIfMissing False (darcsdir++"/checkpoints")
 173     gzWritePatch (darcsdir++"/checkpoints/"++make_filename (patch2patchinfo p)) p
 174     cpi <- (map fst) `fmap` read_checkpoints "."
 175     writeDocBinFile (darcsdir++"/checkpoints/inventory")
 176         $ format_inv $ reverse $ patch2patchinfo p:cpi
 177
 178 with_tag :: RepoPatch p  => Repository p C(r u t) -> PatchInfo -> (IO ()) -> IO ()
 179 with_tag r pinfo job = do
 180     ps <- read_repo r
 181     case get_patches_beyond_tag pinfo ps of
 182         FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do
 183                                             apply_patches [] $ invertRL extras
 184                                             job
 185         _ -> bug "with_tag"
 186 \end{code}
 187
 188 The \verb!_darcs! directory also contains a directory called
 189 ``\verb!prefs!'', which is described in Chapter~\ref{configuring}.
 190
 191 \begin{comment}
 192 \section{Getting interesting info on change history}
 193
 194 One can query the repository for the entire markup history of a file.  This
 195 provides a data structure which contains a history of \emph{all} the
 196 revisions ever made on a given file.
 197
 198 \end{comment}