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

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