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
s <- newWebAppState
return $ WebApp
{ threadState = st
{ threadState = Just st
, daemonStatus = dstatus
, transferQueue = transferqueue
, secretToken = pack token

View file

@ -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

View file

@ -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

View file

@ -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