mirror of https://github.com/voidlizard/hbs2
85 lines
2.3 KiB
Haskell
85 lines
2.3 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.Git3.Repo.Tools where
|
|
|
|
import HBS2.Git3.Prelude
|
|
import HBS2.Git3.State
|
|
import HBS2.Git3.Repo.Types
|
|
|
|
import HBS2.System.Dir
|
|
|
|
import HBS2.Git.Local.CLI
|
|
|
|
import Data.Config.Suckless.Script
|
|
|
|
import Control.Applicative
|
|
import Crypto.Bip39
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.Either
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.Maybe
|
|
import Data.Text qualified as Text
|
|
import Data.Word
|
|
import Lens.Micro.Platform
|
|
import System.Random hiding (next)
|
|
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
listRemotes :: MonadIO m => m [(GitRef, GitRepoKey)]
|
|
listRemotes = do
|
|
|
|
git <- findGitDir >>= orThrow NoGitDir
|
|
|
|
conf <- liftIO (readFile (git </> "config"))
|
|
<&> parseTop
|
|
<&> fromRight mempty
|
|
|
|
let urls = flip fix (mempty,Nothing,conf) $ \next -> \case
|
|
(acc,_, ListVal [SymbolVal "remote", StringLike x] : rest) ->
|
|
next (acc,Just x, rest)
|
|
|
|
(acc, Just x, ListVal [SymbolVal "url", _, RepoURL3 u] : rest) ->
|
|
next ( (fromString x, u) : acc, Nothing, rest)
|
|
|
|
(acc, x, _ : rest) -> next ( acc, x, rest)
|
|
|
|
(acc,_,[]) -> acc
|
|
|
|
pure urls
|
|
|
|
resolveRepoKeyThrow :: MonadIO m => [Syntax C] -> m GitRepoKey
|
|
resolveRepoKeyThrow = \case
|
|
[ SignPubKeyLike url ] -> pure url
|
|
[ RepoURL url ] -> pure url
|
|
[ StringLike x ] -> do
|
|
refs <- listRemotes
|
|
lookup (fromString x) refs & orThrow (GitRemoteKeyNotResolved x)
|
|
x -> throwIO (GitRemoteKeyNotResolved (show $ pretty (mkList x)))
|
|
|
|
newRemoteName :: MonadIO m => GitRepoKey -> m GitRef
|
|
newRemoteName key = do
|
|
refs <- listRemotes <&> HM.fromList
|
|
|
|
flip fix Nothing $ \again i -> do
|
|
|
|
when (i > Just 128) $ throwIO GitCantGenerateRemoteName
|
|
|
|
suff <- case i of
|
|
Nothing -> pure mempty
|
|
Just _ -> do
|
|
p <- randomIO @Word8 <&> Text.pack . show
|
|
pure $ "-" <> p
|
|
|
|
name <- toMnemonic (LBS.toStrict . LBS.drop 8 $ serialise key)
|
|
& orThrow GitCantGenerateRemoteName
|
|
<&> Text.intercalate "-" . take 2 . Text.words
|
|
<&> (<> suff)
|
|
<&> fromString @GitRef . Text.unpack
|
|
|
|
if not (HM.member name refs) then pure name
|
|
else again (succ <$> ( i <|> Just 0) )
|
|
|
|
|