diff options
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 2 | ||||
| -rw-r--r-- | Assistant/WebApp.hs | 12 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 3 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 3 |
4 files changed, 14 insertions, 6 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index ca81498f4..9cdbae451 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -59,7 +59,7 @@ webAppThread st dstatus transferqueue onstartup = do token <- genRandomToken s <- newWebAppState return $ WebApp - { threadState = st + { threadState = Just st , daemonStatus = dstatus , transferQueue = transferqueue , secretToken = pack token diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index fc40ca5bf..f7fb7bb6e 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -30,7 +30,7 @@ staticFiles "static" mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") data WebApp = WebApp - { threadState :: ThreadState + { threadState :: Maybe ThreadState , daemonStatus :: DaemonStatusHandle , transferQueue :: TransferQueue , secretToken :: Text @@ -104,6 +104,16 @@ modifyWebAppState a = go =<< webAppState <$> getYesod v <- takeTMVar s putTMVar s $ a v +{- Runs an Annex action from the webapp. + - + - When the webapp is run outside a git-annex repository, the fallback + - value is returned. + -} +runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a +runAnnex fallback a = maybe (return fallback) go =<< threadState <$> getYesod + where + go st = liftIO $ runThreadState st a + waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp () waitNotifier selector nid = do notifier <- getNotifier selector diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 0930741e2..ee3209ce2 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -12,7 +12,6 @@ module Assistant.WebApp.Configurators where import Assistant.Common import Assistant.WebApp import Assistant.WebApp.SideBar -import Assistant.ThreadedMonad import Utility.Yesod import qualified Remote import Logs.Web (webUUID) @@ -27,7 +26,7 @@ introDisplay :: Text -> Widget introDisplay ident = do webapp <- lift getYesod let reldir = relDir webapp - l <- liftIO $ runThreadState (threadState webapp) $ do + l <- lift $ runAnnex [] $ do u <- getUUID rs <- map Remote.uuid <$> Remote.remoteList rs' <- snd <$> trustPartition DeadTrusted rs diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index f80fb8787..9a9fccdaa 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -14,7 +14,6 @@ import Assistant.WebApp import Assistant.WebApp.SideBar import Assistant.WebApp.Notifications import Assistant.WebApp.Configurators -import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.TransferQueue import Utility.NotificationBroadcaster @@ -35,7 +34,7 @@ import qualified Data.Map as M transfersDisplay :: Bool -> Widget transfersDisplay warnNoScript = do webapp <- lift getYesod - current <- liftIO $ runThreadState (threadState webapp) $ + current <- lift $ runAnnex [] $ M.toList . currentTransfers <$> liftIO (getDaemonStatus $ daemonStatus webapp) queued <- liftIO $ getTransferQueue $ transferQueue webapp |