mirror of https://github.com/voidlizard/hbs2
107 lines
3.1 KiB
Haskell
107 lines
3.1 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 (Monad m, HasGlobalOptions m) => HasGlobalOptions (RunWithConfig m) where
|
|
addGlobalOption k v = lift $ addGlobalOption k v
|
|
getGlobalOption k = lift $ getGlobalOption k
|
|
|
|
instance (Monad m, HasStorage m) => HasStorage (RunWithConfig m) where
|
|
getStorage = lift getStorage
|
|
|
|
instance (Monad m, HasRPC m) => HasRPC (RunWithConfig m) where
|
|
getRPC = lift getRPC
|
|
|
|
instance MonadIO m => HasConf (RunWithConfig (GitRemoteApp m)) where
|
|
getConf = ask
|
|
|
|
instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
|
|
getCredentials = lift . getCredentials
|
|
setCredentials r c = lift $ setCredentials r c
|
|
|
|
|
|
instance MonadIO m => HasEncryptionKeys (RunWithConfig (GitRemoteApp m)) where
|
|
addEncryptionKey = lift . addEncryptionKey
|
|
findEncryptionKey = lift . findEncryptionKey
|
|
enumEncryptionKeys = lift enumEncryptionKeys
|
|
|
|
push :: forall m . ( MonadIO m
|
|
, MonadCatch m
|
|
, HasConf m
|
|
, HasRefCredentials m
|
|
, HasEncryptionKeys m
|
|
, HasGlobalOptions m
|
|
, HasStorage m
|
|
, HasRPC m
|
|
, MonadUnliftIO m
|
|
, MonadMask m
|
|
)
|
|
|
|
=> RepoRef -> [Maybe GitRef] -> m (Maybe GitRef)
|
|
|
|
|
|
push remote what@[Just bFrom , Just br] = do
|
|
|
|
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
|
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
|
|
|
|
_ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef
|
|
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
|
|
|