Checkpoint.lhs

%  Copyright (C) 2002-2005 David Roundy
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.

\chapter{Checkpoints}
\label{checkpoints}

There should be a discussion of checkpoints here.

\begin{code}
{-# OPTIONS_GHC -cpp #-}
module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default,
                                     identify_checkpoint,
                                     write_checkpoint, write_recorded_checkpoint,
                                     write_checkpoint_patch,
                                   ) where

import System.Directory ( setCurrentDirectory )
import Workaround ( getCurrentDirectory, createDirectoryIfMissing )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Data.Maybe ( listToMaybe, catMaybes )
import Darcs.Hopefully ( hopefully, info )
import FastPackedString ( PackedString, nilPS, nullPS )

import Darcs.Lock ( withTempDir, writeDocBinFile )
import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, )
import Darcs.Patch ( RepoPatch, Patch, Named, invertRL, patch2patchinfo,
                     apply_to_slurpy, patchcontents,
                     effect, fromPrims,
                     is_setpref, infopatch,
                     readPatch,
                     gzWritePatch
                   )
import Darcs.Patch.Ordered ( RL(..), FL(..),
                             unsafeFL, unsafeUnFL, (+>+),
                             mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL )
import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded )
import Darcs.Repository.ApplyPatches ( apply_patches )
import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,
                          showPatchInfo
                        )
import Darcs.Diff ( smart_diff )
import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) )
import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) )
import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag )
import Darcs.Repository.Prefs ( filetype_function )
import Darcs.Utils ( catchall )
import Darcs.FilePathUtils ( absolute_dir )
import Darcs.Global ( darcsdir )
import Printer ( Doc, ($$), empty )
#include "impossible.h"
import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), unsafeUnseal, liftSM )
\end{code}

\begin{code}
read_patch_ids :: PackedString -> [PatchInfo]
read_patch_ids inv | nullPS inv = []
read_patch_ids inv = case readPatchInfo inv of
                     Just (pinfo,r) -> pinfo : read_patch_ids r
                     Nothing -> []
\end{code}

\begin{code}
read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)]
read_checkpoints d = do
  realdir <- absolute_dir d
  pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable
           `catchall` return nilPS
  pis <- return $ reverse $ read_patch_ids pistr
  slurpies <- sequence $ map (fetch_checkpoint realdir) pis
  return $ zip pis slurpies
      where fetch_checkpoint r pinfo =
                unsafeInterleaveIO $ do
                pstr <- gzFetchFilePS
                    (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable
                case fst `fmap` readPatch pstr of
                  Nothing -> return Nothing
                  Just (Sealed p) -> return $ apply_to_slurpy (p :: (Named Patch)) empty_slurpy

get_checkpoint :: RepoPatch p => Repository p -> IO (Maybe (Named p))
get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts
                                              then get_check_internal repository
                                              else return Nothing

get_checkpoint_by_default :: RepoPatch p => Repository p -> IO (Maybe (Named p))
get_checkpoint_by_default repository@(Repo _ opts _ _) = if Complete `elem` opts
                                                         then return Nothing
                                                         else get_check_internal repository

identify_checkpoint :: RepoPatch p => Repository p -> IO (Maybe PatchInfo)
identify_checkpoint repository@(Repo r _ _ _) = do
  pis <- (map info . catMaybes . mapRL lastRL) `liftSM` read_repo repository
  pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable
           `catchall` return nilPS
  return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr
    where lastRL = headFL . reverseRL
          headFL (x:>:_) = Just x
          headFL NilFL = Nothing

get_check_internal :: RepoPatch p => Repository p -> IO (Maybe (Named p))
get_check_internal repository@(Repo r _ _ _) = do
  mc <- identify_checkpoint repository
  case mc of
    Nothing -> return Nothing
    Just pinfo ->  (fmap unsafeUnseal . fmap fst . readPatch) `fmap`
                        gzFetchFilePS
                            (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable

format_inv :: [PatchInfo] -> Doc
format_inv [] = empty
format_inv (pinfo:ps) = showPatchInfo pinfo
                     $$ format_inv ps

write_recorded_checkpoint :: RepoPatch p => Repository p -> PatchInfo -> IO ()
write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do
    ps <- (mapFL_FL hopefully.reverseRL.concatRL) `liftSM` read_repo r
    ftf <- filetype_function
    s <- slurp_recorded r
    write_checkpoint_patch $ infopatch pinfo
        (fromPrims $ changepps ps +>+ smart_diff [LookForAdds] ftf empty_slurpy s :: Patch)
    where changeps = unsafeFL . filter is_setpref .
                     unsafeUnFL . effect . patchcontents
          changepps = concatFL . mapFL_FL changeps

write_checkpoint :: RepoPatch p => Repository p -> PatchInfo -> IO ()
write_checkpoint repo@(Repo _ _ _ _) pinfo = do
    repodir <- getCurrentDirectory
    ps <- (reverseRL.mapRL_RL hopefully.concatRL.unsafeUnseal.get_patches_in_tag pinfo)
          `liftSM` read_repo repo
    ftf <- filetype_function
    with_tag repo pinfo $ do
      s <- mmap_slurp "."
      setCurrentDirectory repodir
      write_checkpoint_patch $ infopatch pinfo $
          (fromPrims $ changepps ps +>+ smart_diff [LookForAdds] ftf empty_slurpy s :: Patch)
    where changeps = unsafeFL . filter is_setpref .
                     unsafeUnFL . effect . patchcontents
          changepps = concatFL . mapFL_FL changeps

write_checkpoint_patch :: RepoPatch p => Named p -> IO ()
write_checkpoint_patch p =
 do createDirectoryIfMissing False (darcsdir++"/checkpoints")
    gzWritePatch (darcsdir++"/checkpoints/"++make_filename (patch2patchinfo p)) p
    cpi <- (map fst) `fmap` read_checkpoints "."
    writeDocBinFile (darcsdir++"/checkpoints/inventory")
        $ format_inv $ reverse $ patch2patchinfo p:cpi

with_tag :: RepoPatch p  => Repository p -> PatchInfo -> (IO ()) -> IO ()
with_tag r pinfo job = do
    Sealed ps <- read_repo r
    case get_patches_beyond_tag pinfo ps of
        FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do
                                            apply_patches [] $ invertRL extras
                                            job
        _ -> bug "with_tag"
\end{code}

The \verb!_darcs! directory also contains a directory called
``\verb!prefs!'', which is described in Chapter~\ref{configuring}.

\begin{comment}
\section{Getting interesting info on change history}

One can query the repository for the entire markup history of a file.  This
provides a data structure which contains a history of \emph{all} the
revisions ever made on a given file.

\end{comment}