#include "gadts.h"
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, createDirectoryIfMissing )
import Workaround ( getCurrentDirectory )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Data.Maybe ( listToMaybe, catMaybes )
import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )
import qualified Data.ByteString as B ( null, empty, ByteString )
import Darcs.Lock ( withTempDir, writeDocBinFile )
import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, )
import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo,
apply_to_slurpy, patchcontents,
effect, fromPrims,
is_setpref, infopatch,
readPatch,
gzWritePatch
)
import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq),
(+>+), filterFL, unsafeCoerceP,
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 ( unsafeDiff )
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.RepoPath ( ioAbsoluteOrRemote, toPath )
import Darcs.Global ( darcsdir )
import Printer ( Doc, ($$), empty )
#include "impossible.h"
import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 )
import Control.Monad ( liftM )
read_patch_ids :: B.ByteString -> [PatchInfo]
read_patch_ids inv | B.null inv = []
read_patch_ids inv = case readPatchInfo inv of
Just (pinfo,r) -> pinfo : read_patch_ids r
Nothing -> []
read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)]
read_checkpoints d = do
realdir <- toPath `fmap` ioAbsoluteOrRemote d
pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable
`catchall` return B.empty
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 :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of
Nothing -> return Nothing
Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy
get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
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 C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
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 C(r u t) -> IO (Maybe PatchInfo)
identify_checkpoint repository@(Repo r _ _ _) = do
pis <- (map sp2i . catMaybes . mapRL lastRL) `liftM` read_repo repository
pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable
`catchall` return B.empty
return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr
where lastRL :: RL a C(x y) -> Maybe (Sealed2 a)
lastRL as = do Sealed ps <- headFL (reverseRL as)
return $ seal2 ps
headFL :: FL a C(x y) -> Maybe (Sealed (a C(x)))
headFL (x:>:_) = Just $ seal x
headFL NilFL = Nothing
sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo
sp2i (Sealed2 p) = info p
get_check_internal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
get_check_internal repository@(Repo r _ _ _) = do
mc <- identify_checkpoint repository
case mc of
Nothing -> return Nothing
Just pinfo -> do ps <- gzFetchFilePS
(r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable
return $ case readPatch ps of
Just (p, _) -> Just p
Nothing -> Nothing
format_inv :: [PatchInfo] -> Doc
format_inv [] = empty
format_inv (pinfo:ps) = showPatchInfo pinfo
$$ format_inv ps
write_recorded_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()
write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do
Sealed ps <- (seal . mapFL_FL hopefully.reverseRL.concatRL) `liftM` read_repo r
ftf <- filetype_function
s <- slurp_recorded r
write_checkpoint_patch $ infopatch pinfo
(fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))
where changeps = filterFL is_setprefFL .
effect . patchcontents
changepps = concatFL . mapFL_FL changeps
is_setprefFL :: Prim C(x y) -> EqCheck C(x y)
is_setprefFL p | is_setpref p = NotEq
| otherwise = unsafeCoerceP IsEq
write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()
write_checkpoint repo@(Repo _ _ _ _) pinfo = do
repodir <- getCurrentDirectory
Sealed pit <- get_patches_in_tag pinfo `liftM` read_repo repo
let ps = (reverseRL.mapRL_RL hopefully.concatRL) pit
ftf <- filetype_function
with_tag repo pinfo $ do
s <- mmap_slurp "."
setCurrentDirectory repodir
write_checkpoint_patch $ infopatch pinfo $
(fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))
where changeps = filterFL is_setprefFL .
effect . patchcontents
changepps = concatFL . mapFL_FL changeps
write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> 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 C(r u t) -> PatchInfo -> (IO ()) -> IO ()
with_tag r pinfo job = do
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"