better liftAnnex, avoid using runAnnex undefined

This commit is contained in:
Joey Hess 2013-03-04 16:36:38 -04:00
parent 5274713305
commit 907b0c0d78
15 changed files with 61 additions and 59 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
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"

View file

@ -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")

View file

@ -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

View file

@ -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")

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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")

View file

@ -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 $

View file

@ -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