{-|
License : GPL-2

A set of functions to identify and find Darcs repositories
from a given @URL@ or a given filesystem path.
-}

module Darcs.Repository.Identify
    ( maybeIdentifyRepository -- exported for darcsden
    , identifyRepository
    , identifyRepositoryFor
    , IdentifyRepo(..) -- exported for darcsden
    , ReadingOrWriting(..)
    , findRepository
    , amInRepository
    , amNotInRepository
    , amInHashedRepository
    , seekRepo
    ) where

import Darcs.Prelude

import Darcs.Repository.Format ( tryIdentifyRepoFormat
                               , readProblem
                               , transferProblem
                               )
import System.Directory ( doesDirectoryExist
                        , setCurrentDirectory
                        , createDirectoryIfMissing
                        , doesFileExist
                        )
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( catchIOError )
import Data.Maybe ( fromMaybe )

import Darcs.Repository.Old ( oldRepoFailMsg )
import Darcs.Repository.Flags ( UseCache(..), WorkRepo (..) )
import Darcs.Util.Path
    ( toFilePath
    , ioAbsoluteOrRemote
    , toPath
    )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.Util.Workaround
    ( getCurrentDirectory
    )
import Darcs.Repository.Paths
    ( hashedInventoryPath
    , oldCurrentDirPath
    , oldPristineDirPath
    )
import Darcs.Repository.Prefs ( getCaches )
import Darcs.Repository.InternalTypes
    ( AccessType(..)
    , PristineType(..)
    , Repository
    , mkRepo
    , repoFormat
    )
import Darcs.Util.Global ( darcsdir )

import System.Mem( performGC )

-- | The status of a given directory: is it a darcs repository?
data IdentifyRepo rt p wU wR
    = BadRepository String -- ^ looks like a repository with some error
    | NonRepository String -- ^ safest guess
    | GoodRepository (Repository rt p wU wR)

-- | Try to identify the repository at a given location, passed as a 'String'.
-- If the lcation is ".", then we assume we are identifying the local repository.
-- Otherwise we assume we are dealing with a remote repo, which could be a URL
-- or an absolute path.
maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
maybeIdentifyRepository :: forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
maybeIdentifyRepository UseCache
useCache String
"." =
    do darcs <- String -> IO Bool
doesDirectoryExist String
darcsdir
       if not darcs
        then return (NonRepository $ "Missing " ++ darcsdir ++ " directory")
        else do
        repoFormatOrError <- tryIdentifyRepoFormat "."
        here <- ioAbsoluteOrRemote "."
        case repoFormatOrError of
          Left String
err -> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR))
-> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a b. (a -> b) -> a -> b
$ String -> IdentifyRepo 'RO p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String -> IdentifyRepo rt p wU wR
NonRepository String
err
          Right RepoFormat
rf ->
              case RepoFormat -> Maybe String
readProblem RepoFormat
rf of
              Just String
err -> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR))
-> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a b. (a -> b) -> a -> b
$ String -> IdentifyRepo 'RO p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String -> IdentifyRepo rt p wU wR
BadRepository String
err
              Maybe String
Nothing -> do pris <- IO PristineType
identifyPristine
                            cs <- getCaches useCache Nothing
                            return $ GoodRepository $ mkRepo here rf pris cs
maybeIdentifyRepository UseCache
useCache String
url' =
 do url <- String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote String
url'
    repoFormatOrError <- tryIdentifyRepoFormat (toPath url)
    case repoFormatOrError of
      Left String
e -> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR))
-> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a b. (a -> b) -> a -> b
$ String -> IdentifyRepo 'RO p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String -> IdentifyRepo rt p wU wR
NonRepository String
e
      Right RepoFormat
rf -> case RepoFormat -> Maybe String
readProblem RepoFormat
rf of
                  Just String
err -> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR))
-> IdentifyRepo 'RO p wU wR -> IO (IdentifyRepo 'RO p wU wR)
forall a b. (a -> b) -> a -> b
$ String -> IdentifyRepo 'RO p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String -> IdentifyRepo rt p wU wR
BadRepository String
err
                  Maybe String
Nothing ->  do cs <- UseCache -> Maybe AbsoluteOrRemotePath -> IO Cache
getCaches UseCache
useCache (AbsoluteOrRemotePath -> Maybe AbsoluteOrRemotePath
forall a. a -> Maybe a
Just AbsoluteOrRemotePath
url)
                                 return $ GoodRepository $ mkRepo url rf NoPristine cs

identifyPristine :: IO PristineType
identifyPristine :: IO PristineType
identifyPristine =
    do pristine <- String -> IO Bool
doesDirectoryExist String
oldPristineDirPath
       current  <- doesDirectoryExist oldCurrentDirPath
       hashinv  <- doesFileExist      hashedInventoryPath
       case (pristine || current, hashinv) of
           (Bool
False, Bool
False) -> PristineType -> IO PristineType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PristineType
NoPristine
           (Bool
True,  Bool
False) -> PristineType -> IO PristineType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PristineType
PlainPristine
           (Bool
False, Bool
True ) -> PristineType -> IO PristineType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PristineType
HashedPristine
           (Bool, Bool)
_ -> String -> IO PristineType
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Multiple pristine trees."

-- | identifyRepository identifies the repo at 'url'. Warning:
-- you have to know what kind of patches are found in that repo.
identifyRepository :: UseCache -> String -> IO (Repository 'RO p wU wR)
identifyRepository :: forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (Repository 'RO p wU wR)
identifyRepository UseCache
useCache String
url =
    do er <- UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
maybeIdentifyRepository UseCache
useCache String
url
       case er of
         BadRepository String
s -> String -> IO (Repository 'RO p wU wR)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
         NonRepository String
s -> String -> IO (Repository 'RO p wU wR)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
         GoodRepository Repository 'RO p wU wR
r -> Repository 'RO p wU wR -> IO (Repository 'RO p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Repository 'RO p wU wR
r

data ReadingOrWriting = Reading | Writing

-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',
-- but fails if it is not compatible for reading from and writing to.
identifyRepositoryFor :: ReadingOrWriting
                      -> Repository rt p wU wR
                      -> UseCache
                      -> String
                      -> IO (Repository 'RO p vR vU)
identifyRepositoryFor :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR vR vU.
ReadingOrWriting
-> Repository rt p wU wR
-> UseCache
-> String
-> IO (Repository 'RO p vR vU)
identifyRepositoryFor ReadingOrWriting
what Repository rt p wU wR
us UseCache
useCache String
them_loc = do
  them <- UseCache -> String -> IO (Repository 'RO p vR vU)
forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (Repository 'RO p wU wR)
identifyRepository UseCache
useCache String
them_loc
  case
    case what of
      ReadingOrWriting
Reading -> RepoFormat -> RepoFormat -> Maybe String
transferProblem (Repository 'RO p vR vU -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RO p vR vU
them) (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
us)
      ReadingOrWriting
Writing -> RepoFormat -> RepoFormat -> Maybe String
transferProblem (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
us) (Repository 'RO p vR vU -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository 'RO p vR vU
them) 
    of
      Just String
e -> String -> IO (Repository 'RO p vR vU)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Repository 'RO p vR vU))
-> String -> IO (Repository 'RO p vR vU)
forall a b. (a -> b) -> a -> b
$ String
"Incompatibility with repository " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
them_loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
      Maybe String
Nothing -> Repository 'RO p vR vU -> IO (Repository 'RO p vR vU)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Repository 'RO p vR vU
them

amInRepository :: WorkRepo -> IO (Either String ())
amInRepository :: WorkRepo -> IO (Either String ())
amInRepository (WorkRepoDir String
d) =
  do
    String -> IO ()
setCurrentDirectory String
d
    status <- UseCache
-> String
-> IO (IdentifyRepo 'RO (ZonkAny 3) (ZonkAny 4) (ZonkAny 5))
forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
maybeIdentifyRepository UseCache
YesUseCache String
"."
    case status of
      GoodRepository Repository 'RO (ZonkAny 3) (ZonkAny 4) (ZonkAny 5)
_ -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either String ()
forall a b. b -> Either a b
Right ())
      BadRepository  String
e -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"While " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" looks like a repository directory, we have a problem with it:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
      NonRepository  String
_ -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left String
"You need to be in a repository directory to run this command.")
  IO (Either String ())
-> (IOError -> IO (Either String ())) -> IO (Either String ())
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError`
    \IOError
e -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left (IOError -> String
forall a. Show a => a -> String
show IOError
e))
  
amInRepository WorkRepo
_ =
  Either String () -> Maybe (Either String ()) -> Either String ()
forall a. a -> Maybe a -> a
fromMaybe (String -> Either String ()
forall a b. a -> Either a b
Left String
"You need to be in a repository directory to run this command.") (Maybe (Either String ()) -> Either String ())
-> IO (Maybe (Either String ())) -> IO (Either String ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Either String ()))
seekRepo

amInHashedRepository :: WorkRepo -> IO (Either String ())
amInHashedRepository :: WorkRepo -> IO (Either String ())
amInHashedRepository WorkRepo
wd
 = do inrepo <- WorkRepo -> IO (Either String ())
amInRepository WorkRepo
wd
      case inrepo of
       Right ()
_ -> do pristine <- IO PristineType
identifyPristine
                     case pristine of
                       PristineType
HashedPristine -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either String ()
forall a b. b -> Either a b
Right ())
                       PristineType
_ -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left String
oldRepoFailMsg)
       Either String ()
left    -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either String ()
left

-- | hunt upwards for the darcs repository
-- This keeps changing up one parent directory, testing at each
-- step if the current directory is a repository or not.
-- The result is:
--   Nothing, if no repository found
--   Just (Left errorMessage), if bad repository found
--   Just (Right ()), if good repository found.
-- WARNING this changes the current directory for good if matchFn succeeds
seekRepo :: IO (Maybe (Either String ()))
seekRepo :: IO (Maybe (Either String ()))
seekRepo = IO String
getCurrentDirectory IO String
-> (String -> IO (Maybe (Either String ())))
-> IO (Maybe (Either String ()))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO (Maybe (Either String ()))
helper where
  helper :: String -> IO (Maybe (Either String ()))
helper String
startpwd = do
    status <- UseCache
-> String
-> IO (IdentifyRepo 'RO (ZonkAny 0) (ZonkAny 1) (ZonkAny 2))
forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
maybeIdentifyRepository UseCache
YesUseCache String
"."
    case status of
      GoodRepository Repository 'RO (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)
_ -> Maybe (Either String ()) -> IO (Maybe (Either String ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String ()) -> IO (Maybe (Either String ())))
-> (Either String () -> Maybe (Either String ()))
-> Either String ()
-> IO (Maybe (Either String ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String () -> Maybe (Either String ())
forall a. a -> Maybe a
Just (Either String () -> IO (Maybe (Either String ())))
-> Either String () -> IO (Maybe (Either String ()))
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
      BadRepository String
e -> Maybe (Either String ()) -> IO (Maybe (Either String ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String ()) -> IO (Maybe (Either String ())))
-> (Either String () -> Maybe (Either String ()))
-> Either String ()
-> IO (Maybe (Either String ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String () -> Maybe (Either String ())
forall a. a -> Maybe a
Just (Either String () -> IO (Maybe (Either String ())))
-> Either String () -> IO (Maybe (Either String ()))
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
e
      NonRepository String
_ ->
        IO (Maybe (Either String ()))
-> (IOError -> IO (Maybe (Either String ())))
-> IO (Maybe (Either String ()))
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError
          (do cd <- String -> String
forall a. FilePathLike a => a -> String
toFilePath (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO String
getCurrentDirectory
              setCurrentDirectory ".."
              cd' <- toFilePath `fmap` getCurrentDirectory
              if cd' /= cd
                then helper startpwd
                else do
                  setCurrentDirectory startpwd
                  return Nothing)
          (\IOError
e -> do
             Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
             Maybe (Either String ()) -> IO (Maybe (Either String ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String ())
forall a. Maybe a
Nothing)

-- The performGC in this function is a workaround for a library/GHC bug,
-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a
-- problem on fast machines, but virtual ones trip this from time to time)
amNotInRepository :: WorkRepo -> IO (Either String ())
amNotInRepository :: WorkRepo -> IO (Either String ())
amNotInRepository (WorkRepoDir String
d) = do
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
d
       IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` (IO ()
performGC IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
d)
    -- note that the above could always fail
    String -> IO ()
setCurrentDirectory String
d
    WorkRepo -> IO (Either String ())
amNotInRepository WorkRepo
WorkRepoCurrentDir
amNotInRepository WorkRepo
_ = do
       status <- UseCache
-> String
-> IO (IdentifyRepo 'RO (ZonkAny 6) (ZonkAny 7) (ZonkAny 8))
forall (p :: * -> * -> *) wU wR.
UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)
maybeIdentifyRepository UseCache
YesUseCache String
"."
       case status of
         GoodRepository Repository 'RO (ZonkAny 6) (ZonkAny 7) (ZonkAny 8)
_ -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left String
"You may not run this command in a repository.")
         BadRepository String
e  -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"You may not run this command in a repository.\nBy the way, we have a problem with it:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
         NonRepository String
_  -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either String ()
forall a b. b -> Either a b
Right ())

findRepository :: WorkRepo -> IO (Either String ())
findRepository :: WorkRepo -> IO (Either String ())
findRepository WorkRepo
workrepo =
  case WorkRepo
workrepo of
    WorkRepoPossibleURL String
d | String -> Bool
isValidLocalPath String
d -> do
      String -> IO ()
setCurrentDirectory String
d
      WorkRepo -> IO (Either String ())
findRepository WorkRepo
WorkRepoCurrentDir
    WorkRepoDir String
d -> do
      String -> IO ()
setCurrentDirectory String
d
      WorkRepo -> IO (Either String ())
findRepository WorkRepo
WorkRepoCurrentDir
    WorkRepo
_ -> Either String () -> Maybe (Either String ()) -> Either String ()
forall a. a -> Maybe a -> a
fromMaybe (() -> Either String ()
forall a b. b -> Either a b
Right ()) (Maybe (Either String ()) -> Either String ())
-> IO (Maybe (Either String ())) -> IO (Either String ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Either String ()))
seekRepo
  IO (Either String ())
-> (IOError -> IO (Either String ())) -> IO (Either String ())
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
e ->
    Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left (IOError -> String
forall a. Show a => a -> String
show IOError
e))