tweak types so the webapp can run without a threadstate when outside an annex
This commit is contained in:
parent
e9d9d9d5ea
commit
b9b0097876
4 changed files with 14 additions and 6 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue