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

@ -101,8 +101,8 @@ repoList onlyconfigured includehere
| otherwise = list =<< (++) <$> configured <*> rest
where
configured = do
rs <- filter (not . Remote.readonly) . syncRemotes <$>
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
rs <- filter (not . Remote.readonly) . syncRemotes
<$> getDaemonStatusY
runAnnex [] $ do
u <- getUUID
let l = map Remote.uuid rs

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 $

View file

@ -38,8 +38,9 @@ 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 webapp
queued <- liftIO $ getTransferQueue $ transferQueue d
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued
if null transfers

View file

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

View file

@ -12,13 +12,6 @@ module Assistant.WebApp.Types where
import Assistant.Common
import Assistant.Ssh
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Pushes
import Assistant.Commits
import Assistant.Alert
import Assistant.Pairing
import Utility.NotificationBroadcaster
@ -35,18 +28,13 @@ publicFiles "static"
mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
data WebApp = WebApp
{ threadState :: Maybe ThreadState
, daemonStatus :: DaemonStatusHandle
, scanRemotes :: ScanRemoteMap
, transferQueue :: TransferQueue
, transferSlots :: TransferSlots
, pushNotifier :: PushNotifier
, commitChan :: CommitChan
{ assistantData :: AssistantData
, secretToken :: Text
, relDir :: Maybe FilePath
, getStatic :: Static
, webAppState :: TMVar WebAppState
, postFirstRun :: Maybe (IO String)
, noAnnex :: Bool
}
instance Yesod WebApp where

View file

@ -23,7 +23,6 @@ import Logs.Transfer
import Locations.UserConfig
import qualified Config
import Yesod
import qualified Data.Map as M
import Control.Concurrent
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
@ -37,13 +36,13 @@ changeSyncable (Just r) True = do
syncRemote r
changeSyncable (Just r) False = do
changeSyncFlag r False
webapp <- getYesod
let dstatus = daemonStatus webapp
let st = fromJust $ threadState webapp
d <- getAssistantY id
let dstatus = daemonStatus d
let st = threadState d
liftIO $ runThreadState st $ updateSyncRemotes dstatus
{- Stop all transfers to or from this remote.
- XXX Can't stop any ongoing scan, or git syncs. -}
void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom
mapM_ (cancelTransfer False) =<<
filter tofrom . M.keys <$>
liftIO (currentTransfers <$> getDaemonStatus dstatus)
@ -63,11 +62,11 @@ changeSyncFlag r enabled = runAnnex undefined $ do
{- Start syncing remote, using a background thread. -}
syncRemote :: Remote -> Handler ()
syncRemote remote = do
webapp <- getYesod
d <- getAssistantY id
liftIO $ syncNewRemote
(fromJust $ threadState webapp)
(daemonStatus webapp)
(scanRemotes webapp)
(threadState d)
(daemonStatus d)
(scanRemoteMap d)
remote
pauseTransfer :: Transfer -> Handler ()
@ -75,13 +74,13 @@ pauseTransfer = cancelTransfer True
cancelTransfer :: Bool -> Transfer -> Handler ()
cancelTransfer pause t = do
webapp <- getYesod
let dstatus = daemonStatus webapp
dstatus <- getAssistantY daemonStatus
tq <- getAssistantY transferQueue
m <- getCurrentTransfers
liftIO $ do
unless pause $
{- remove queued transfer -}
void $ dequeueTransfers (transferQueue webapp) dstatus $
void $ dequeueTransfers tq dstatus $
equivilantTransfer t
{- stop running transfer -}
maybe noop (stop dstatus) (M.lookup t m)
@ -118,28 +117,24 @@ startTransfer t = do
where
go info = maybe (start info) resume $ transferTid info
startqueued = do
webapp <- getYesod
let dstatus = daemonStatus webapp
let q = transferQueue webapp
dstatus <- getAssistantY daemonStatus
q <- getAssistantY transferQueue
is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
maybe noop start $ headMaybe is
resume tid = do
webapp <- getYesod
let dstatus = daemonStatus webapp
dstatus <- getAssistantY daemonStatus
liftIO $ do
alterTransferInfo dstatus t $ \i -> i
{ transferPaused = False }
throwTo tid ResumeTransfer
start info = do
webapp <- getYesod
let st = fromJust $ threadState webapp
let dstatus = daemonStatus webapp
let slots = transferSlots webapp
let commitchan = commitChan webapp
st <- getAssistantY threadState
dstatus <- getAssistantY daemonStatus
slots <- getAssistantY transferSlots
commitchan <- getAssistantY commitChan
liftIO $ inImmediateTransferSlot dstatus slots $ do
program <- readProgramFile
Transferrer.startTransfer st dstatus commitchan program t info
getCurrentTransfers :: Handler TransferMap
getCurrentTransfers = currentTransfers
<$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
getCurrentTransfers = currentTransfers <$> getDaemonStatusY