module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat,
createRepoFormat, writeRepoFormat,
writeProblem, readProblem, readfromAndWritetoProblem,
formatHas, formatHasTogether,
) where
import Data.List ( sort )
import Data.Maybe ( isJust, catMaybes )
import Control.Monad ( msum )
import Darcs.SignalHandler ( catchNonSignal )
import Darcs.External ( fetchFilePS, Cachable( Cachable ) )
import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory,
UseOldFashionedInventory ) )
import Darcs.Lock ( writeBinFile )
import Darcs.Utils ( catchall, prettyException )
import Progress ( beginTedious, endTedious, finishedOneIO )
import Darcs.Global ( darcsdir )
import ByteStringUtils ( linesPS )
import qualified Data.ByteString.Char8 as BC (split, unpack, singleton, elemIndex, pack)
import qualified Data.ByteString as B (ByteString, null, empty)
import qualified ByteStringUtils as BU ( intercalate )
#include "impossible.h"
data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory
newtype RepoFormat = RF [[B.ByteString]] deriving ( Show )
df :: FilePath
df = darcsdir++"/format"
identifyRepoFormat :: String -> IO (Either String RepoFormat)
identifyRepoFormat repo =
do let k = "Identifying repository "++repo
beginTedious k
finishedOneIO k "format"
dff <- fetchFilePS (repo ++ "/" ++ df) Cachable `catchall` return B.empty
rf <- if B.null dff || isJust (BC.elemIndex '<' dff)
then do finishedOneIO k "inventory"
have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")
case have_inventory of
Right _ -> return $ Right defaultRepoFormat
Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")"
else return $ Right $ parseRepoFormat dff
endTedious k
return rf
where drfe x = fetchFilePS x Cachable >> return True
doesRemoteFileExist x = (fmap Right) (drfe x) `catchNonSignal`
(\e -> return (Left (prettyException e)))
writeRepoFormat :: RepoFormat -> FilePath -> IO ()
writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $
map (BC.unpack . BU.intercalate (BC.singleton '|')) rf
parseRepoFormat :: B.ByteString -> RepoFormat
parseRepoFormat ps =
RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps
defaultRepoFormat :: RepoFormat
defaultRepoFormat = RF [[rp2ps Darcs1_0]]
createRepoFormat :: [DarcsFlag] -> RepoFormat
createRepoFormat fs = RF ([map rp2ps flags2inv] ++ maybe2)
where flags2inv | UseFormat2 `elem` fs = [HashedInventory]
| UseHashedInventory `elem` fs = [HashedInventory]
| UseOldFashionedInventory `elem` fs = [Darcs1_0]
| otherwise = [HashedInventory]
maybe2 = if UseFormat2 `notElem` fs &&
(UseOldFashionedInventory `elem` fs ||
UseHashedInventory `elem` fs)
then []
else [[rp2ps Darcs2]]
writeProblem :: RepoFormat -> Maybe String
writeProblem rf | isJust $ readProblem rf = readProblem rf
writeProblem (RF ks) = unlines `fmap` justsOrNothing (map wp ks)
where wp x | all isKnown x = Nothing
wp [] = impossible
wp x = Just $ unwords $ "Can't write repository format: " :
map BC.unpack (filter (not . isKnown) x)
readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String
readfromAndWritetoProblem inrf outrf
| formatHas Darcs2 inrf /= formatHas Darcs2 outrf
= Just "Cannot mix darcs-2 repositories with older formats"
| otherwise = msum [readProblem inrf, writeProblem outrf]
readProblem :: RepoFormat -> Maybe String
readProblem rf | formatHas Darcs1_0 rf && formatHas Darcs2 rf
= Just "Invalid repositoryformat: format 2 is incompatible with format 1"
readProblem (RF ks) = unlines `fmap` justsOrNothing (map rp ks)
where rp x | any isKnown x = Nothing
rp [] = impossible
rp x = Just $ unwords $
"Can't understand repository format:" : map BC.unpack x
isKnown :: B.ByteString -> Bool
isKnown p = p `elem` map rp2ps knownProperties
knownProperties :: [RepoProperty]
knownProperties = [Darcs1_0, Darcs2, HashedInventory]
justsOrNothing :: [Maybe x] -> Maybe [x]
justsOrNothing mxs =
case catMaybes mxs of
[] -> Nothing
xs -> Just xs
formatHas :: RepoProperty -> RepoFormat -> Bool
formatHas f (RF ks) = rp2ps f `elem` concat ks
formatHasTogether :: [RepoProperty] -> RepoFormat -> Bool
formatHasTogether fs (RF ks) = fht (sort $ map rp2ps fs) ks
where fht _ [] = False
fht x (y:ys) | x == sort y = True
| otherwise = fht x ys
rp2ps :: RepoProperty -> B.ByteString
rp2ps Darcs1_0 = BC.pack "darcs-1.0"
rp2ps Darcs2 = BC.pack "darcs-2"
rp2ps HashedInventory = BC.pack "hashed"