make liftAnnex and liftAssistant polymorphic, like liftIO

Assistant/Monad.hs

@@ -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
+instance LiftAnnex Assistant where
-liftAnnex a = do
+	liftAnnex a = do
-	st <- reader threadState
+		st <- reader threadState
-	liftIO $ runThreadState st a
+		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

Assistant/Threads/XMPPClient.hs

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

Assistant/WebApp.hs

@@ -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 Assistant.Common
-import qualified Assistant.Monad as Assistant
 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")

Assistant/WebApp/Common.hs

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

Assistant/WebApp/Configurators.hs

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

Assistant/WebApp/Configurators/AWS.hs

@@ -143,7 +143,7 @@ getAddGlacierR = glacierConfigurator $ do
 				]
 		_ -> $(widgetFile "configurators/addglacier")
   where
-	setgroup r = liftAnnex $
+	setgroup r = liftAnnex $ 
 		setStandardGroup (Remote.uuid r) SmallArchiveGroup
 
 getEnableS3R :: UUID -> Handler RepHtml
@@ -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")
 

Assistant/WebApp/Configurators/Edit.hs

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

Assistant/WebApp/Configurators/Local.hs

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

Assistant/WebApp/Configurators/Pairing.hs

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

Assistant/WebApp/Configurators/Ssh.hs

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

Assistant/WebApp/Configurators/WebDAV.hs

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

Assistant/WebApp/Configurators/XMPP.hs

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

Assistant/WebApp/Control.hs

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

Assistant/WebApp/DashBoard.hs

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

Assistant/WebApp/Page.hs

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

Assistant/WebApp/Types.hs

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

Assistant/WebApp/Utility.hs

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