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
|
@ -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
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue