make liftAnnex and liftAssistant polymorphic, like liftIO

This commit is contained in:
Joey Hess 2013-03-16 00:12:28 -04:00
parent d640df7378
commit c94c99942b
17 changed files with 66 additions and 50 deletions

View file

@ -13,6 +13,7 @@ module Assistant.Monad (
newAssistantData,
runAssistant,
getAssistant,
LiftAnnex,
liftAnnex,
(<~>),
(<<~),
@ -90,13 +91,18 @@ runAssistant d a = runReaderT (mkAssistant a) d
getAssistant :: (AssistantData -> a) -> Assistant a
getAssistant = reader
{- Using a type class for lifting into the annex monad allows
- easily lifting to it from multiple different monads. -}
class LiftAnnex m where
liftAnnex :: Annex a -> m a
{- Runs an action in the git-annex monad. Note that the same monad state
- is shared amoung all assistant threads, so only one of these can run at
- a time. Therefore, long-duration actions should be avoided. -}
liftAnnex :: Annex a -> Assistant a
liftAnnex a = do
st <- reader threadState
liftIO $ runThreadState st a
instance LiftAnnex Assistant where
liftAnnex a = do
st <- reader threadState
liftIO $ runThreadState st a
{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b

View file

@ -19,7 +19,7 @@ import Assistant.DaemonStatus
import qualified Remote
import Utility.ThreadScheduler
import Assistant.WebApp (UrlRenderer, renderUrl)
import Assistant.WebApp.Types
import Assistant.WebApp.Types hiding (liftAssistant)
import Assistant.Alert
import Assistant.Pairing
import Assistant.XMPP.Git

View file

@ -1,17 +1,17 @@
{- git-annex assistant webapp core
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp where
import Assistant.WebApp.Types
import Assistant.Common hiding (liftAnnex)
import qualified Assistant.Monad as Assistant
import Assistant.Common
import Utility.NotificationBroadcaster
import Utility.Yesod
@ -19,26 +19,6 @@ import Yesod
import Data.Text (Text)
import Control.Concurrent
inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod
{- Runs an Annex action from the webapp.
-
- When the webapp is run outside a git-annex repository, the fallback
- value is returned.
-}
liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a
liftAnnexOr fallback a = ifM (noAnnex <$> getYesod)
( return fallback
, 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
@ -73,6 +53,9 @@ newUrlRenderer = newEmptyMVar
setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO ()
setUrlRenderer = putMVar
inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod
{- Blocks until the webapp is running and has called setUrlRenderer. -}
renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text
renderUrl urlrenderer route params = do
@ -85,6 +68,3 @@ redirectBack = do
clearUltDest
setUltDestReferer
redirectUltDest DashboardR
controlMenu :: Widget
controlMenu = $(widgetFile "controlmenu")

View file

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

View file

@ -22,7 +22,7 @@ getConfigurationR = ifM (inFirstRun)
( getFirstRepositoryR
, page "Configuration" (Just Configuration) $ do
#ifdef WITH_XMPP
xmppconfigured <- lift $ liftAnnex $ isJust <$> getXMPPCreds
xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds
#else
let xmppconfigured = False
#endif

View file

@ -167,7 +167,7 @@ enableAWSRemote remotetype uuid = do
fromJust $ M.lookup uuid m
makeAWSRemote remotetype creds name (const noop) M.empty
_ -> do
description <- lift $ liftAnnex $
description <- liftAnnex $
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
$(widgetFile "configurators/enableaws")

View file

@ -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 $ liftAnnex $ Remote.remoteFromUUID uuid
curr <- lift $ liftAnnex $ getRepoConfig uuid mremote
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
curr <- liftAnnex $ getRepoConfig uuid mremote
lift $ checkarchivedirectory curr
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ editRepositoryAForm curr

View file

@ -227,7 +227,7 @@ combineRepos dir name = liftAnnex $ do
getEnableDirectoryR :: UUID -> Handler RepHtml
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
description <- lift $ liftAnnex $
description <- liftAnnex $
T.pack . concat <$> prettyListUUIDs [uuid]
$(widgetFile "configurators/enabledirectory")

View file

@ -214,10 +214,10 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do
urlrender <- lift getUrlRender
reldir <- fromJust . relDir <$> lift getYesod
sendrequests <- lift $ liftAssistant $ asIO2 $ mksendrequests urlrender
sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender
{- Generating a ssh key pair can take a while, so do it in the
- background. -}
thread <- lift $ liftAssistant $ asIO $ do
thread <- liftAssistant $ asIO $ do
keypair <- liftIO $ genSshKeyPair
pairdata <- liftIO $ PairData
<$> getHostname

View file

@ -133,7 +133,7 @@ getEnableRsyncR u = do
_ -> redirect AddSshR
where
showform form enctype status = do
description <- lift $ liftAnnex $
description <- liftAnnex $
T.pack . concat <$> prettyListUUIDs [u]
$(widgetFile "configurators/ssh/enable")
enable sshdata = lift $ redirect $ ConfirmSshR $

View file

@ -108,7 +108,7 @@ getEnableWebDAVR uuid = do
FormSuccess input -> lift $
makeWebDavRemote name (toCredPair input) (const noop) M.empty
_ -> do
description <- lift $ liftAnnex $
description <- liftAnnex $
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
$(widgetFile "configurators/enablewebdav")
#else

View file

@ -85,7 +85,7 @@ getBuddyName u = go =<< getclientjid
getNeedCloudRepoR :: UUID -> Handler RepHtml
#ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
buddyname <- lift $ liftAssistant $ getBuddyName for
buddyname <- liftAssistant $ getBuddyName for
$(widgetFile "configurators/xmpp/needcloudrepo")
#else
needCloudRepoR = xmppPage $
@ -129,9 +129,9 @@ buddyListDisplay :: Widget
buddyListDisplay = do
autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
#ifdef WITH_XMPP
myjid <- lift $ liftAssistant $ xmppClientID <$> getDaemonStatus
myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
let isself (BuddyKey b) = Just b == myjid
buddies <- lift $ liftAssistant $ do
buddies <- liftAssistant $ do
pairedwith <- map fst <$> getXMPPRemotes
catMaybes . map (buddySummary pairedwith)
<$> (getBuddyList <<~ buddyList)

View file

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

View file

@ -33,7 +33,7 @@ transfersDisplay :: Bool -> Widget
transfersDisplay warnNoScript = do
webapp <- lift getYesod
current <- lift $ M.toList <$> getCurrentTransfers
queued <- lift $ take 10 <$> liftAssistant getTransferQueue
queued <- take 10 <$> liftAssistant getTransferQueue
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued
$(widgetFile "dashboard/transfers")

View file

@ -65,3 +65,6 @@ customPage navbaritem content = do
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
controlMenu :: Widget
controlMenu = $(widgetFile "controlmenu")

View file

@ -7,6 +7,7 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.WebApp.Types where
@ -71,6 +72,33 @@ instance Yesod WebApp where
instance RenderMessage WebApp FormMessage where
renderMessage _ _ = defaultFormMessage
{- Runs an Annex action from the webapp.
-
- When the webapp is run outside a git-annex repository, the fallback
- value is returned.
-}
liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a
liftAnnexOr fallback a = ifM (noAnnex <$> getYesod)
( return fallback
, liftAssistant $ liftAnnex a
)
instance LiftAnnex (GHandler sub WebApp) where
liftAnnex = liftAnnexOr $ error "internal runAnnex"
instance LiftAnnex (GWidget WebApp WebApp) where
liftAnnex = lift . liftAnnex
class LiftAssistant m where
liftAssistant :: Assistant a -> m a
instance LiftAssistant (GHandler sub WebApp) where
liftAssistant a = liftIO . flip runAssistant a
=<< assistantData <$> getYesod
instance LiftAssistant (GWidget WebApp WebApp) where
liftAssistant = lift . liftAssistant
type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
data RepoSelector = RepoSelector

View file

@ -7,8 +7,7 @@
module Assistant.WebApp.Utility where
import Assistant.Common hiding (liftAnnex)
import Assistant.WebApp
import Assistant.Common
import Assistant.WebApp.Types
import Assistant.DaemonStatus
import Assistant.TransferQueue