-- Copyright (C) 2005 David Roundy
--
-- This file is licensed under the GPL, version two or later.

{- | The format file.

The purpose of the format file is to check compatibility between
repositories in different formats and to allow the addition of new features
without risking corruption by old darcs versions that do not yet know about
these features.

This allows a limited form of forward compatibility between darcs versions.
Old versions of darcs that are unaware of features added in later versions
will fail with a decent error message instead of crashing or misbehaving or
even corrupting new repos.

The format file lives at _darcs/format and must only contain printable ASCII
characters and must not contain the characters @<@ and @>@.

(We currently do not strip whitespace from the lines, but may want to do so
in the future.)

The file consists of format properties. A format property can contain any
allowed ASCII character except the vertical bar (@|@) and newlines. Empty
lines are ignored and multiple properties on the same line are separated
with a @|@.

If multiple properties appear on the same line (separated by vertical bars),
then this indicates alternative format properties. These have a generic
meaning:

 * If we know *any* of these properties, then we can read the repo.

 * If we know *all* of them, we can also write the repo.

The above rules are necessary conditions, not sufficient ones. It is allowed
to further restrict read and/or write access for specific commands, but care
should be taken to not unnecessarily break forward compatibility. It is not
recommended, but sometimes necessary, to impose ad-hoc restrictions on the
format, see 'transferProblem' and 'readProblem' for examples.

The no-working-dir property is an example for how to use alternative
properties. An old darcs version that does not know this format can perform
most read-only operations correctly even if there is no working tree;
however, whatsnew will report that the whole tree was removed, so the
solution is not perfect.

When you add a new property as an alternative to an existing one, you should
make sure that the old format remains to be updated in parallel to the new
one, so that reading the repo with old darcs versions behaves correctly. If
this cannot be guaranteed, it is better to add the new format on a separate
line.

It is not advisable for commands to modify an existing format file. However,
sometimes compatibility requirements may leave us no other choice. In this
case make sure to write the format file only after having checked that the
existing repo format allows modification of the repo, and that you have
taken the repo lock.

-}

{-# LANGUAGE OverloadedStrings #-}
module Darcs.Repository.Format
    ( RepoFormat(..)
    , RepoProperty(..)
    , identifyRepoFormat
    , tryIdentifyRepoFormat
    , createRepoFormat
    , writeRepoFormat
    , writeProblem
    , readProblem
    , transferProblem
    , formatHas
    , addToFormat
    , removeFromFormat
    ) where

import Darcs.Prelude

import Control.Monad ( mplus, (<=<) )
import qualified Data.ByteString.Char8 as BC ( split, pack, unpack, elem )
import qualified Data.ByteString  as B ( ByteString, null, empty, stripPrefix )
import Data.List ( partition, intercalate, (\\) )
import Data.Maybe ( mapMaybe )
import Data.String ( IsString )
import System.FilePath.Posix( (</>) )

import Darcs.Util.External
    ( fetchFilePS
    , Cachable( Cachable )
    )
import Darcs.Util.Lock ( writeBinFile )
import qualified Darcs.Repository.Flags as F
    ( WithWorkingDir (..), PatchFormat (..)  )
import Darcs.Repository.Paths ( formatPath, oldInventoryPath )
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
                  | Darcs3
                  | HashedInventory
                  | NoWorkingDir
                  | RebaseInProgress
                  | RebaseInProgress_2_16
                  | UnknownFormat B.ByteString
                  deriving ( RepoProperty -> RepoProperty -> Bool
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 )

-- | Define string constants in one place, for reuse in show/parse functions.
darcs1Format, darcs2Format, darcs3Format,
  hashedInventoryFormat, noWorkingDirFormat,
  rebaseInProgressFormat, rebaseInProgress_2_16,
  newStyleRebaseInProgress :: IsString s => s

darcs1Format :: forall s. IsString s => s
darcs1Format = s
"darcs-1.0"
darcs2Format :: forall s. IsString s => s
darcs2Format = s
"darcs-2"
darcs3Format :: forall s. IsString s => s
darcs3Format = s
"darcs-3"
hashedInventoryFormat :: forall s. IsString s => s
hashedInventoryFormat = s
"hashed"
noWorkingDirFormat :: forall s. IsString s => s
noWorkingDirFormat = s
"no-working-dir"
rebaseInProgressFormat :: forall s. IsString s => s
rebaseInProgressFormat = s
"rebase-in-progress"
rebaseInProgress_2_16 :: forall s. IsString s => s
rebaseInProgress_2_16 = s
"rebase-in-progress-2-16"
-- compatibility alias, may want to remove this at some point in the future
newStyleRebaseInProgress :: forall s. IsString s => s
newStyleRebaseInProgress = s
"new-style-rebase-in-progress"

instance Show RepoProperty where
    show :: RepoProperty -> FilePath
show RepoProperty
Darcs1 = forall s. IsString s => s
darcs1Format
    show RepoProperty
Darcs2 = forall s. IsString s => s
darcs2Format
    show RepoProperty
Darcs3 = forall s. IsString s => s
darcs3Format
    show RepoProperty
HashedInventory = forall s. IsString s => s
hashedInventoryFormat
    show RepoProperty
NoWorkingDir = forall s. IsString s => s
noWorkingDirFormat
    show RepoProperty
RebaseInProgress = forall s. IsString s => s
rebaseInProgressFormat
    show RepoProperty
RebaseInProgress_2_16 = forall s. IsString s => s
rebaseInProgress_2_16
    show (UnknownFormat ByteString
f) = ByteString -> FilePath
BC.unpack ByteString
f

readRepoProperty :: B.ByteString -> RepoProperty
readRepoProperty :: ByteString -> RepoProperty
readRepoProperty ByteString
input
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
darcs1Format = RepoProperty
Darcs1
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
darcs2Format = RepoProperty
Darcs2
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
darcs3Format = RepoProperty
Darcs3
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
hashedInventoryFormat = RepoProperty
HashedInventory
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
noWorkingDirFormat = RepoProperty
NoWorkingDir
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
rebaseInProgressFormat = RepoProperty
RebaseInProgress
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
newStyleRebaseInProgress = RepoProperty
RebaseInProgress_2_16
    | ByteString
input forall a. Eq a => a -> a -> Bool
== forall s. IsString s => s
rebaseInProgress_2_16 = RepoProperty
RebaseInProgress_2_16
    | Bool
otherwise = ByteString -> RepoProperty
UnknownFormat ByteString
input

-- | Representation of the format of a repository. Each
-- sublist corresponds to a line in the format file.
newtype RepoFormat = RF [[RepoProperty]]

-- | Is a given property contained within a given format?
formatHas :: RepoProperty -> RepoFormat -> Bool
formatHas :: RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
f (RF [[RepoProperty]]
rps) = RepoProperty
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[RepoProperty]]
rps

-- | Add a single property to an existing format.
addToFormat :: RepoProperty -> RepoFormat -> RepoFormat
addToFormat :: RepoProperty -> RepoFormat -> RepoFormat
addToFormat RepoProperty
f (RF [[RepoProperty]]
rps) = [[RepoProperty]] -> RepoFormat
RF ([[RepoProperty]]
rps forall a. [a] -> [a] -> [a]
++ [[RepoProperty
f]])

-- | Remove a single property from an existing format.
removeFromFormat :: RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat :: RepoProperty -> RepoFormat -> RepoFormat
removeFromFormat RepoProperty
f (RF [[RepoProperty]]
rps) = [[RepoProperty]] -> RepoFormat
RF ([[RepoProperty]]
rps forall a. Eq a => [a] -> [a] -> [a]
\\ [[RepoProperty
f]])

instance Show RepoFormat where
    show :: RepoFormat -> FilePath
show (RF [[RepoProperty]]
rf) = [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"|" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show) [[RepoProperty]]
rf

-- | Identify the format of the repository at the
-- given location (directory, URL, or SSH path).
-- Fails if we weren't able to identify the format.
identifyRepoFormat :: String -> IO RepoFormat
identifyRepoFormat :: FilePath -> IO RepoFormat
identifyRepoFormat = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< FilePath -> IO (Either FilePath RepoFormat)
tryIdentifyRepoFormat

-- | Identify the format of the repository at the
-- given location (directory, URL, or SSH path).
-- Return @'Left' reason@ if it fails, where @reason@ explains why
-- we weren't able to identify the format. Note that we do no verification of
-- the format, which is handled by 'readProblem' or 'writeProblem' on the
-- resulting 'RepoFormat'.
tryIdentifyRepoFormat :: String -> IO (Either String RepoFormat)
tryIdentifyRepoFormat :: FilePath -> IO (Either FilePath RepoFormat)
tryIdentifyRepoFormat FilePath
repo = do
    let k :: FilePath
k = FilePath
"Identifying repository " forall a. [a] -> [a] -> [a]
++ FilePath
repo
    FilePath -> IO ()
beginTedious FilePath
k
    FilePath -> FilePath -> IO ()
finishedOneIO FilePath
k FilePath
"format"
    ByteString
formatInfo <- (FilePath -> Cachable -> IO ByteString
fetchFilePS (FilePath
repo FilePath -> ShowS
</> FilePath
formatPath) Cachable
Cachable)
                  forall a. IO a -> IO a -> IO a
`catchall` (forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty)
    -- We use a workaround for servers that don't return a 404 on nonexistent
    -- files (we trivially check for something that looks like a HTML/XML tag).
    Either FilePath RepoFormat
format <-
      if ByteString -> Bool
B.null ByteString
formatInfo Bool -> Bool -> Bool
|| Char -> ByteString -> Bool
BC.elem Char
'<' ByteString
formatInfo then do
        FilePath -> FilePath -> IO ()
finishedOneIO FilePath
k FilePath
"inventory"
        Maybe FilePath
missingInvErr <- FilePath -> IO (Maybe FilePath)
checkFile (FilePath
repo FilePath -> ShowS
</> FilePath
oldInventoryPath)
        case Maybe FilePath
missingInvErr of
          Maybe FilePath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [[RepoProperty]] -> RepoFormat
RF [[RepoProperty
Darcs1]]
          Just FilePath
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ShowS
makeErrorMsg FilePath
e
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> RepoFormat
readFormat ByteString
formatInfo
    FilePath -> IO ()
endTedious FilePath
k
    forall (m :: * -> *) a. Monad m => a -> m a
return Either FilePath RepoFormat
format
  where
    readFormat :: ByteString -> RepoFormat
readFormat =
      [[RepoProperty]] -> RepoFormat
RF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> RepoProperty
readRepoProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fixupUnknownFormat)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [[ByteString]]
splitFormat

    -- silently fixup unknown format entries broken by previous darcs versions
    fixupUnknownFormat :: ByteString -> ByteString
fixupUnknownFormat ByteString
s =
      case ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"Unknown format: " ByteString
s of
        Maybe ByteString
Nothing -> ByteString
s
        Just ByteString
s' -> ByteString -> ByteString
fixupUnknownFormat ByteString
s' -- repeat until not found anymore

    -- split into lines, then split each non-empty line on '|'
    splitFormat :: ByteString -> [[ByteString]]
splitFormat = forall a b. (a -> b) -> [a] -> [b]
map (Char -> ByteString -> [ByteString]
BC.split Char
'|') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
linesPS

    checkFile :: FilePath -> IO (Maybe FilePath)
checkFile FilePath
path = (FilePath -> Cachable -> IO ByteString
fetchFilePS FilePath
path Cachable
Cachable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                     forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal`
                     (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> FilePath
prettyException)

    makeErrorMsg :: ShowS
makeErrorMsg FilePath
e =  FilePath
"Not a repository: " forall a. [a] -> [a] -> [a]
++ FilePath
repo forall a. [a] -> [a] -> [a]
++ FilePath
" (" forall a. [a] -> [a] -> [a]
++ FilePath
e forall a. [a] -> [a] -> [a]
++ FilePath
")"

-- | Write the repo format to the given file.
writeRepoFormat :: RepoFormat -> FilePath -> IO ()
writeRepoFormat :: RepoFormat -> FilePath -> IO ()
writeRepoFormat RepoFormat
rf FilePath
loc = forall p. FilePathLike p => p -> ByteString -> IO ()
writeBinFile FilePath
loc forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show RepoFormat
rf
-- note: this assumes show returns ascii

-- | Create a repo format. The first argument specifies the patch
-- format; the second says whether the repo has a working tree.
createRepoFormat :: F.PatchFormat -> F.WithWorkingDir -> RepoFormat
createRepoFormat :: PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
fmt WithWorkingDir
wwd = [[RepoProperty]] -> RepoFormat
RF forall a b. (a -> b) -> a -> b
$ (RepoProperty
HashedInventory forall a. a -> [a] -> [a]
: WithWorkingDir -> [RepoProperty]
flags2wd WithWorkingDir
wwd) forall a. a -> [a] -> [a]
: PatchFormat -> [[RepoProperty]]
flags2format PatchFormat
fmt
  where
    flags2format :: PatchFormat -> [[RepoProperty]]
flags2format PatchFormat
F.PatchFormat1 = []
    flags2format PatchFormat
F.PatchFormat2 = [[RepoProperty
Darcs2]]
    flags2format PatchFormat
F.PatchFormat3 = [[RepoProperty
Darcs3]]
    flags2wd :: WithWorkingDir -> [RepoProperty]
flags2wd WithWorkingDir
F.NoWorkingDir   = [RepoProperty
NoWorkingDir]
    flags2wd WithWorkingDir
F.WithWorkingDir = []

-- | @'writeProblem' source@ returns 'Just' an error message if we cannot write
-- to a repo in format @source@, or 'Nothing' if there's no such problem.
writeProblem :: RepoFormat -> Maybe String
writeProblem :: RepoFormat -> Maybe FilePath
writeProblem RepoFormat
target = RepoFormat -> Maybe FilePath
readProblem RepoFormat
target forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` RepoFormat -> ([RepoProperty] -> Maybe FilePath) -> Maybe FilePath
findProblems RepoFormat
target [RepoProperty] -> Maybe FilePath
wp
  where
    wp :: [RepoProperty] -> Maybe FilePath
wp [] = forall a. HasCallStack => FilePath -> a
error FilePath
"impossible case"
    wp [RepoProperty]
x = case forall a. (a -> Bool) -> [a] -> ([a], [a])
partition RepoProperty -> Bool
isKnown [RepoProperty]
x of
               ([RepoProperty]
_, []) -> forall a. Maybe a
Nothing
               ([RepoProperty]
_, [RepoProperty]
unknowns) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords forall a b. (a -> b) -> a -> b
$
                    FilePath
"Can't write repository: unknown formats:" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show [RepoProperty]
unknowns

-- | @'transferProblem' source target@ returns 'Just' an error message if we
-- cannot transfer patches from a repo in format @source@ to a repo in format
-- @target@, or 'Nothing' if there are no such problem.
transferProblem :: RepoFormat -> RepoFormat -> Maybe String
transferProblem :: RepoFormat -> RepoFormat -> Maybe FilePath
transferProblem RepoFormat
source RepoFormat
target
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs3 RepoFormat
source forall a. Eq a => a -> a -> Bool
/= RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs3 RepoFormat
target =
        forall a. a -> Maybe a
Just FilePath
"Cannot mix darcs-3 repositories with older formats"
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
source forall a. Eq a => a -> a -> Bool
/= RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
target =
        forall a. a -> Maybe a
Just FilePath
"Cannot mix darcs-2 repositories with older formats"
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress RepoFormat
source =
        forall a. a -> Maybe a
Just FilePath
"Cannot transfer patches from a repository \
          \where an old-style rebase is in progress"
    | Bool
otherwise = RepoFormat -> Maybe FilePath
readProblem RepoFormat
source forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` RepoFormat -> Maybe FilePath
writeProblem RepoFormat
target

-- | @'readProblem' source@ returns 'Just' an error message if we cannot read
-- from a repo in format @source@, or 'Nothing' if there's no such problem.
readProblem :: RepoFormat -> Maybe String
readProblem :: RepoFormat -> Maybe FilePath
readProblem RepoFormat
source
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs1 RepoFormat
source Bool -> Bool -> Bool
&& RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
source =
        forall a. a -> Maybe a
Just FilePath
"Invalid repository format: format 2 is incompatible with format 1"
    | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress RepoFormat
source Bool -> Bool -> Bool
&& RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
RebaseInProgress_2_16 RepoFormat
source =
        forall a. a -> Maybe a
Just FilePath
"Invalid repository format: \
          \cannot have both old-style and new-style rebase in progress"
readProblem RepoFormat
source = RepoFormat -> ([RepoProperty] -> Maybe FilePath) -> Maybe FilePath
findProblems RepoFormat
source [RepoProperty] -> Maybe FilePath
rp
  where
    rp :: [RepoProperty] -> Maybe FilePath
rp [RepoProperty]
x | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RepoProperty -> Bool
isKnown [RepoProperty]
x = forall a. Maybe a
Nothing
    rp [] = forall a. HasCallStack => FilePath -> a
error FilePath
"impossible case"
    rp [RepoProperty]
x = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords forall a b. (a -> b) -> a -> b
$ FilePath
"Can't read repository: unknown formats:" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show [RepoProperty]
x

-- |'findProblems' applies a function that maps format-entries to an optional
-- error message, to each repoformat entry. Returning any errors.
findProblems :: RepoFormat -> ([RepoProperty] -> Maybe String) -> Maybe String
findProblems :: RepoFormat -> ([RepoProperty] -> Maybe FilePath) -> Maybe FilePath
findProblems (RF [[RepoProperty]]
ks) [RepoProperty] -> Maybe FilePath
formatHasProblem = case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [RepoProperty] -> Maybe FilePath
formatHasProblem [[RepoProperty]]
ks of
                                            [] -> forall a. Maybe a
Nothing
                                            [FilePath]
xs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
xs

-- | Does this version of darcs know how to handle this property?
isKnown :: RepoProperty -> Bool
isKnown :: RepoProperty -> Bool
isKnown RepoProperty
p = RepoProperty
p 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
Darcs3
                      , RepoProperty
HashedInventory
                      , RepoProperty
NoWorkingDir
                      , RepoProperty
RebaseInProgress
                      , RepoProperty
RebaseInProgress_2_16
                      ]