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