#include "gadts.h"
module Darcs.Repository.Checkpoint ( getCheckpoint, getCheckpointByDefault,
identifyCheckpoint,
writeCheckpointPatch,
) where
import System.Directory ( createDirectoryIfMissing )
import Data.Maybe ( listToMaybe )
import Darcs.Hopefully ( PatchInfoAnd, info )
import qualified Data.ByteString as B ( null, empty, ByteString )
import Darcs.Lock ( writeDocBinFile )
import Darcs.Patch ( RepoPatch, Named, patch2patchinfo,
readPatch, gzWritePatch )
import Darcs.Witnesses.Ordered ( mapRL )
import Darcs.Repository.Internal ( Repository(..), readRepo )
import Darcs.Repository.DarcsRepo ( readCheckpoints )
import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfo,
showPatchInfo )
import Darcs.Patch.Set( PatchSet(..), Tagged(..) )
import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) )
import Darcs.Flags ( DarcsFlag( Partial, Complete ) )
import Darcs.Utils ( catchall )
import Darcs.Global ( darcsdir )
import Printer ( Doc, ($$), empty )
import Darcs.Witnesses.Sealed ( Sealed, Sealed2(Sealed2), seal2 )
import Control.Monad ( liftM )
readPatchIds :: B.ByteString -> [PatchInfo]
readPatchIds inv | B.null inv = []
readPatchIds inv = case readPatchInfo inv of
Just (pinfo,r) -> pinfo : readPatchIds r
Nothing -> []
getCheckpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
getCheckpoint repository@(Repo _ opts _ _) = if Partial `elem` opts
then getCheckInternal repository
else return Nothing
getCheckpointByDefault :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
getCheckpointByDefault repository@(Repo _ opts _ _) = if Complete `elem` opts
then return Nothing
else getCheckInternal repository
identifyCheckpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo)
identifyCheckpoint repository@(Repo r _ _ _) = do
pis <- (map sp2i . extractTags) `liftM` readRepo repository
pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable
`catchall` return B.empty
return $ listToMaybe $ filter (`elem` pis) $ reverse $ readPatchIds pistr
where extractTags :: PatchSet p C(start end) -> [Sealed2 (PatchInfoAnd p)]
extractTags (PatchSet _ ts) = mapRL (\(Tagged t _ _) -> seal2 t) ts
sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo
sp2i (Sealed2 p) = info p
getCheckInternal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))
getCheckInternal repository@(Repo r _ _ _) = do
mc <- identifyCheckpoint repository
case mc of
Nothing -> return Nothing
Just pinfo -> do ps <- gzFetchFilePS
(r++"/"++darcsdir++"/checkpoints/"++makeFilename pinfo) Cachable
return $ case readPatch ps of
Just (p, _) -> Just p
Nothing -> Nothing
formatInv :: [PatchInfo] -> Doc
formatInv [] = empty
formatInv (pinfo:ps) = showPatchInfo pinfo
$$ formatInv ps
writeCheckpointPatch :: RepoPatch p => Named p C(x y) -> IO ()
writeCheckpointPatch p =
do createDirectoryIfMissing False (darcsdir++"/checkpoints")
gzWritePatch (darcsdir++"/checkpoints/"++makeFilename (patch2patchinfo p)) p
cpi <- readCheckpoints "."
writeDocBinFile (darcsdir++"/checkpoints/inventory")
$ formatInv $ reverse $ patch2patchinfo p:cpi