Assistant monad, stage 1
This adds the Assistant monad, and an AssistantData structure. So far, none of the assistant's threads run in the monad yet.
This commit is contained in:
parent
ec0bac9d73
commit
4e765327ca
18 changed files with 259 additions and 210 deletions
|
@ -69,7 +69,7 @@ setRepoConfig uuid mremote oldc newc = do
|
|||
when (repoSyncable oldc /= repoSyncable newc) $
|
||||
changeSyncable mremote (repoSyncable newc)
|
||||
when (isJust mremote && repoName oldc /= repoName newc) $ do
|
||||
dstatus <- daemonStatus <$> getYesod
|
||||
dstatus <- getAssistantY daemonStatus
|
||||
runAnnex undefined $ do
|
||||
name <- fromRepo $ uniqueRemoteName (T.unpack $ repoName newc) 0
|
||||
inRepo $ Git.Command.run "remote"
|
||||
|
|
|
@ -87,7 +87,7 @@ getInprogressPairR _ = noPairing
|
|||
-}
|
||||
startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
|
||||
startPairing stage oncancel alert muuid displaysecret secret = do
|
||||
dstatus <- daemonStatus <$> lift getYesod
|
||||
dstatus <- lift $ getAssistantY daemonStatus
|
||||
urlrender <- lift getUrlRender
|
||||
reldir <- fromJust . relDir <$> lift getYesod
|
||||
|
||||
|
|
|
@ -116,13 +116,13 @@ getEnableS3R uuid = s3Configurator $ do
|
|||
|
||||
makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
||||
makeS3Remote (S3Creds ak sk) name setup config = do
|
||||
webapp <- getYesod
|
||||
let st = fromJust $ threadState webapp
|
||||
d <- getAssistantY id
|
||||
let st = threadState d
|
||||
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
|
||||
liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
|
||||
r <- liftIO $ runThreadState st $ addRemote $ do
|
||||
makeSpecialRemote name S3.remote config
|
||||
return remotename
|
||||
setup r
|
||||
liftIO $ syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r
|
||||
liftIO $ syncNewRemote st (daemonStatus d) (scanRemoteMap d) r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
|
@ -283,11 +283,11 @@ makeSsh' rsync setup sshdata keypair =
|
|||
|
||||
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
|
||||
makeSshRepo forcersync setup sshdata = do
|
||||
webapp <- getYesod
|
||||
d <- getAssistantY id
|
||||
r <- liftIO $ makeSshRemote
|
||||
(fromJust $ threadState webapp)
|
||||
(daemonStatus webapp)
|
||||
(scanRemotes webapp)
|
||||
(threadState d)
|
||||
(daemonStatus d)
|
||||
(scanRemoteMap d)
|
||||
forcersync sshdata
|
||||
setup r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
|
@ -34,7 +34,7 @@ import qualified Data.Text as T
|
|||
{- Displays an alert suggesting to configure XMPP, with a button. -}
|
||||
xmppNeeded :: Handler ()
|
||||
xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
|
||||
dstatus <- daemonStatus <$> getYesod
|
||||
dstatus <- getAssistantY daemonStatus
|
||||
urlrender <- getUrlRender
|
||||
void $ liftIO $ addAlert dstatus $ xmppNeededAlert $ AlertButton
|
||||
{ buttonLabel = "Configure a Jabber account"
|
||||
|
@ -59,7 +59,7 @@ getXMPPR = xmppPage $ do
|
|||
where
|
||||
storecreds creds = do
|
||||
void $ runAnnex undefined $ setXMPPCreds creds
|
||||
liftIO . notifyRestart =<< pushNotifier <$> getYesod
|
||||
liftIO . notifyRestart =<< getAssistantY pushNotifier
|
||||
redirect ConfigR
|
||||
#else
|
||||
getXMPPR = xmppPage $
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue