finished pushing Assistant monad into all relevant files

All temporary and old functions are removed.
This commit is contained in:
Joey Hess 2012-10-30 17:14:26 -04:00
parent 47d94eb9a4
commit 93ffd47d76
26 changed files with 262 additions and 301 deletions

View file

@ -102,7 +102,7 @@ repoList onlyconfigured includehere
where
configured = do
rs <- filter (not . Remote.readonly) . syncRemotes
<$> runAssistantY getDaemonStatus
<$> liftAssistant getDaemonStatus
runAnnex [] $ do
u <- getUUID
let l = map Remote.uuid rs

View file

@ -77,7 +77,7 @@ setRepoConfig uuid mremote oldc newc = do
, Param name
]
void $ Remote.remoteListRefresh
runAssistantY updateSyncRemotes
liftAssistant updateSyncRemotes
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
editRepositoryAForm def = RepoConfig

View file

@ -87,17 +87,15 @@ getInprogressPairR _ = noPairing
-}
startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
startPairing stage oncancel alert muuid displaysecret secret = do
dstatus <- lift $ getAssistantY daemonStatusHandle
urlrender <- lift getUrlRender
reldir <- fromJust . relDir <$> lift getYesod
sendrequests <- lift $ runAssistantY $ asIO2 $ mksendrequests urlrender
sendrequests <- lift $ liftAssistant $ asIO2 $ mksendrequests urlrender
{- Generating a ssh key pair can take a while, so do it in the
- background. -}
void $ liftIO $ forkIO $ do
keypair <- genSshKeyPair
pairdata <- PairData
thread <- lift $ liftAssistant $ asIO $ do
keypair <- liftIO $ genSshKeyPair
pairdata <- liftIO $ PairData
<$> getHostname
<*> myUserName
<*> pure reldir
@ -105,7 +103,8 @@ startPairing stage oncancel alert muuid displaysecret secret = do
<*> (maybe genUUID return muuid)
let sender = multicastPairMsg Nothing secret pairdata
let pip = PairingInProgress secret Nothing keypair pairdata stage
startSending dstatus pip stage $ sendrequests sender
startSending pip stage $ sendrequests sender
void $ liftIO $ forkIO thread
lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
where

View file

@ -117,9 +117,9 @@ makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> H
makeS3Remote (S3Creds ak sk) name setup config = do
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
r <- runAssistantY $ liftAnnex $ addRemote $ do
r <- liftAssistant $ liftAnnex $ addRemote $ do
makeSpecialRemote name S3.remote config
return remotename
setup r
runAssistantY $ syncNewRemote r
liftAssistant $ syncNewRemote r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r

View file

@ -283,7 +283,7 @@ makeSsh' rsync setup sshdata keypair =
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
makeSshRepo forcersync setup sshdata = do
r <- runAssistantY $ makeSshRemote forcersync sshdata
r <- liftAssistant $ makeSshRemote forcersync sshdata
setup r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r

View file

@ -35,8 +35,8 @@ import qualified Data.Text as T
xmppNeeded :: Handler ()
xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
urlrender <- getUrlRender
void $ runAssistantY $ do
close <- asIO removeAlert
void $ liftAssistant $ do
close <- asIO1 removeAlert
addAlert $ xmppNeededAlert $ AlertButton
{ buttonLabel = "Configure a Jabber account"
, buttonUrl = urlrender XMPPR
@ -60,7 +60,7 @@ getXMPPR = xmppPage $ do
where
storecreds creds = do
void $ runAnnex undefined $ setXMPPCreds creds
runAssistantY notifyRestart
liftAssistant notifyRestart
redirect ConfigR
#else
getXMPPR = xmppPage $

View file

@ -37,9 +37,8 @@ import Control.Concurrent
transfersDisplay :: Bool -> Widget
transfersDisplay warnNoScript = do
webapp <- lift getYesod
d <- lift $ getAssistantY id
current <- lift $ M.toList <$> getCurrentTransfers
queued <- liftIO $ getTransferQueue $ transferQueue d
queued <- lift $ liftAssistant getTransferQueue
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued
if null transfers

View file

@ -28,7 +28,7 @@ sideBarDisplay = do
let content = do
{- Add newest alerts to the sidebar. -}
alertpairs <- lift $ M.toList . alertMap
<$> runAssistantY getDaemonStatus
<$> liftAssistant getDaemonStatus
mapM_ renderalert $
take displayAlerts $ reverse $ sortAlertPairs alertpairs
let ident = "sidebar"
@ -73,12 +73,12 @@ getSideBarR nid = do
{- Called by the client to close an alert. -}
getCloseAlert :: AlertId -> Handler ()
getCloseAlert = runAssistantY . removeAlert
getCloseAlert = liftAssistant . removeAlert
{- When an alert with a button is clicked on, the button takes us here. -}
getClickAlert :: AlertId -> Handler ()
getClickAlert i = do
m <- alertMap <$> runAssistantY getDaemonStatus
m <- alertMap <$> liftAssistant getDaemonStatus
case M.lookup i m of
Just (Alert { alertButton = Just b }) -> do
{- Spawn a thread to run the action while redirecting. -}

View file

@ -36,15 +36,13 @@ changeSyncable (Just r) True = do
syncRemote r
changeSyncable (Just r) False = do
changeSyncFlag r False
d <- getAssistantY id
let dstatus = daemonStatusHandle d
runAssistantY $ updateSyncRemotes
liftAssistant $ updateSyncRemotes
{- Stop all transfers to or from this remote.
- XXX Can't stop any ongoing scan, or git syncs. -}
void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom
void $ liftAssistant $ dequeueTransfers tofrom
mapM_ (cancelTransfer False) =<<
filter tofrom . M.keys <$>
runAssistantY (currentTransfers <$> getDaemonStatus)
liftAssistant (currentTransfers <$> getDaemonStatus)
where
tofrom t = transferUUID t == Remote.uuid r
@ -60,24 +58,21 @@ changeSyncFlag r enabled = runAnnex undefined $ do
{- Start syncing remote, using a background thread. -}
syncRemote :: Remote -> Handler ()
syncRemote = runAssistantY . syncNewRemote
syncRemote = liftAssistant . syncNewRemote
pauseTransfer :: Transfer -> Handler ()
pauseTransfer = cancelTransfer True
cancelTransfer :: Bool -> Transfer -> Handler ()
cancelTransfer pause t = do
tq <- getAssistantY transferQueue
m <- getCurrentTransfers
dstatus <- getAssistantY daemonStatusHandle
unless pause $ liftIO $
unless pause $
{- remove queued transfer -}
void $ dequeueTransfers tq dstatus $
equivilantTransfer t
void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t
{- stop running transfer -}
maybe noop stop (M.lookup t m)
where
stop info = runAssistantY $ do
stop info = liftAssistant $ do
{- When there's a thread associated with the
- transfer, it's signaled first, to avoid it
- displaying any alert about the transfer having
@ -107,18 +102,16 @@ startTransfer t = do
where
go info = maybe (start info) resume $ transferTid info
startqueued = do
dstatus <- getAssistantY daemonStatusHandle
q <- getAssistantY transferQueue
is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
is <- liftAssistant $ map snd <$> getMatchingTransfers (== t)
maybe noop start $ headMaybe is
resume tid = do
runAssistantY $ alterTransferInfo t $
liftAssistant $ alterTransferInfo t $
\i -> i { transferPaused = False }
liftIO $ throwTo tid ResumeTransfer
start info = runAssistantY $ do
start info = liftAssistant $ do
program <- liftIO readProgramFile
inImmediateTransferSlot $
Transferrer.startTransfer program t info
getCurrentTransfers :: Handler TransferMap
getCurrentTransfers = currentTransfers <$> runAssistantY getDaemonStatus
getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus