From 4e765327cad2a08d76f6b649d1d9a9e0948ea752 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 29 Oct 2012 00:15:43 -0400 Subject: [PATCH] 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. --- Assistant.hs | 46 ++++--- Assistant/BranchChange.hs | 2 +- Assistant/Common.hs | 9 +- Assistant/Monad.hs | 83 +++++++++++++ Assistant/Threads/Watcher.hs | 143 +++++++++++----------- Assistant/Threads/WebApp.hs | 46 +++---- Assistant/WebApp.hs | 15 ++- Assistant/WebApp/Configurators.hs | 4 +- Assistant/WebApp/Configurators/Edit.hs | 2 +- Assistant/WebApp/Configurators/Pairing.hs | 2 +- Assistant/WebApp/Configurators/S3.hs | 6 +- Assistant/WebApp/Configurators/Ssh.hs | 8 +- Assistant/WebApp/Configurators/XMPP.hs | 4 +- Assistant/WebApp/DashBoard.hs | 3 +- Assistant/WebApp/SideBar.hs | 11 +- Assistant/WebApp/Types.hs | 16 +-- Assistant/WebApp/Utility.hs | 43 +++---- Command/WebApp.hs | 26 ++-- 18 files changed, 259 insertions(+), 210 deletions(-) create mode 100644 Assistant/Monad.hs diff --git a/Assistant.hs b/Assistant.hs index ade4621e5d..bdca20fefb 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -120,13 +120,6 @@ module Assistant where import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus -import Assistant.Changes -import Assistant.Commits -import Assistant.Pushes -import Assistant.ScanRemotes -import Assistant.BranchChange -import Assistant.TransferQueue -import Assistant.TransferSlots import Assistant.Threads.DaemonStatus import Assistant.Threads.Watcher import Assistant.Threads.Committer @@ -180,24 +173,28 @@ startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO () startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do checkCanWatch dstatus <- startDaemonStatus - liftIO $ daemonize $ run dstatus st + liftIO $ daemonize $ + runAssistant go =<< newAssistantData st dstatus where - run dstatus st = do - changechan <- newChangeChan - commitchan <- newCommitChan - pushmap <- newFailedPushMap - transferqueue <- newTransferQueue - transferslots <- newTransferSlots - scanremotes <- newScanRemoteMap - branchhandle <- newBranchChangeHandle - pushnotifier <- newPushNotifier + go = do + d <- getAssistant id + st <- getAssistant threadState + dstatus <- getAssistant daemonStatus + changechan <- getAssistant changeChan + commitchan <- getAssistant commitChan + pushmap <- getAssistant failedPushMap + transferqueue <- getAssistant transferQueue + transferslots <- getAssistant transferSlots + scanremotes <- getAssistant scanRemoteMap + branchhandle <- getAssistant branchChangeHandle + pushnotifier <- getAssistant pushNotifier #ifdef WITH_WEBAPP - urlrenderer <- newUrlRenderer + urlrenderer <- liftIO $ newUrlRenderer #endif - mapM_ (startthread dstatus) + mapM_ (startthread d) [ watch $ commitThread st changechan commitchan transferqueue dstatus #ifdef WITH_WEBAPP - , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter + , assist $ webAppThread d urlrenderer False Nothing webappwaiter #ifdef WITH_PAIRING , assist $ pairListenerThread st dstatus scanremotes urlrenderer #endif @@ -220,11 +217,12 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do #endif , watch $ watchThread st dstatus transferqueue changechan ] - waitForTermination + liftIO waitForTermination watch a = (True, a) assist a = (False, a) - startthread dstatus (watcher, t) - | watcher || assistant = void $ forkIO $ - runNamedThread dstatus t + startthread d (watcher, t) + | watcher || assistant = void $ liftIO $ forkIO $ + flip runAssistant d $ + runNamedThread t | otherwise = noop diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs index d1d1c20dfe..cf7080f904 100644 --- a/Assistant/BranchChange.hs +++ b/Assistant/BranchChange.hs @@ -8,7 +8,7 @@ module Assistant.BranchChange where import Control.Concurrent.MSampleVar -import Assistant.Common +import Common.Annex newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ()) diff --git a/Assistant/Common.hs b/Assistant/Common.hs index d6df77f69a..a6c6b89353 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -14,8 +14,9 @@ module Assistant.Common ( ) where import Common.Annex as X -import Assistant.DaemonStatus +import Assistant.Monad as X import Assistant.Alert +import Assistant.DaemonStatus import System.Log.Logger import qualified Control.Exception as E @@ -26,10 +27,10 @@ data NamedThread = NamedThread ThreadName (IO ()) debug :: ThreadName -> [String] -> IO () debug threadname ws = debugM threadname $ unwords $ (threadname ++ ":") : ws -runNamedThread :: DaemonStatusHandle -> NamedThread -> IO () -runNamedThread dstatus (NamedThread name a) = go +runNamedThread :: NamedThread -> Assistant () +runNamedThread (NamedThread name a) = liftIO . go =<< getAssistant daemonStatus where - go = do + go dstatus = do r <- E.try a :: IO (Either E.SomeException ()) case r of Right _ -> noop diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs new file mode 100644 index 0000000000..fa982b45e8 --- /dev/null +++ b/Assistant/Monad.hs @@ -0,0 +1,83 @@ +{- git-annex assistant monad + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-} + +module Assistant.Monad ( + Assistant, + AssistantData(..), + newAssistantData, + runAssistant, + getAssistant, + liftAnnex +) where + +import "mtl" Control.Monad.Reader +import Control.Monad.Base (liftBase, MonadBase) + +import Common.Annex +import Assistant.ThreadedMonad +import Assistant.DaemonStatus +import Assistant.ScanRemotes +import Assistant.TransferQueue +import Assistant.TransferSlots +import Assistant.Pushes +import Assistant.Commits +import Assistant.Changes +import Assistant.BranchChange + +newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } + deriving ( + Monad, + MonadIO, + MonadReader AssistantData, + Functor, + Applicative + ) + +instance MonadBase IO Assistant where + liftBase = Assistant . liftBase + +data AssistantData = AssistantData + { threadState :: ThreadState + , daemonStatus :: DaemonStatusHandle + , scanRemoteMap :: ScanRemoteMap + , transferQueue :: TransferQueue + , transferSlots :: TransferSlots + , pushNotifier :: PushNotifier + , failedPushMap :: FailedPushMap + , commitChan :: CommitChan + , changeChan :: ChangeChan + , branchChangeHandle :: BranchChangeHandle + } + +newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData +newAssistantData st dstatus = AssistantData + <$> pure st + <*> pure dstatus + <*> newScanRemoteMap + <*> newTransferQueue + <*> newTransferSlots + <*> newPushNotifier + <*> newFailedPushMap + <*> newCommitChan + <*> newChangeChan + <*> newBranchChangeHandle + +runAssistant :: Assistant a -> AssistantData -> IO a +runAssistant a = runReaderT (mkAssistant a) + +getAssistant :: (AssistantData -> a) -> Assistant a +getAssistant = reader + +{- Runs an action in the git-annex monad. Note that the same monad state + - is shared amoung all assistant threads, so only one of these can run at + - a time. Therefore, long-duration actions should be avoided. -} +liftAnnex :: Annex a -> Assistant a +liftAnnex a = do + st <- reader threadState + liftIO $ runThreadState st a diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 310a6e9848..5d24fe23f2 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -59,16 +59,16 @@ watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do void $ watchDir "." ignored hooks startup debug thisThread [ "watching", "."] - where - startup = startupScan st dstatus - hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a - hooks = mkWatchHooks - { addHook = hook onAdd - , delHook = hook onDel - , addSymlinkHook = hook onAddSymlink - , delDirHook = hook onDelDir - , errHook = hook onErr - } + where + startup = startupScan st dstatus + hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a + hooks = mkWatchHooks + { addHook = hook onAdd + , delHook = hook onDel + , addSymlinkHook = hook onAddSymlink + , delDirHook = hook onDelDir + , errHook = hook onErr + } {- Initial scartup scan. The action should return once the scan is complete. -} startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a @@ -89,7 +89,7 @@ startupScan st dstatus scanner = do ignored :: FilePath -> Bool ignored = ig . takeFileName - where + where ig ".git" = True ig ".gitignore" = True ig ".gitattributes" = True @@ -109,14 +109,13 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu Left e -> print e Right Nothing -> noop Right (Just change) -> recordChange changechan change - where - go = runThreadState st $ handler threadname file filestatus dstatus transferqueue + where + go = runThreadState st $ handler threadname file filestatus dstatus transferqueue onAdd :: Handler onAdd _ file filestatus _ _ | maybe False isRegularFile filestatus = pendingAddChange file | otherwise = noChange - where {- A symlink might be an arbitrary symlink, which is just added. - Or, if it is a git-annex symlink, ensure it points to the content @@ -124,69 +123,67 @@ onAdd _ file filestatus _ _ -} onAddSymlink :: Handler onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.lookupFile file - where - go (Just (key, _)) = do - link <- calcGitLink file key - ifM ((==) link <$> liftIO (readSymbolicLink file)) - ( do - s <- liftIO $ getDaemonStatus dstatus - checkcontent key s - ensurestaged link s - , do - liftIO $ debug threadname ["fix symlink", file] - liftIO $ removeFile file - liftIO $ createSymbolicLink link file - checkcontent key =<< liftIO (getDaemonStatus dstatus) - addlink link - ) - go Nothing = do -- other symlink - link <- liftIO (readSymbolicLink file) - ensurestaged link =<< liftIO (getDaemonStatus dstatus) + where + go (Just (key, _)) = do + link <- calcGitLink file key + ifM ((==) link <$> liftIO (readSymbolicLink file)) + ( do + s <- liftIO $ getDaemonStatus dstatus + checkcontent key s + ensurestaged link s + , do + liftIO $ debug threadname ["fix symlink", file] + liftIO $ removeFile file + liftIO $ createSymbolicLink link file + checkcontent key =<< liftIO (getDaemonStatus dstatus) + addlink link + ) + go Nothing = do -- other symlink + link <- liftIO (readSymbolicLink file) + ensurestaged link =<< liftIO (getDaemonStatus dstatus) - {- This is often called on symlinks that are already - - staged correctly. A symlink may have been deleted - - and being re-added, or added when the watcher was - - not running. So they're normally restaged to make sure. - - - - As an optimisation, during the startup scan, avoid - - restaging everything. Only links that were created since - - the last time the daemon was running are staged. - - (If the daemon has never ran before, avoid staging - - links too.) - -} - ensurestaged link daemonstatus - | scanComplete daemonstatus = addlink link - | otherwise = case filestatus of - Just s - | not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange - _ -> addlink link + {- This is often called on symlinks that are already + - staged correctly. A symlink may have been deleted + - and being re-added, or added when the watcher was + - not running. So they're normally restaged to make sure. + - + - As an optimisation, during the startup scan, avoid + - restaging everything. Only links that were created since + - the last time the daemon was running are staged. + - (If the daemon has never ran before, avoid staging + - links too.) + -} + ensurestaged link daemonstatus + | scanComplete daemonstatus = addlink link + | otherwise = case filestatus of + Just s + | not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange + _ -> addlink link - {- For speed, tries to reuse the existing blob for - - the symlink target. -} - addlink link = do - liftIO $ debug threadname ["add symlink", file] - v <- catObjectDetails $ Ref $ ':':file - case v of - Just (currlink, sha) - | s2w8 link == L.unpack currlink -> - stageSymlink file sha - _ -> do - sha <- inRepo $ - Git.HashObject.hashObject BlobObject link + {- For speed, tries to reuse the existing blob for symlink target. -} + addlink link = do + liftIO $ debug threadname ["add symlink", file] + v <- catObjectDetails $ Ref $ ':':file + case v of + Just (currlink, sha) + | s2w8 link == L.unpack currlink -> stageSymlink file sha - madeChange file LinkChange + _ -> do + sha <- inRepo $ + Git.HashObject.hashObject BlobObject link + stageSymlink file sha + madeChange file LinkChange - {- When a new link appears, or a link is changed, - - after the startup scan, handle getting or - - dropping the key's content. -} - checkcontent key daemonstatus - | scanComplete daemonstatus = do - present <- inAnnex key - unless present $ - queueTransfers Next transferqueue dstatus - key (Just file) Download - handleDrops dstatus present key (Just file) - | otherwise = noop + {- When a new link appears, or a link is changed, after the startup + - scan, handle getting or dropping the key's content. -} + checkcontent key daemonstatus + | scanComplete daemonstatus = do + present <- inAnnex key + unless present $ + queueTransfers Next transferqueue dstatus + key (Just file) Download + handleDrops dstatus present key (Just file) + | otherwise = noop onDel :: Handler onDel threadname file _ _dstatus _ = do diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 6ed827e012..bb8fcd1866 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -28,12 +28,6 @@ import Assistant.WebApp.Configurators.XMPP import Assistant.WebApp.Documentation import Assistant.WebApp.OtherRepos import Assistant.ThreadedMonad -import Assistant.DaemonStatus -import Assistant.ScanRemotes -import Assistant.TransferQueue -import Assistant.TransferSlots -import Assistant.Pushes -import Assistant.Commits import Utility.WebApp import Utility.FileMode import Utility.TempFile @@ -51,51 +45,43 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") type Url = String -webAppThread - :: Maybe ThreadState - -> DaemonStatusHandle - -> ScanRemoteMap - -> TransferQueue - -> TransferSlots - -> PushNotifier - -> CommitChan +webAppThread + :: AssistantData -> UrlRenderer + -> Bool -> Maybe (IO String) -> Maybe (Url -> FilePath -> IO ()) -> NamedThread -webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer postfirstrun onstartup = thread $ do +webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ do webapp <- WebApp - <$> pure mst - <*> pure dstatus - <*> pure scanremotes - <*> pure transferqueue - <*> pure transferslots - <*> pure pushnotifier - <*> pure commitchan + <$> pure assistantdata <*> (pack <$> genRandomToken) - <*> getreldir mst + <*> getreldir <*> pure $(embed "static") <*> newWebAppState <*> pure postfirstrun + <*> pure noannex setUrlRenderer urlrenderer $ yesodRender webapp (pack "") app <- toWaiAppPlain webapp app' <- ifM debugEnabled ( return $ httpDebugLogger app , return app ) - runWebApp app' $ \port -> case mst of - Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> + runWebApp app' $ \port -> if noannex + then withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile Nothing - Just st -> do + else do + let st = threadState assistantdata htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile go port webapp htmlshim (Just urlfile) where thread = NamedThread thisThread - getreldir Nothing = return Nothing - getreldir (Just st) = Just <$> - (relHome =<< absPath - =<< runThreadState st (fromRepo repoPath)) + getreldir + | noannex = return Nothing + | otherwise = Just <$> + (relHome =<< absPath + =<< runThreadState (threadState assistantdata) (fromRepo repoPath)) go port webapp htmlshim urlfile = do debug thisThread ["running on port", show port] let url = myUrl webapp port diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 0b59ccc101..16b11c0eab 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -72,6 +72,12 @@ newWebAppState = do { showIntro = True , otherRepos = otherrepos } +getAssistantY :: forall sub a. (AssistantData -> a) -> GHandler sub WebApp a +getAssistantY f = f <$> (assistantData <$> getYesod) + +getDaemonStatusY :: forall sub. GHandler sub WebApp DaemonStatus +getDaemonStatusY = liftIO . getDaemonStatus =<< getAssistantY daemonStatus + getWebAppState :: forall sub. GHandler sub WebApp WebAppState getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod @@ -88,7 +94,10 @@ modifyWebAppState a = go =<< webAppState <$> getYesod - value is returned. -} runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a -runAnnex fallback a = maybe (return fallback) go =<< threadState <$> getYesod +runAnnex fallback a = ifM (noAnnex <$> getYesod) + ( return fallback + , go =<< getAssistantY threadState + ) where go st = liftIO $ runThreadState st a @@ -103,9 +112,7 @@ newNotifier selector = do liftIO $ notificationHandleToId <$> newNotificationHandle notifier getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster -getNotifier selector = do - webapp <- getYesod - liftIO $ selector <$> getDaemonStatus (daemonStatus webapp) +getNotifier selector = selector <$> getDaemonStatusY {- Adds the auth parameter as a hidden field on a form. Must be put into - every form. -} diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 166819d6c8..aa9f499f33 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 64d89c911e..650aae4cc9 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -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" diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index a20f7959bf..7584fb5754 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/S3.hs b/Assistant/WebApp/Configurators/S3.hs index e4401d445f..793c034c8d 100644 --- a/Assistant/WebApp/Configurators/S3.hs +++ b/Assistant/WebApp/Configurators/S3.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 9da291b0c6..6f44d4c35f 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index 80472c1d75..4940ddf4ce 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -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 $ diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 897fddf735..7cf1e41521 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -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 diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs index 6c765925b4..70ca1566ff 100644 --- a/Assistant/WebApp/SideBar.hs +++ b/Assistant/WebApp/SideBar.hs @@ -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. -} diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index be2438669b..e0f5167b0d 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -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 diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index 6369282a2b..19e22ac8b6 100644 --- a/Assistant/WebApp/Utility.hs +++ b/Assistant/WebApp/Utility.hs @@ -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 diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 5a372f94d5..aff760ee45 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -12,11 +12,6 @@ import Command import Assistant import Assistant.Common import Assistant.DaemonStatus -import Assistant.ScanRemotes -import Assistant.TransferQueue -import Assistant.TransferSlots -import Assistant.Pushes -import Assistant.Commits import Assistant.Threads.WebApp import Assistant.WebApp import Assistant.Install @@ -101,20 +96,21 @@ autoStart autostartfile = do -} firstRun :: IO () firstRun = do + {- Without a repository, we cannot have an Annex monad, so cannot + - get a ThreadState. Using undefined is only safe because the + - webapp checks its noAnnex field before accessing the + - threadstate. -} + let st = undefined + {- Get a DaemonStatus without running in the Annex monad. -} dstatus <- atomically . newTMVar =<< newDaemonStatus - scanremotes <- newScanRemoteMap - transferqueue <- newTransferQueue - transferslots <- newTransferSlots + d <- newAssistantData st dstatus urlrenderer <- newUrlRenderer - pushnotifier <- newPushNotifier - commitchan <- newCommitChan v <- newEmptyMVar let callback a = Just $ a v - void $ runNamedThread dstatus $ - webAppThread Nothing dstatus scanremotes - transferqueue transferslots pushnotifier commitchan - urlrenderer - (callback signaler) (callback mainthread) + void $ flip runAssistant d $ runNamedThread $ + webAppThread d urlrenderer True + (callback signaler) + (callback mainthread) where signaler v = do putMVar v ""