1 -- Copyright (C) 2002-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 -cpp #-}
   19 {-# LANGUAGE CPP #-}
   20 
   21 #include "gadts.h"
   22 
   23 module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default,
   24                                      identify_checkpoint,
   25                                      write_checkpoint_patch,
   26                                    ) where
   27 
   28 import System.Directory ( setCurrentDirectory, createDirectoryIfMissing )
   29 import Workaround ( getCurrentDirectory )
   30 import System.IO.Unsafe ( unsafeInterleaveIO )
   31 import Data.Maybe ( listToMaybe, catMaybes )
   32 import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )
   33 import qualified Data.ByteString as B ( null, empty, ByteString )
   34 
   35 import Darcs.Lock ( withTempDir, writeDocBinFile )
   36 import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, )
   37 import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo,
   38                      apply_to_slurpy, patchcontents,
   39                      effect, fromPrims,
   40                      is_setpref, infopatch,
   41                      readPatch,
   42                      gzWritePatch
   43                    )
   44 import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq),
   45                              (+>+), filterFL, unsafeCoerceP,
   46                              mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL )
   47 import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded )
   48 import Darcs.Repository.ApplyPatches ( apply_patches )
   49 import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,
   50                           showPatchInfo
   51                         )
   52 import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) )
   53 import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) )
   54 import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag )
   55 import Darcs.Repository.Prefs ( filetype_function )
   56 import Darcs.Utils ( catchall )
   57 import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
   58 import Darcs.Global ( darcsdir )
   59 import Printer ( Doc, ($$), empty )
   60 #include "impossible.h"
   61 import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 )
   62 import Control.Monad ( liftM )
   63 
   64 read_patch_ids :: B.ByteString -> [PatchInfo]
   65 read_patch_ids inv | B.null inv = []
   66 read_patch_ids inv = case readPatchInfo inv of
   67                      Just (pinfo,r) -> pinfo : read_patch_ids r
   68                      Nothing -> []
   69 
   70 read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)]
   71 read_checkpoints d = do
   72   realdir <- toPath `fmap` ioAbsoluteOrRemote d
   73   pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable
   74            `catchall` return B.empty
   75   pis <- return $ reverse $ read_patch_ids pistr
   76   slurpies <- sequence $ map (fetch_checkpoint realdir) pis
   77   return $ zip pis slurpies
   78       where fetch_checkpoint r pinfo =
   79                 unsafeInterleaveIO $ do
   80                 pstr <- gzFetchFilePS
   81                     (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable
   82                 case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of
   83                   Nothing -> return Nothing
   84                   Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy
   85 
   86 get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
   87 get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts
   88                                               then get_check_internal repository
   89                                               else return Nothing
   90 
   91 get_checkpoint_by_default :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
   92 get_checkpoint_by_default repository@(Repo _ opts _ _) = if Complete `elem` opts
   93                                                          then return Nothing
   94                                                          else get_check_internal repository
   95 
   96 identify_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo)
   97 identify_checkpoint repository@(Repo r _ _ _) = do
   98   pis <- (map sp2i . catMaybes . mapRL lastRL) `liftM` read_repo repository
   99   pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable
  100            `catchall` return B.empty
  101   return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr
  102     where lastRL :: RL a C(x y) -> Maybe (Sealed2 a)
  103           lastRL as = do Sealed ps <- headFL (reverseRL as)
  104                          return $ seal2 ps
  105           headFL :: FL a C(x y) -> Maybe (Sealed (a C(x)))
  106           headFL (x:>:_) = Just $ seal x
  107           headFL NilFL = Nothing
  108           sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo
  109           sp2i (Sealed2 p) = info p
  110 
  111 get_check_internal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
  112 get_check_internal repository@(Repo r _ _ _) = do
  113   mc <- identify_checkpoint repository
  114   case mc of
  115     Nothing -> return Nothing
  116     Just pinfo ->  do ps <- gzFetchFilePS
  117                             (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable
  118                       return $ case readPatch ps of
  119                                Just (p, _) -> Just p
  120                                Nothing -> Nothing
  121 
  122 format_inv :: [PatchInfo] -> Doc
  123 format_inv [] = empty
  124 format_inv (pinfo:ps) = showPatchInfo pinfo
  125                      $$ format_inv ps
  126 
  127 is_setprefFL :: Prim C(x y) -> EqCheck C(x y)
  128 is_setprefFL p | is_setpref p = NotEq
  129                | otherwise = unsafeCoerceP IsEq
  130 
  131 write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO ()
  132 write_checkpoint_patch p =
  133  do createDirectoryIfMissing False (darcsdir++"/checkpoints")
  134     gzWritePatch (darcsdir++"/checkpoints/"++make_filename (patch2patchinfo p)) p
  135     cpi <- (map fst) `fmap` read_checkpoints "."
  136     writeDocBinFile (darcsdir++"/checkpoints/inventory")
  137         $ format_inv $ reverse $ patch2patchinfo p:cpi
  138 
  139 with_tag :: RepoPatch p  => Repository p C(r u t) -> PatchInfo -> (IO ()) -> IO ()
  140 with_tag r pinfo job = do
  141     ps <- read_repo r
  142     case get_patches_beyond_tag pinfo ps of
  143         FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do
  144                                             apply_patches [] $ invertRL extras
  145                                             job
  146         _ -> bug "with_tag"                                                                                                               
  147