diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index b7e3ce66d1..4459ee13cf 100644 --- a/Assistant/Threads/PairListener.hs +++ b/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 diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index f5225b5902..0e5dc6d535 100644 --- a/Assistant/WebApp.hs +++ b/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 -runAnnex fallback a = ifM (noAnnex <$> getYesod) +liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a +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 diff --git a/Assistant/WebApp/Common.hs b/Assistant/WebApp/Common.hs index dfde4c492f..0c6bcdd11b 100644 --- a/Assistant/WebApp/Common.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index f2e77791a6..21289206cc 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index 49ae1347a0..b70e70c940 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 6e62bc2709..32e5158ed2 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/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..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 - curr <- lift $ runAnnex undefined $ getRepoConfig uuid mremote + mremote <- lift $ liftAnnex $ Remote.remoteFromUUID uuid + 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" diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index fd427467ec..d222331055 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/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") diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index a98cf315cf..db2bb429af 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/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 - forM_ clients $ \(Client c) -> sendNetMessage $ - PairingNotification PairReq (formatJID c) u + u <- liftAnnex getUUID + liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $ + 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 diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs index 6f51a5ce60..997d9d47bd 100644 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/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") diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 2006afc25f..7df02b3bd3 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 0e3268b2bf..1afa1f5212 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index 1226d8365a..b81a31c5a3 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/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 diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs index 81ddfd4fcd..e18c9890ef 100644 --- a/Assistant/WebApp/Control.hs +++ b/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") diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 045202174b..d71f240cce 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/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") $ - fromRepo Git.repoPath + path <- liftAnnex $ fromRepo Git.repoPath ifM (liftIO $ inPath cmd <&&> inPath cmd) ( do void $ liftIO $ forkIO $ void $ diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index 6ebca3863a..311bbfddca 100644 --- a/Assistant/WebApp/Utility.hs +++ b/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