better liftAnnex, avoid using runAnnex undefined

Assistant/Threads/PairListener.hs

@@ -11,7 +11,7 @@ import Assistant.Common
 import Assistant.Pairing
 import Assistant.Pairing.Network
 import Assistant.Pairing.MakeRemote
-import Assistant.WebApp
+import Assistant.WebApp (UrlRenderer, renderUrl)
 import Assistant.WebApp.Types
 import Assistant.Alert
 import Assistant.DaemonStatus

Assistant/WebApp.hs

@@ -10,7 +10,8 @@
 module Assistant.WebApp where
 
 import Assistant.WebApp.Types
-import Assistant.Common
+import Assistant.Common hiding (liftAnnex)
+import qualified Assistant.Monad as Assistant
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 
@@ -25,9 +26,6 @@ inFirstRun = isNothing . relDir <$> getYesod
 newWebAppState :: IO (TMVar WebAppState)
 newWebAppState = atomically $ newTMVar $ WebAppState { showIntro = True }
 
-liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a
-liftAssistant a = liftIO . flip runAssistant a =<< assistantData <$> getYesod
-
 getWebAppState :: forall sub. GHandler sub WebApp WebAppState
 getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
 
@@ -43,12 +41,18 @@ modifyWebAppState a = go =<< webAppState <$> getYesod
  - 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
+liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a
-runAnnex fallback a = ifM (noAnnex <$> getYesod)
+liftAnnexOr fallback a = ifM (noAnnex <$> getYesod)
 	( return fallback
-	, liftAssistant $ liftAnnex a
+	, liftAssistant $ Assistant.liftAnnex a
 	)
 
+liftAnnex :: forall sub a. Annex a -> GHandler sub WebApp a
+liftAnnex = liftAnnexOr $ error "internal runAnnex"
+
+liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a
+liftAssistant a = liftIO . flip runAssistant a =<< assistantData <$> getYesod
+
 waitNotifier :: forall sub. (Assistant NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
 waitNotifier getbroadcaster nid = liftAssistant $ do
 	b <- getbroadcaster

Assistant/WebApp/Common.hs

@@ -7,7 +7,7 @@
 
 module Assistant.WebApp.Common (module X) where
 
-import Assistant.Common as X
+import Assistant.Common as X hiding (liftAnnex)
 import Assistant.WebApp as X
 import Assistant.WebApp.Page as X
 import Assistant.WebApp.Form as X

Assistant/WebApp/Configurators.hs

@@ -33,7 +33,7 @@ getConfigurationR = ifM (inFirstRun)
 	( getFirstRepositoryR
 	, page "Configuration" (Just Configuration) $ do
 #ifdef WITH_XMPP
-		xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds
+		xmppconfigured <- lift $ liftAnnex $ isJust <$> getXMPPCreds
 #else
 		let xmppconfigured = False
 #endif
@@ -136,7 +136,7 @@ repoList reposelector
 	configured = do
 		rs <- filter wantedrepo . syncRemotes
 			<$> liftAssistant getDaemonStatus
-		runAnnex [] $ do
+		liftAnnex $ do
 			let us = map Remote.uuid rs
 			let l = zip us $ map mkSyncingRepoActions us
 			if includeHere reposelector
@@ -149,7 +149,7 @@ repoList reposelector
 					let here = (u, hereactions)
 					return $ here : l
 				else return l
-	rest = runAnnex [] $ do
+	rest = liftAnnex $ do
 		m <- readRemoteLog
 		unconfigured <- map snd . catMaybes . filter wantedremote 
 			. map (findinfo m)
@@ -181,7 +181,7 @@ repoList reposelector
 			_ -> Nothing
 	  where
 		val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
-	list l = runAnnex [] $ do
+	list l = liftAnnex $ do
 		let l' = nubBy (\x y -> fst x == fst y) l
 		zip3
 			<$> pure counter
@@ -197,6 +197,6 @@ getDisableSyncR = flipSync False
 
 flipSync :: Bool -> UUID -> Handler ()
 flipSync enable uuid = do
-	mremote <- runAnnex undefined $ Remote.remoteFromUUID uuid
+	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
 	changeSyncable mremote enable
 	redirect RepositoriesR

Assistant/WebApp/Configurators/AWS.hs

@@ -123,7 +123,7 @@ getAddS3R = awsConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/adds3")
   where
-	setgroup r = runAnnex () $
+	setgroup r = liftAnnex $
 		setStandardGroup (Remote.uuid r) TransferGroup
 #else
 getAddS3R = error "S3 not supported by this build"
@@ -143,7 +143,7 @@ getAddGlacierR = glacierConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/addglacier")
   where
-	setgroup r = runAnnex () $
+	setgroup r = liftAnnex $
 		setStandardGroup (Remote.uuid r) SmallArchiveGroup
 
 getEnableS3R :: UUID -> Handler RepHtml
@@ -162,20 +162,20 @@ enableAWSRemote remotetype uuid = do
 		runFormGet $ renderBootstrap awsCredsAForm
 	case result of
 		FormSuccess creds -> lift $ do
-			m <- runAnnex M.empty readRemoteLog
+			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
 			makeAWSRemote remotetype creds name (const noop) M.empty
 		_ -> do
-			description <- lift $ runAnnex "" $
+			description <- lift $ liftAnnex $
 				T.pack . concat <$> Remote.prettyListUUIDs [uuid]
 			$(widgetFile "configurators/enableaws")
 
 makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
 makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
-	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
+	remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
-	r <- liftAssistant $ liftAnnex $ addRemote $ do
+	r <- liftAnnex $ addRemote $ do
 		makeSpecialRemote hostname remotetype config
 		return remotename
 	setup r

Assistant/WebApp/Configurators/Edit.hs

@@ -60,17 +60,17 @@ getRepoConfig uuid mremote = RepoConfig
 
 setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
 setRepoConfig uuid mremote oldc newc = do
-	when (repoDescription oldc /= repoDescription newc) $ runAnnex undefined $ do
+	when (repoDescription oldc /= repoDescription newc) $ liftAnnex $ do
 		maybe noop (describeUUID uuid . T.unpack) (repoDescription newc)
 		void uuidMapLoad
-	when (repoGroup oldc /= repoGroup newc) $ runAnnex undefined $ 
+	when (repoGroup oldc /= repoGroup newc) $ liftAnnex $ 
 		case repoGroup newc of
 			RepoGroupStandard g -> setStandardGroup uuid g
 			RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
 	when (repoSyncable oldc /= repoSyncable newc) $
 		changeSyncable mremote (repoSyncable newc)
 	when (isJust mremote && makeLegalName (T.unpack $ repoName oldc) /= makeLegalName (T.unpack $ repoName newc)) $ do
-		runAnnex undefined $ do
+		liftAnnex $ do
 			name <- fromRepo $ uniqueRemoteName (T.unpack $ repoName newc) 0
 			{- git remote rename expects there to be a
 			 - remote.<name>.fetch, and exits nonzero if
@@ -119,8 +119,8 @@ getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
 
 editForm :: Bool -> UUID -> Handler RepHtml
 editForm new uuid = page "Configure repository" (Just Configuration) $ do
-	mremote <- lift $ runAnnex undefined $ Remote.remoteFromUUID uuid
+	mremote <- lift $ liftAnnex $ Remote.remoteFromUUID uuid
-	curr <- lift $ runAnnex undefined $ getRepoConfig uuid mremote
+	curr <- lift $ liftAnnex $ getRepoConfig uuid mremote
 	lift $ checkarchivedirectory curr
 	((result, form), enctype) <- lift $
 		runFormGet $ renderBootstrap $ editRepositoryAForm curr
@@ -145,6 +145,6 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
 		| repoGroup cfg == RepoGroupStandard FullArchiveGroup = go
 		| otherwise = noop
 	  where
-		go = runAnnex undefined $ inRepo $ \g ->
+		go = liftAnnex $ inRepo $ \g ->
 			createDirectoryIfMissing True $
 				Git.repoPath g </> "archive"

Assistant/WebApp/Configurators/Local.hs

@@ -153,7 +153,7 @@ getNewRepositoryR = page "Add another repository" (Just Configuration) $ do
 			let path = T.unpack p
 			liftIO $ makeRepo path False
 			u <- liftIO $ initRepo True path Nothing
-			lift $ runAnnex () $ setStandardGroup u ClientGroup
+			lift $ liftAnnexOr () $ setStandardGroup u ClientGroup
 			liftIO $ addAutoStartFile path
 			liftIO $ startAssistant path
 			askcombine u path
@@ -211,7 +211,7 @@ getAddDriveR = page "Add a removable drive" (Just Configuration) $ do
 		liftIO $ makerepo dir
 		u <- liftIO $ initRepo False dir $ Just remotename
 		r <- combineRepos dir remotename
-		runAnnex () $ setStandardGroup u TransferGroup
+		liftAnnex $ setStandardGroup u TransferGroup
 		syncRemote r
 		return u
 	  where
@@ -230,7 +230,7 @@ getAddDriveR = page "Add a removable drive" (Just Configuration) $ do
 {- Each repository is made a remote of the other.
  - Next call syncRemote to get them in sync. -}
 combineRepos :: FilePath -> String -> Handler Remote
-combineRepos dir name = runAnnex undefined $ do
+combineRepos dir name = liftAnnex $ do
 	hostname <- maybe "host" id <$> liftIO getHostname
 	hostlocation <- fromRepo Git.repoLocation
 	liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
@@ -238,7 +238,7 @@ combineRepos dir name = runAnnex undefined $ do
 
 getEnableDirectoryR :: UUID -> Handler RepHtml
 getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
-	description <- lift $ runAnnex "" $
+	description <- lift $ liftAnnex $
 		T.pack . concat <$> prettyListUUIDs [uuid]
 	$(widgetFile "configurators/enabledirectory")
 

Assistant/WebApp/Configurators/Pairing.hs

@@ -51,7 +51,7 @@ import qualified Data.Set as S
 
 getStartXMPPPairR :: Handler RepHtml
 #ifdef WITH_XMPP
-getStartXMPPPairR = ifM (isJust <$> runAnnex Nothing getXMPPCreds)
+getStartXMPPPairR = ifM (isJust <$> liftAnnex getXMPPCreds)
 	( do
 		{- Ask buddies to send presence info, to get
 		 - the buddy list populated. -}
@@ -76,13 +76,12 @@ getRunningXMPPPairR bid = do
 	go $ S.toList . buddyAssistants <$> buddy
   where
 	go (Just (clients@((Client exemplar):_))) = do
-		creds <- runAnnex Nothing getXMPPCreds
+		creds <- liftAnnex getXMPPCreds
 		let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
 		let samejid = baseJID ourjid == baseJID exemplar
-		liftAssistant $ do
+		u <- liftAnnex getUUID
-			u <- liftAnnex getUUID
+		liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $
-			forM_ clients $ \(Client c) -> sendNetMessage $
+			PairingNotification PairReq (formatJID c) u
-				PairingNotification PairReq (formatJID c) u
 		xmppPairEnd True $ if samejid then Nothing else Just exemplar
 	-- A buddy could have logged out, or the XMPP client restarted,
 	-- and there be no clients to message; handle unforseen by going back.
@@ -109,7 +108,7 @@ noLocalPairing = noPairing "local"
 getFinishLocalPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	repodir <- lift $ repoPath <$> runAnnex undefined gitRepo
+	repodir <- lift $ repoPath <$> liftAnnex gitRepo
 	liftIO $ setup repodir
 	startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
   where
@@ -138,8 +137,8 @@ getFinishXMPPPairR :: PairKey -> Handler RepHtml
 getFinishXMPPPairR (PairKey theiruuid t) = case parseJID t of
 	Nothing -> error "bad JID"
 	Just theirjid -> do
+		selfuuid <- liftAnnex getUUID
 		liftAssistant $ do
-			selfuuid <- liftAnnex getUUID
 			sendNetMessage $
 				PairingNotification PairAck (formatJID theirjid) selfuuid
 			finishXMPPPairing theirjid theiruuid

Assistant/WebApp/Configurators/Preferences.hs

@@ -84,11 +84,11 @@ storePrefs p = do
 getPreferencesR :: Handler RepHtml
 getPreferencesR = page "Preferences" (Just Configuration) $ do
 	((result, form), enctype) <- lift $ do
-		current <- runAnnex undefined getPrefs
+		current <- liftAnnex getPrefs
 		runFormGet $ renderBootstrap $ prefsAForm current
 	case result of
 		FormSuccess new -> lift $ do
-			runAnnex undefined $ storePrefs new
+			liftAnnex $ storePrefs new
 			redirect ConfigurationR
 		_ -> $(widgetFile "configurators/preferences")
 

Assistant/WebApp/Configurators/Ssh.hs

@@ -114,7 +114,7 @@ getAddSshR = sshConfigurator $ do
  -}
 getEnableRsyncR :: UUID -> Handler RepHtml
 getEnableRsyncR u = do
-	m <- fromMaybe M.empty . M.lookup u <$> runAnnex M.empty readRemoteLog
+	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
 	case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
 		(Just sshinput, Just reponame) -> sshConfigurator $ do
 			((result, form), enctype) <- lift $
@@ -133,7 +133,7 @@ getEnableRsyncR u = do
 		_ -> redirect AddSshR
   where
 	showform form enctype status = do
-		description <- lift $ runAnnex "" $
+		description <- lift $ liftAnnex $
 			T.pack . concat <$> prettyListUUIDs [u]
 		$(widgetFile "configurators/ssh/enable")
 	enable sshdata = lift $ redirect $ ConfirmSshR $
@@ -350,4 +350,4 @@ isRsyncNet Nothing = False
 isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
 
 setupGroup :: Remote -> Handler ()
-setupGroup r = runAnnex () $ setStandardGroup (Remote.uuid r) TransferGroup
+setupGroup r = liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup

Assistant/WebApp/Configurators/WebDAV.hs

@@ -77,7 +77,7 @@ getAddBoxComR = boxConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/addbox.com")
   where
-	setgroup r = runAnnex () $
+	setgroup r = liftAnnex $
 		setStandardGroup (Remote.uuid r) TransferGroup
 #else
 getAddBoxComR = error "WebDAV not supported by this build"
@@ -86,11 +86,11 @@ getAddBoxComR = error "WebDAV not supported by this build"
 getEnableWebDAVR :: UUID -> Handler RepHtml
 #ifdef WITH_WEBDAV
 getEnableWebDAVR uuid = do
-	m <- runAnnex M.empty readRemoteLog
+	m <- liftAnnex readRemoteLog
 	let c = fromJust $ M.lookup uuid m
 	let name = fromJust $ M.lookup "name" c
 	let url = fromJust $ M.lookup "url" c
-	mcreds <- runAnnex Nothing $
+	mcreds <- liftAnnex $
 		getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
 	case mcreds of
 		Just creds -> webDAVConfigurator $ lift $
@@ -108,7 +108,7 @@ getEnableWebDAVR uuid = do
 			FormSuccess input -> lift $
 				makeWebDavRemote name (toCredPair input) (const noop) M.empty
 			_ -> do
-				description <- lift $ runAnnex "" $
+				description <- lift $ liftAnnex $
 					T.pack . concat <$> Remote.prettyListUUIDs [uuid]
 				$(widgetFile "configurators/enablewebdav")
 #else
@@ -118,9 +118,9 @@ getEnableWebDAVR _ = error "WebDAV not supported by this build"
 #ifdef WITH_WEBDAV
 makeWebDavRemote :: String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
 makeWebDavRemote name creds setup config = do
-	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
+	remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ WebDAV.setCredsEnv creds
-	r <- liftAssistant $ liftAnnex $ addRemote $ do
+	r <- liftAnnex $ addRemote $ do
 		makeSpecialRemote name WebDAV.remote config
 		return remotename
 	setup r

Assistant/WebApp/Configurators/XMPP.hs

@@ -33,7 +33,7 @@ import Control.Exception (SomeException)
 {- Displays an alert suggesting to configure XMPP, with a button. -}
 xmppNeeded :: Handler ()
 #ifdef WITH_XMPP
-xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
+xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
 	urlrender <- getUrlRender
 	void $ liftAssistant $ do
 		close <- asIO1 removeAlert
@@ -50,7 +50,7 @@ xmppNeeded = return ()
 getXMPPR :: Handler RepHtml
 getXMPPR = xmppPage $ do
 	((result, form), enctype) <- lift $ do
-		oldcreds <- runAnnex Nothing getXMPPCreds
+		oldcreds <- liftAnnex getXMPPCreds
 		runFormGet $ renderBootstrap $ xmppAForm $
 			creds2Form <$> oldcreds
 	let showform problem = $(widgetFile "configurators/xmpp")
@@ -60,7 +60,7 @@ getXMPPR = xmppPage $ do
 		_ -> showform Nothing
   where
 	storecreds creds = do
-		void $ runAnnex undefined $ setXMPPCreds creds
+		void $ liftAnnex $ setXMPPCreds creds
 		liftAssistant notifyNetMessagerRestart
 		redirect StartXMPPPairR
 #else

Assistant/WebApp/Control.hs

@@ -52,7 +52,7 @@ getRestartThreadR name = do
 
 getLogR :: Handler RepHtml
 getLogR = page "Logs" Nothing $ do
-	logfile <- lift $ runAnnex undefined $ fromRepo gitAnnexLogFile
+	logfile <- lift $ liftAnnex $ fromRepo gitAnnexLogFile
 	logs <- liftIO $ listLogs logfile
 	logcontent <- liftIO $ concat <$> mapM readFile logs
 	$(widgetFile "control/log")

Assistant/WebApp/DashBoard.hs

@@ -117,8 +117,7 @@ getFileBrowserR = whenM openFileBrowser $ redirectBack
  - blocking the response to the browser on it. -}
 openFileBrowser :: Handler Bool
 openFileBrowser = do
-	path <- runAnnex (error "no configured repository") $
+	path <- liftAnnex $ fromRepo Git.repoPath
-		fromRepo Git.repoPath
 	ifM (liftIO $ inPath cmd <&&> inPath cmd)
 		( do
 			void $ liftIO $ forkIO $ void $

Assistant/WebApp/Utility.hs

@@ -7,7 +7,7 @@
 
 module Assistant.WebApp.Utility where
 
-import Assistant.Common
+import Assistant.Common hiding (liftAnnex)
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.DaemonStatus
@@ -34,10 +34,10 @@ import System.Posix.Process (getProcessGroupIDOf)
 {- Use Nothing to change autocommit setting; or a remote to change
  - its sync setting. -}
 changeSyncable :: (Maybe Remote) -> Bool -> Handler ()
-changeSyncable Nothing enable = liftAssistant $ do
+changeSyncable Nothing enable = do
 	liftAnnex $ Config.setConfig key (boolConfig enable)
 	liftIO . maybe noop (`throwTo` signal)
-		=<< namedThreadId watchThread
+		=<< liftAssistant (namedThreadId watchThread)
   where
 	key = Config.annexConfig "autocommit"
 	signal
@@ -59,7 +59,7 @@ changeSyncable (Just r) False = do
 	tofrom t = transferUUID t == Remote.uuid r
 
 changeSyncFlag :: Remote -> Bool -> Handler ()
-changeSyncFlag r enabled = runAnnex undefined $ do
+changeSyncFlag r enabled = liftAnnex $ do
 	Config.setConfig key (boolConfig enabled)
 	void $ Remote.remoteListRefresh
   where