src/Darcs/Repository/Format.lhs

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