tweak types so the webapp can run without a threadstate when outside an annex

This commit is contained in:
Joey Hess 2012-07-31 11:19:40 -04:00
parent e9d9d9d5ea
commit b9b0097876
4 changed files with 14 additions and 6 deletions

View file

@ -59,7 +59,7 @@ webAppThread st dstatus transferqueue onstartup = do
token <- genRandomToken token <- genRandomToken
s <- newWebAppState s <- newWebAppState
return $ WebApp return $ WebApp
{ threadState = st { threadState = Just st
, daemonStatus = dstatus , daemonStatus = dstatus
, transferQueue = transferqueue , transferQueue = transferqueue
, secretToken = pack token , secretToken = pack token

View file

@ -30,7 +30,7 @@ staticFiles "static"
mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
data WebApp = WebApp data WebApp = WebApp
{ threadState :: ThreadState { threadState :: Maybe ThreadState
, daemonStatus :: DaemonStatusHandle , daemonStatus :: DaemonStatusHandle
, transferQueue :: TransferQueue , transferQueue :: TransferQueue
, secretToken :: Text , secretToken :: Text
@ -104,6 +104,16 @@ modifyWebAppState a = go =<< webAppState <$> getYesod
v <- takeTMVar s v <- takeTMVar s
putTMVar s $ a v 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 :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
waitNotifier selector nid = do waitNotifier selector nid = do
notifier <- getNotifier selector notifier <- getNotifier selector

View file

@ -12,7 +12,6 @@ module Assistant.WebApp.Configurators where
import Assistant.Common import Assistant.Common
import Assistant.WebApp import Assistant.WebApp
import Assistant.WebApp.SideBar import Assistant.WebApp.SideBar
import Assistant.ThreadedMonad
import Utility.Yesod import Utility.Yesod
import qualified Remote import qualified Remote
import Logs.Web (webUUID) import Logs.Web (webUUID)
@ -27,7 +26,7 @@ introDisplay :: Text -> Widget
introDisplay ident = do introDisplay ident = do
webapp <- lift getYesod webapp <- lift getYesod
let reldir = relDir webapp let reldir = relDir webapp
l <- liftIO $ runThreadState (threadState webapp) $ do l <- lift $ runAnnex [] $ do
u <- getUUID u <- getUUID
rs <- map Remote.uuid <$> Remote.remoteList rs <- map Remote.uuid <$> Remote.remoteList
rs' <- snd <$> trustPartition DeadTrusted rs rs' <- snd <$> trustPartition DeadTrusted rs

View file

@ -14,7 +14,6 @@ import Assistant.WebApp
import Assistant.WebApp.SideBar import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators import Assistant.WebApp.Configurators
import Assistant.ThreadedMonad
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.TransferQueue import Assistant.TransferQueue
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
@ -35,7 +34,7 @@ import qualified Data.Map as M
transfersDisplay :: Bool -> Widget transfersDisplay :: Bool -> Widget
transfersDisplay warnNoScript = do transfersDisplay warnNoScript = do
webapp <- lift getYesod webapp <- lift getYesod
current <- liftIO $ runThreadState (threadState webapp) $ current <- lift $ runAnnex [] $
M.toList . currentTransfers M.toList . currentTransfers
<$> liftIO (getDaemonStatus $ daemonStatus webapp) <$> liftIO (getDaemonStatus $ daemonStatus webapp)
queued <- liftIO $ getTransferQueue $ transferQueue webapp queued <- liftIO $ getTransferQueue $ transferQueue webapp