mirror of https://github.com/voidlizard/hbs2
100 lines
2.9 KiB
Haskell
100 lines
2.9 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
module GitRemotePush where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.OrDie
|
|
import HBS2.System.Logger.Simple
|
|
import HBS2.Net.Auth.Credentials hiding (getCredentials)
|
|
|
|
import HBS2.Git.Local
|
|
import HBS2.Git.Local.CLI
|
|
|
|
import HBS2Git.Config as Config
|
|
import HBS2Git.Types
|
|
import HBS2Git.State
|
|
import HBS2Git.App
|
|
import HBS2Git.Export (exportRefOnly,exportRefDeleted)
|
|
import HBS2Git.Import (importRefLogNew)
|
|
|
|
import GitRemoteTypes
|
|
|
|
import Control.Monad.Reader
|
|
import Data.Functor
|
|
import Data.Set (Set)
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
import Control.Monad.Catch
|
|
import Control.Monad.Trans.Resource
|
|
|
|
newtype RunWithConfig m a =
|
|
WithConfig { fromWithConf :: ReaderT [Syntax C] m a }
|
|
deriving newtype ( Applicative
|
|
, Functor
|
|
, Monad
|
|
, MonadIO
|
|
, MonadReader [Syntax C]
|
|
, MonadTrans
|
|
, MonadThrow
|
|
, MonadCatch
|
|
-- , MonadMask
|
|
, MonadUnliftIO
|
|
)
|
|
|
|
|
|
runWithConfig :: MonadIO m => [Syntax C] -> RunWithConfig m a -> m a
|
|
runWithConfig conf m = runReaderT (fromWithConf m) conf
|
|
|
|
instance MonadIO m => HasConf (RunWithConfig (GitRemoteApp m)) where
|
|
getConf = ask
|
|
|
|
instance MonadIO m => HasCatAPI (RunWithConfig (GitRemoteApp m)) where
|
|
getHttpCatAPI = lift getHttpCatAPI
|
|
getHttpSizeAPI = lift getHttpSizeAPI
|
|
getHttpPutAPI = lift getHttpPutAPI
|
|
getHttpRefLogGetAPI = lift getHttpRefLogGetAPI
|
|
|
|
instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
|
|
getCredentials = lift . getCredentials
|
|
setCredentials r c = lift $ setCredentials r c
|
|
|
|
push :: forall m . ( MonadIO m
|
|
, MonadCatch m
|
|
, HasProgress (RunWithConfig (GitRemoteApp m))
|
|
, MonadUnliftIO m
|
|
)
|
|
|
|
=> RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef)
|
|
|
|
|
|
|
|
push remote what@[Just bFrom , Just br] = do
|
|
(_, syn) <- Config.configInit
|
|
|
|
dbPath <- makeDbPath remote
|
|
db <- dbEnv dbPath
|
|
|
|
runWithConfig syn do
|
|
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
|
loadCredentials mempty
|
|
trace $ "PUSH PARAMS" <+> pretty what
|
|
gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|]
|
|
_ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh
|
|
importRefLogNew False remote
|
|
pure (Just br)
|
|
|
|
push remote [Nothing, Just br] = do
|
|
(_, syn) <- Config.configInit
|
|
|
|
runWithConfig syn do
|
|
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
|
loadCredentials mempty
|
|
trace $ "deleting remote reference" <+> pretty br
|
|
exportRefDeleted () remote br
|
|
importRefLogNew False remote
|
|
pure (Just br)
|
|
|
|
push r w = do
|
|
warn $ "ignoring weird push" <+> pretty w <+> pretty r
|
|
pure Nothing
|
|
|