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
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue