Format.lhs

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

\begin{code}
{-# OPTIONS_GHC -cpp #-}
module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat,
                    create_repo_format, writeRepoFormat,
                    write_problem, read_problem, readfrom_and_writeto_problem,
                    format_has, format_has_together,
                  ) where

import Data.List ( sort, intersperse )
import Data.Maybe ( isJust, catMaybes )
import Control.Monad ( msum )

import Darcs.SignalHandler ( catchNonSignal )
import Darcs.External ( fetchFilePS, Cachable( Cachable ) )
import FastPackedString ( PackedString, packString, nilPS, unpackPS,
                          nullPS, linesPS, splitPS, findPS )
import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory ) )
import Darcs.Lock ( writeBinFile )
import Darcs.Utils ( catchall, prettyException )
import Darcs.Progress ( beginTedious, endTedious, finishedOneIO )
import Darcs.Global ( darcsdir )
#include "impossible.h"

data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory
newtype RepoFormat = RF [[PackedString]] deriving ( Show )
\end{code}

\begin{code}
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 nilPS
    -- below is a workaround for servers that don't return a 404 on nonexistent files
    rf <- if nullPS dff || isJust (findPS '<' dff)
          then do finishedOneIO k "inventory"
                  have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")
                  case have_inventory of
                    Right _ -> return $ Right default_repo_format
                    Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")"
          else return $ Right $ parse_repo_format 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 (concat . intersperse "|" . map unpackPS) rf

parse_repo_format :: PackedString -> RepoFormat
parse_repo_format ps =
    RF $ map (splitPS '|') $ filter (not.nullPS) $ linesPS ps

default_repo_format :: RepoFormat
default_repo_format = RF [[rp2ps Darcs1_0]]

create_repo_format :: [DarcsFlag] -> RepoFormat
create_repo_format fs = RF ([map rp2ps flags2inv] ++ maybe2)
    where flags2inv | UseFormat2 `elem` fs || UseHashedInventory `elem` fs = [HashedInventory]
                    | otherwise = [Darcs1_0]
          maybe2 = if UseFormat2 `elem` fs then [[rp2ps Darcs2]] else []

\end{code}

\begin{code}
-- Nothing means we can write
write_problem :: RepoFormat -> Maybe String
write_problem rf | isJust $ read_problem rf = read_problem rf
write_problem (RF ks) = unlines `fmap` justsOrNothing (map wp ks)
    where wp x | all is_known x = Nothing
          wp [] = impossible
          wp x = Just $ unwords $ "Can't write repository format: " :
                 map unpackPS (filter (not . is_known) x)

readfrom_and_writeto_problem :: RepoFormat -> RepoFormat -> Maybe String
readfrom_and_writeto_problem inrf outrf
    | format_has Darcs2 inrf /= format_has Darcs2 outrf
        = Just "Cannot mix darcs-2 repositories with older formats" 
    | otherwise = msum [read_problem inrf, write_problem outrf]
\end{code}

\begin{code}
read_problem :: RepoFormat -> Maybe String
read_problem rf | format_has Darcs1_0 rf && format_has Darcs2 rf
                    = Just "Invalid repositoryformat:  format 2 is incompatible with format 1"
read_problem (RF ks) = unlines `fmap` justsOrNothing (map rp ks)
    where rp x | any is_known x = Nothing
          rp [] = impossible
          rp x = Just $ unwords $
                 "Can't understand repository format:" : map unpackPS x

is_known :: PackedString -> Bool
is_known p = p `elem` map rp2ps known_properties

known_properties :: [RepoProperty]
known_properties = [Darcs1_0, Darcs2, HashedInventory]

justsOrNothing :: [Maybe x] -> Maybe [x]
justsOrNothing mxs =
 case catMaybes mxs of
   [] -> Nothing
   xs -> Just xs
\end{code}

\begin{code}
format_has :: RepoProperty -> RepoFormat -> Bool
format_has f (RF ks) = rp2ps f `elem` concat ks

format_has_together :: [RepoProperty] -> RepoFormat -> Bool
format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks
    where fht _ [] = False
          fht x (y:ys) | x == sort y = True
                       | otherwise = fht x ys
\end{code}

\begin{code}
rp2ps :: RepoProperty -> PackedString
rp2ps Darcs1_0 = packString "darcs-1.0"
rp2ps Darcs2 = packString "darcs-2"
rp2ps HashedInventory = packString "hashed"
\end{code}