module Darcs.Repository.Format
( RepoFormat(..)
, RepoProperty(..)
, identifyRepoFormat
, tryIdentifyRepoFormat
, createRepoFormat
, writeRepoFormat
, writeProblem
, readProblem
, transferProblem
, formatHas
, addToFormat
, removeFromFormat
) where
import Prelude ()
import Darcs.Prelude
#include "impossible.h"
import Control.Monad ( mplus, (<=<) )
import qualified Data.ByteString.Char8 as BC ( split, unpack, elemIndex )
import qualified Data.ByteString as B ( null, empty )
import Data.List ( partition, intercalate, (\\) )
import Data.Maybe ( isJust, mapMaybe )
import Darcs.Util.External
( fetchFilePS
, Cachable( Cachable )
)
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock ( writeBinFile )
import qualified Darcs.Repository.Flags as F ( WithWorkingDir (..), PatchFormat (..) )
import Darcs.Util.SignalHandler ( catchNonSignal )
import Darcs.Util.Exception ( catchall, prettyException )
import Darcs.Util.ByteString ( linesPS )
import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO )
data RepoProperty = Darcs1
| Darcs2
| HashedInventory
| NoWorkingDir
| RebaseInProgress
| UnknownFormat String
deriving ( Eq )
darcs1Format, darcs2Format, hashedInventoryFormat :: String
noWorkingDirFormat, rebaseInProgressFormat :: String
darcs1Format = "darcs-1.0"
darcs2Format = "darcs-2"
hashedInventoryFormat = "hashed"
noWorkingDirFormat = "no-working-dir"
rebaseInProgressFormat = "rebase-in-progress"
instance Show RepoProperty where
show Darcs1 = darcs1Format
show Darcs2 = darcs2Format
show HashedInventory = hashedInventoryFormat
show NoWorkingDir = noWorkingDirFormat
show RebaseInProgress = rebaseInProgressFormat
show (UnknownFormat f) = "Unknown format: " ++ f
readRepoProperty :: String -> RepoProperty
readRepoProperty input
| input == darcs1Format = Darcs1
| input == darcs2Format = Darcs2
| input == hashedInventoryFormat = HashedInventory
| input == noWorkingDirFormat = NoWorkingDir
| input == rebaseInProgressFormat = RebaseInProgress
| otherwise = UnknownFormat input
newtype RepoFormat = RF [[RepoProperty]]
formatHas :: RepoProperty -> RepoFormat -> Bool
formatHas f (RF rps) = f `elem` concat rps
addToFormat :: RepoProperty -> RepoFormat -> RepoFormat
addToFormat f (RF rps) = RF (rps ++ [[f]])
removeFromFormat :: RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat f (RF rps) = RF (rps \\ [[f]])
instance Show RepoFormat where
show (RF rf) = unlines $ map (intercalate "|" . map show) rf
identifyRepoFormat :: String -> IO RepoFormat
identifyRepoFormat = either fail return <=< tryIdentifyRepoFormat
tryIdentifyRepoFormat :: String -> IO (Either String RepoFormat)
tryIdentifyRepoFormat repo = do
let k = "Identifying repository " ++ repo
beginTedious k
finishedOneIO k "format"
formatInfo <- (fetchFilePS (repoPath "format") Cachable)
`catchall` (return B.empty)
format <-
if (B.null formatInfo || isJust (BC.elemIndex '<' formatInfo)) then do
finishedOneIO k "inventory"
missingInvErr <- checkFile (repoPath "inventory")
case missingInvErr of
Nothing -> return . Right $ RF [[Darcs1]]
Just e -> return . Left $ makeErrorMsg e
else return . Right $ readFormat formatInfo
endTedious k
return format
where
repoPath fileName = repo ++ "/" ++ darcsdir ++ "/" ++ fileName
readFormat = RF . map (map (readRepoProperty . BC.unpack)) . splitFormat
splitFormat = map (BC.split '|') . filter (not . B.null) . linesPS
checkFile path = (fetchFilePS path Cachable >> return Nothing)
`catchNonSignal`
(return . Just . prettyException)
makeErrorMsg e = unlines
[ "Not a repository: " ++ repo ++ " (" ++ e ++ ")"
, ""
, "HINT: Do you have the right URI for the repository?"
]
writeRepoFormat :: RepoFormat -> FilePath -> IO ()
writeRepoFormat rf loc = writeBinFile loc $ show rf
createRepoFormat :: F.PatchFormat -> F.WithWorkingDir -> RepoFormat
createRepoFormat fmt wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format fmt
where
flags2format F.PatchFormat1 = []
flags2format F.PatchFormat2 = [[Darcs2]]
flags2wd F.NoWorkingDir = [NoWorkingDir]
flags2wd F.WithWorkingDir = []
writeProblem :: RepoFormat -> Maybe String
writeProblem target = readProblem target `mplus` findProblems target wp
where
wp [] = impossible
wp x = case partition isKnown x of
(_, []) -> Nothing
(_, unknowns) -> Just . unwords $
"Can't write repository format: " : map show unknowns
transferProblem :: RepoFormat -> RepoFormat -> Maybe String
transferProblem source target
| formatHas Darcs2 source /= formatHas Darcs2 target =
Just "Cannot mix darcs-2 repositories with older formats"
| formatHas RebaseInProgress source =
Just "Cannot transfer patches from a repository where a rebase is in progress"
| otherwise = readProblem source `mplus` writeProblem target
readProblem :: RepoFormat -> Maybe String
readProblem source
| formatHas Darcs1 source && formatHas Darcs2 source =
Just "Invalid repositoryformat: format 2 is incompatible with format 1"
readProblem source = findProblems source rp
where
rp x | any isKnown x = Nothing
rp [] = impossible
rp x = Just . unwords $ "Can't understand repository format:" : map show x
findProblems :: RepoFormat -> ([RepoProperty] -> Maybe String) -> Maybe String
findProblems (RF ks) formatHasProblem = case mapMaybe formatHasProblem ks of
[] -> Nothing
xs -> Just $ unlines xs
isKnown :: RepoProperty -> Bool
isKnown p = p `elem` knownProperties
where
knownProperties :: [RepoProperty]
knownProperties = [ Darcs1
, Darcs2
, HashedInventory
, NoWorkingDir
, RebaseInProgress
]