finished pushing Assistant monad into all relevant files
All temporary and old functions are removed.
This commit is contained in:
parent
47d94eb9a4
commit
93ffd47d76
26 changed files with 262 additions and 301 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue