module Darcs.Repository.Create
( createRepository
, createRepositoryV1
, createRepositoryV2
, EmptyRepository(..)
, writePristine
) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( when )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Maybe( isJust )
import System.Directory
( createDirectory
, getCurrentDirectory
, setCurrentDirectory
)
import System.FilePath ( (</>) )
import System.IO.Error
( catchIOError
, isAlreadyExistsError
)
import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )
import Darcs.Patch.Set ( Origin, emptyPatchSet )
import Darcs.Patch.V1 ( RepoPatchV1 )
import Darcs.Patch.V2 ( RepoPatchV2 )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Repository.Cache ( Cache )
import Darcs.Repository.Format
( RepoFormat
, createRepoFormat
, writeRepoFormat
)
import Darcs.Repository.Flags
( UseCache(..)
, WithWorkingDir (..)
, WithPatchIndex (..)
, PatchFormat (..)
)
import Darcs.Repository.Hashed
( pokePristineHash
, pristineDirPath
, patchesDirPath
, inventoriesDirPath
, hashedInventoryPath
)
import Darcs.Repository.Identify ( seekRepo )
import Darcs.Repository.InternalTypes
( Repository
, PristineType(..)
, mkRepo
)
import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk )
import Darcs.Repository.Prefs
( writeDefaultPrefs
, getCaches
, prefsDirPath
)
import Darcs.Util.ByteString( gzReadFilePS )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Hash( encodeBase16 )
import Darcs.Util.Lock
( writeBinFile
, writeDocBinFile
)
import Darcs.Util.Tree( Tree, emptyTree )
import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes )
createRepositoryFiles :: PatchFormat -> WithWorkingDir -> IO RepoFormat
createRepositoryFiles :: PatchFormat -> WithWorkingDir -> IO RepoFormat
createRepositoryFiles patchfmt :: PatchFormat
patchfmt withWorkingDir :: WithWorkingDir
withWorkingDir = do
FilePath
cwd <- IO FilePath
getCurrentDirectory
Maybe (Either FilePath ())
x <- IO (Maybe (Either FilePath ()))
seekRepo
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Either FilePath ()) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Either FilePath ())
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
setCurrentDirectory FilePath
cwd
FilePath -> IO ()
putStrLn "WARNING: creating a nested repository."
FilePath -> IO ()
createDirectory FilePath
darcsdir IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError`
(\e :: IOError
e-> if IOError -> Bool
isAlreadyExistsError IOError
e
then FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail "Tree has already been initialized!"
else FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error creating directory `"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
darcsdirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"'.")
FilePath -> IO ()
createDirectory FilePath
pristineDirPath
FilePath -> IO ()
createDirectory FilePath
patchesDirPath
FilePath -> IO ()
createDirectory FilePath
inventoriesDirPath
FilePath -> IO ()
createDirectory FilePath
prefsDirPath
IO ()
writeDefaultPrefs
let repo_format :: RepoFormat
repo_format = PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
patchfmt WithWorkingDir
withWorkingDir
RepoFormat -> FilePath -> IO ()
writeRepoFormat RepoFormat
repo_format (FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "format")
FilePath -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeBinFile FilePath
hashedInventoryPath ByteString
B.empty
FilePath -> Tree IO -> IO ()
writePristine FilePath
here Tree IO
forall (m :: * -> *). Tree m
emptyTree
RepoFormat -> IO RepoFormat
forall (m :: * -> *) a. Monad m => a -> m a
return RepoFormat
repo_format
data EmptyRepository where
EmptyRepository :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> EmptyRepository
createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> UseCache
-> IO EmptyRepository
createRepository :: PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO EmptyRepository
createRepository patchfmt :: PatchFormat
patchfmt withWorkingDir :: WithWorkingDir
withWorkingDir withPatchIndex :: WithPatchIndex
withPatchIndex useCache :: UseCache
useCache = do
RepoFormat
rfmt <- PatchFormat -> WithWorkingDir -> IO RepoFormat
createRepositoryFiles PatchFormat
patchfmt WithWorkingDir
withWorkingDir
Cache
cache <- UseCache -> FilePath -> IO Cache
getCaches UseCache
useCache FilePath
here
repo :: EmptyRepository
repo@(EmptyRepository r :: Repository ('RepoType 'NoRebase) p Origin Origin Origin
r) <- case PatchFormat
patchfmt of
PatchFormat1 -> EmptyRepository -> IO EmptyRepository
forall (m :: * -> *) a. Monad m => a -> m a
return (EmptyRepository -> IO EmptyRepository)
-> EmptyRepository -> IO EmptyRepository
forall a b. (a -> b) -> a -> b
$ Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
-> EmptyRepository
forall (p :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> EmptyRepository
EmptyRepository (Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
-> EmptyRepository)
-> Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
-> EmptyRepository
forall a b. (a -> b) -> a -> b
$ RepoFormat
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
mkRepoV1 RepoFormat
rfmt Cache
cache
PatchFormat2 -> EmptyRepository -> IO EmptyRepository
forall (m :: * -> *) a. Monad m => a -> m a
return (EmptyRepository -> IO EmptyRepository)
-> EmptyRepository -> IO EmptyRepository
forall a b. (a -> b) -> a -> b
$ Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> EmptyRepository
forall (p :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> EmptyRepository
EmptyRepository (Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> EmptyRepository)
-> Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> EmptyRepository
forall a b. (a -> b) -> a -> b
$ RepoFormat
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
mkRepoV2 RepoFormat
rfmt Cache
cache
WithPatchIndex
-> Repository ('RepoType 'NoRebase) p Origin Origin Origin -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wU.
(RepoPatch p, ApplyState p ~ Tree) =>
WithPatchIndex -> Repository rt p Origin wU Origin -> IO ()
maybeCreatePatchIndex WithPatchIndex
withPatchIndex Repository ('RepoType 'NoRebase) p Origin Origin Origin
r
EmptyRepository -> IO EmptyRepository
forall (m :: * -> *) a. Monad m => a -> m a
return EmptyRepository
repo
mkRepoV1
:: RepoFormat
-> Cache
-> Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin
mkRepoV1 :: RepoFormat
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
mkRepoV1 repofmt :: RepoFormat
repofmt cache :: Cache
cache = FilePath
-> RepoFormat
-> PristineType
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
FilePath
-> RepoFormat -> PristineType -> Cache -> Repository rt p wR wU wT
mkRepo "." RepoFormat
repofmt PristineType
HashedPristine Cache
cache
mkRepoV2
:: RepoFormat
-> Cache
-> Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin
mkRepoV2 :: RepoFormat
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
mkRepoV2 repofmt :: RepoFormat
repofmt cache :: Cache
cache = FilePath
-> RepoFormat
-> PristineType
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
FilePath
-> RepoFormat -> PristineType -> Cache -> Repository rt p wR wU wT
mkRepo "." RepoFormat
repofmt PristineType
HashedPristine Cache
cache
createRepositoryV1
:: WithWorkingDir -> WithPatchIndex -> UseCache
-> IO (Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin)
createRepositoryV1 :: WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO
(Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin)
createRepositoryV1 withWorkingDir :: WithWorkingDir
withWorkingDir withPatchIndex :: WithPatchIndex
withPatchIndex useCache :: UseCache
useCache = do
RepoFormat
rfmt <- PatchFormat -> WithWorkingDir -> IO RepoFormat
createRepositoryFiles PatchFormat
PatchFormat1 WithWorkingDir
withWorkingDir
Cache
cache <- UseCache -> FilePath -> IO Cache
getCaches UseCache
useCache FilePath
here
let repo :: Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
repo = RepoFormat
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
mkRepoV1 RepoFormat
rfmt Cache
cache
WithPatchIndex
-> Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wU.
(RepoPatch p, ApplyState p ~ Tree) =>
WithPatchIndex -> Repository rt p Origin wU Origin -> IO ()
maybeCreatePatchIndex WithPatchIndex
withPatchIndex Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
repo
Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
-> IO
(Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository
('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin Origin Origin
repo
createRepositoryV2
:: WithWorkingDir -> WithPatchIndex -> UseCache
-> IO (Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin)
createRepositoryV2 :: WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO
(Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin)
createRepositoryV2 withWorkingDir :: WithWorkingDir
withWorkingDir withPatchIndex :: WithPatchIndex
withPatchIndex useCache :: UseCache
useCache = do
RepoFormat
rfmt <- PatchFormat -> WithWorkingDir -> IO RepoFormat
createRepositoryFiles PatchFormat
PatchFormat2 WithWorkingDir
withWorkingDir
Cache
cache <- UseCache -> FilePath -> IO Cache
getCaches UseCache
useCache FilePath
here
let repo :: Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
repo = RepoFormat
-> Cache
-> Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
mkRepoV2 RepoFormat
rfmt Cache
cache
WithPatchIndex
-> Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wU.
(RepoPatch p, ApplyState p ~ Tree) =>
WithPatchIndex -> Repository rt p Origin wU Origin -> IO ()
maybeCreatePatchIndex WithPatchIndex
withPatchIndex Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
repo
Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> IO
(Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository
('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
repo
maybeCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> WithPatchIndex -> Repository rt p Origin wU Origin -> IO ()
maybeCreatePatchIndex :: WithPatchIndex -> Repository rt p Origin wU Origin -> IO ()
maybeCreatePatchIndex NoPatchIndex _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeCreatePatchIndex YesPatchIndex repo :: Repository rt p Origin wU Origin
repo =
Repository rt p Origin wU Origin
-> PatchSet rt p Origin Origin -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
createOrUpdatePatchIndexDisk Repository rt p Origin wU Origin
repo PatchSet rt p Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wX. PatchSet rt p wX wX
emptyPatchSet
writePristine :: FilePath -> Tree IO -> IO ()
writePristine :: FilePath -> Tree IO -> IO ()
writePristine dir :: FilePath
dir tree :: Tree IO
tree =
FilePath -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory FilePath
dir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
inv <- FilePath -> IO ByteString
gzReadFilePS FilePath
hashedInventoryPath
Tree IO
tree' <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes Tree IO
tree
Hash
root <- Tree IO -> FilePath -> IO Hash
writeDarcsHashed Tree IO
tree' FilePath
pristineDirPath
FilePath -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile FilePath
hashedInventoryPath (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> Doc
pokePristineHash (ByteString -> FilePath
BC.unpack (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Hash -> ByteString
encodeBase16 Hash
root) ByteString
inv
here :: String
here :: FilePath
here = "."