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:
Joey Hess 2012-10-29 00:15:43 -04:00
parent ec0bac9d73
commit 4e765327ca
18 changed files with 259 additions and 210 deletions

View file

@ -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"

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 $