1 -- Copyright (C) 2005 David Roundy
    2 --
    3 -- This file is licensed under the GPL, version two or later.
    4 
    5 {-# OPTIONS_GHC -cpp #-}
    6 {-# LANGUAGE CPP #-}
    7 
    8 module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat,
    9                     create_repo_format, writeRepoFormat,
   10                     write_problem, read_problem, readfrom_and_writeto_problem,
   11                     format_has, format_has_together,
   12                   ) where
   13 
   14 import Data.List ( sort )
   15 import Data.Maybe ( isJust, catMaybes )
   16 import Control.Monad ( msum )
   17 
   18 import Darcs.SignalHandler ( catchNonSignal )
   19 import Darcs.External ( fetchFilePS, Cachable( Cachable ) )
   20 import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory,
   21                                  UseOldFashionedInventory ) )
   22 import Darcs.Lock ( writeBinFile )
   23 import Darcs.Utils ( catchall, prettyException )
   24 import Progress ( beginTedious, endTedious, finishedOneIO )
   25 import Darcs.Global ( darcsdir )
   26 
   27 import ByteStringUtils ( linesPS )
   28 import qualified Data.ByteString.Char8 as BC (split, unpack, singleton, elemIndex, pack)
   29 import qualified Data.ByteString       as B (ByteString, null, empty)
   30 import qualified ByteStringUtils       as BU ( intercalate )
   31 
   32 #include "impossible.h"
   33 
   34 data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory
   35 
   36 -- | @RepoFormat@ is the representation of the format of a
   37 -- repository. Each sublist corresponds to a line in the format
   38 -- file. Each line is decomposed into words.
   39 newtype RepoFormat = RF [[B.ByteString]] deriving ( Show )
   40 
   41 -- | The file where the format information should be.
   42 df :: FilePath
   43 df = darcsdir++"/format"
   44 
   45 -- | @identifyRepoFormat URL@ identifies the format of the repository
   46 -- at the given address. Return @Left reason@ if it fails, where
   47 -- @reason@ explains why we weren't able to identify the format.
   48 identifyRepoFormat :: String -> IO (Either String RepoFormat)
   49 identifyRepoFormat repo =
   50  do let k = "Identifying repository "++repo
   51     beginTedious k
   52     finishedOneIO k "format"
   53     dff <- fetchFilePS (repo ++ "/" ++ df) Cachable `catchall` return B.empty
   54     -- below is a workaround for servers that don't return a 404 on nonexistent files
   55     rf <- if B.null dff || isJust (BC.elemIndex '<' dff)
   56           then do finishedOneIO k "inventory"
   57                   have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")
   58                   case have_inventory of
   59                     Right _ -> return $ Right default_repo_format
   60                     Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")"
   61           else return $ Right $ parse_repo_format dff
   62     endTedious k
   63     return rf
   64     where drfe x = fetchFilePS x Cachable >> return True
   65           doesRemoteFileExist x = (fmap Right) (drfe x) `catchNonSignal`
   66                                   (\e -> return (Left (prettyException e)))
   67 
   68 -- | @writeRepoFormat@ writes the repo format to the given file.
   69 writeRepoFormat :: RepoFormat -> FilePath -> IO ()
   70 writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $
   71                               map (BC.unpack . BU.intercalate (BC.singleton '|')) rf
   72 
   73 parse_repo_format :: B.ByteString -> RepoFormat
   74 parse_repo_format ps =
   75     RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps
   76 
   77 -- | The repo format we assume if we do not find a format file.
   78 default_repo_format :: RepoFormat
   79 default_repo_format = RF [[rp2ps Darcs1_0]]
   80 
   81 create_repo_format :: [DarcsFlag] -> RepoFormat
   82 create_repo_format fs = RF ([map rp2ps flags2inv] ++ maybe2)
   83     where flags2inv | UseFormat2 `elem` fs = [HashedInventory]
   84                     | UseHashedInventory `elem` fs = [HashedInventory]
   85                     | UseOldFashionedInventory `elem` fs = [Darcs1_0]
   86                     | otherwise = [HashedInventory]
   87           maybe2 = if UseFormat2 `notElem` fs &&
   88                       (UseOldFashionedInventory `elem` fs ||
   89                        UseHashedInventory `elem` fs)
   90                    then []
   91                    else [[rp2ps Darcs2]]
   92 
   93 -- | @write_problem from@ tells if we can write to a repo in format @form@.
   94 -- it returns @Nothing@ if there's no problem writing to such a repository.
   95 write_problem :: RepoFormat -> Maybe String
   96 write_problem rf | isJust $ read_problem rf = read_problem rf
   97 write_problem (RF ks) = unlines `fmap` justsOrNothing (map wp ks)
   98     where wp x | all is_known x = Nothing
   99           wp [] = impossible                                                                                                          
  100           wp x = Just $ unwords $ "Can't write repository format: " :
  101                  map BC.unpack (filter (not . is_known) x)
  102 
  103 
  104 -- | @write_problem from@ tells if we can read and write to a repo in
  105 -- format @form@.  it returns @Nothing@ if there's no problem reading
  106 -- and writing to such a repository.
  107 readfrom_and_writeto_problem :: RepoFormat -> RepoFormat -> Maybe String
  108 readfrom_and_writeto_problem inrf outrf
  109     | format_has Darcs2 inrf /= format_has Darcs2 outrf
  110         = Just "Cannot mix darcs-2 repositories with older formats" 
  111     | otherwise = msum [read_problem inrf, write_problem outrf]
  112 
  113 
  114 -- | @read_problem from@ tells if we can write to a repo in format @form@.
  115 -- it returns @Nothing@ if there's no problem reading from such a repository.
  116 read_problem :: RepoFormat -> Maybe String
  117 read_problem rf | format_has Darcs1_0 rf && format_has Darcs2 rf
  118                     = Just "Invalid repositoryformat:  format 2 is incompatible with format 1"
  119 read_problem (RF ks) = unlines `fmap` justsOrNothing (map rp ks)
  120     where rp x | any is_known x = Nothing
  121           rp [] = impossible                                                                                                           
  122           rp x = Just $ unwords $
  123                  "Can't understand repository format:" : map BC.unpack x
  124 
  125 
  126 -- | Does this version of darcs know how to handle this property?
  127 is_known :: B.ByteString -> Bool
  128 is_known p = p `elem` map rp2ps known_properties
  129 
  130 -- | This is the list of properties which this version of darcs knows
  131 -- how to handle.
  132 known_properties :: [RepoProperty]
  133 known_properties = [Darcs1_0, Darcs2, HashedInventory]
  134 
  135 justsOrNothing :: [Maybe x] -> Maybe [x]
  136 justsOrNothing mxs =
  137  case catMaybes mxs of
  138    [] -> Nothing
  139    xs -> Just xs
  140 
  141 format_has :: RepoProperty -> RepoFormat -> Bool
  142 format_has f (RF ks) = rp2ps f `elem` concat ks
  143 
  144 format_has_together :: [RepoProperty] -> RepoFormat -> Bool
  145 format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks
  146     where fht _ [] = False
  147           fht x (y:ys) | x == sort y = True
  148                        | otherwise = fht x ys
  149 
  150 rp2ps :: RepoProperty -> B.ByteString
  151 rp2ps Darcs1_0 = BC.pack "darcs-1.0"
  152 rp2ps Darcs2 = BC.pack "darcs-2"
  153 rp2ps HashedInventory = BC.pack "hashed"