2016-05-04 13:44:06 +02:00
|
|
|
{- This file is part of Vervis.
|
|
|
|
-
|
2019-10-07 16:05:52 +02:00
|
|
|
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
2016-05-04 13:44:06 +02:00
|
|
|
-
|
|
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
|
|
-
|
|
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
|
|
- rights to this software to the public domain worldwide. This software is
|
|
|
|
- distributed without any warranty.
|
|
|
|
-
|
|
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
|
|
- with this software. If not, see
|
|
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
|
|
-}
|
|
|
|
|
2016-05-08 16:28:03 +02:00
|
|
|
module Darcs.Local.Repository
|
2019-10-07 16:05:52 +02:00
|
|
|
( writeDefaultsFile
|
|
|
|
, createRepo
|
2016-05-05 09:29:19 +02:00
|
|
|
, readPristineRoot
|
2016-05-04 13:44:06 +02:00
|
|
|
)
|
|
|
|
where
|
|
|
|
|
2016-07-02 10:51:29 +02:00
|
|
|
import Darcs.Util.Hash
|
2019-10-07 16:05:52 +02:00
|
|
|
import Data.Bits
|
|
|
|
import Data.Text (Text)
|
2016-05-04 13:44:06 +02:00
|
|
|
import System.Directory (createDirectory)
|
|
|
|
import System.Exit (ExitCode (..))
|
|
|
|
import System.FilePath ((</>))
|
2016-05-08 16:28:03 +02:00
|
|
|
import System.IO (withBinaryFile, IOMode (ReadMode))
|
2019-10-07 16:05:52 +02:00
|
|
|
import System.Posix.Files
|
2016-05-04 13:44:06 +02:00
|
|
|
import System.Process (createProcess, proc, waitForProcess)
|
|
|
|
|
2016-05-05 09:29:19 +02:00
|
|
|
import qualified Data.ByteString as B
|
2019-10-07 16:05:52 +02:00
|
|
|
import qualified Data.Text as T
|
|
|
|
import qualified Data.Text.IO as TIO
|
|
|
|
|
2019-10-20 11:19:49 +02:00
|
|
|
writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> Text -> IO ()
|
|
|
|
writeDefaultsFile path cmd authority sharer repo = do
|
2019-10-07 16:05:52 +02:00
|
|
|
let file = path </> "_darcs" </> "prefs" </> "defaults"
|
2019-10-20 11:19:49 +02:00
|
|
|
TIO.writeFile file $ defaultsContent cmd authority sharer repo
|
2019-10-07 16:05:52 +02:00
|
|
|
setFileMode file $ ownerReadMode .|. ownerWriteMode
|
|
|
|
where
|
2019-10-20 11:19:49 +02:00
|
|
|
defaultsContent :: FilePath -> Text -> Text -> Text -> Text
|
|
|
|
defaultsContent hook authority sharer repo =
|
|
|
|
T.concat
|
|
|
|
[ "apply posthook "
|
|
|
|
, T.pack hook, " ", authority, " ", sharer, " ", repo
|
|
|
|
]
|
2016-05-05 09:29:19 +02:00
|
|
|
|
2016-05-04 13:44:06 +02:00
|
|
|
{-
|
|
|
|
initialRepoTree :: FileName -> DirTree B.ByteString
|
|
|
|
initialRepoTree repo =
|
|
|
|
Dir repo
|
|
|
|
[ Dir "_darcs"
|
|
|
|
--[ File "format"
|
|
|
|
-- "hashed|no-working-dir\n\
|
|
|
|
-- \darcs-2"
|
|
|
|
--, File "hashed_inventory" ""
|
|
|
|
--, File "index" ???
|
|
|
|
, Dir "inventories" []
|
|
|
|
, Dir "patches" []
|
|
|
|
, Dir "prefs" []
|
|
|
|
-- [ File "binaries" ""
|
|
|
|
-- , File "boring" ""
|
|
|
|
-- , File "motd" ""
|
|
|
|
-- ]
|
|
|
|
, Dir "pristine.hashed" []
|
|
|
|
]
|
|
|
|
]
|
|
|
|
-}
|
|
|
|
|
|
|
|
-- | initialize a new bare repository at a specific location.
|
2016-05-04 19:17:47 +02:00
|
|
|
createRepo
|
2016-05-04 13:44:06 +02:00
|
|
|
:: FilePath
|
|
|
|
-- ^ Parent directory which already exists
|
|
|
|
-> String
|
|
|
|
-- ^ Name of new repo, i.e. new directory to create under the parent
|
2019-10-07 16:05:52 +02:00
|
|
|
-> FilePath
|
|
|
|
-- ^ Path of Vervis hook program
|
|
|
|
-> Text
|
2019-10-20 11:19:49 +02:00
|
|
|
-- ^ Instance HTTP authority
|
|
|
|
-> Text
|
2019-10-07 16:05:52 +02:00
|
|
|
-- ^ Repo sharer textual ID
|
|
|
|
-> Text
|
|
|
|
-- ^ Repo textual ID
|
2016-05-04 13:44:06 +02:00
|
|
|
-> IO ()
|
2019-10-20 11:19:49 +02:00
|
|
|
createRepo parent name cmd authority sharer repo = do
|
2016-05-04 13:44:06 +02:00
|
|
|
let path = parent </> name
|
|
|
|
createDirectory path
|
2016-08-04 10:00:29 +02:00
|
|
|
let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path]
|
2016-05-04 13:44:06 +02:00
|
|
|
(_, _, _, ph) <- createProcess settings
|
|
|
|
ec <- waitForProcess ph
|
|
|
|
case ec of
|
2019-10-20 11:19:49 +02:00
|
|
|
ExitSuccess -> writeDefaultsFile path cmd authority sharer repo
|
2016-05-04 13:44:06 +02:00
|
|
|
ExitFailure n -> error $ "darcs init failed with exit code " ++ show n
|
2016-05-05 09:29:19 +02:00
|
|
|
|
|
|
|
readPristineRoot :: FilePath -> IO (Maybe Int, Hash)
|
|
|
|
readPristineRoot darcsDir = do
|
|
|
|
let inventoryFile = darcsDir </> "hashed_inventory"
|
2016-05-08 16:28:03 +02:00
|
|
|
line <- withBinaryFile inventoryFile ReadMode B.hGetLine
|
2016-05-05 09:29:19 +02:00
|
|
|
let hashBS = B.drop 9 line
|
|
|
|
return (Nothing, decodeBase16 hashBS)
|