From c94c99942b09ae294fb92d27fa12e990bdb37e52 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 16 Mar 2013 00:12:28 -0400 Subject: [PATCH] make liftAnnex and liftAssistant polymorphic, like liftIO --- Assistant/Monad.hs | 14 +++++++--- Assistant/Threads/XMPPClient.hs | 2 +- Assistant/WebApp.hs | 34 +++++------------------ Assistant/WebApp/Common.hs | 2 +- Assistant/WebApp/Configurators.hs | 2 +- Assistant/WebApp/Configurators/AWS.hs | 4 +-- Assistant/WebApp/Configurators/Edit.hs | 4 +-- Assistant/WebApp/Configurators/Local.hs | 2 +- Assistant/WebApp/Configurators/Pairing.hs | 4 +-- Assistant/WebApp/Configurators/Ssh.hs | 2 +- Assistant/WebApp/Configurators/WebDAV.hs | 2 +- Assistant/WebApp/Configurators/XMPP.hs | 6 ++-- Assistant/WebApp/Control.hs | 2 +- Assistant/WebApp/DashBoard.hs | 2 +- Assistant/WebApp/Page.hs | 3 ++ Assistant/WebApp/Types.hs | 28 +++++++++++++++++++ Assistant/WebApp/Utility.hs | 3 +- 17 files changed, 66 insertions(+), 50 deletions(-) diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 140b9f582e..e046c96669 100644 --- a/Assistant/Monad.hs +++ b/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 -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 diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 69a886c4af..66c6e72278 100644 --- a/Assistant/Threads/XMPPClient.hs +++ 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 diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 81dace34e4..12028a9df7 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -1,17 +1,17 @@ {- git-annex assistant webapp core - - - Copyright 2012 Joey Hess + - Copyright 2012, 2013 Joey Hess - - 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") diff --git a/Assistant/WebApp/Common.hs b/Assistant/WebApp/Common.hs index 0c6bcdd11b..dfde4c492f 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 hiding (liftAnnex) +import Assistant.Common as X 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 17e50e0b86..516c3cc1dc 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index b70e70c940..a932bb84b4 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/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") diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 95a9106c40..617dbc41fb 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/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 - 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 diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 576f171ba8..9084fec64e 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/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") diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index d9aacab8a5..77099df30c 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index b168c6be0d..f79ad7f0a7 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/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 $ diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 1afa1f5212..e54a754d64 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index 0a136a2e4a..e00f2dc1f2 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/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) diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs index e18c9890ef..6c480be5ab 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 $ liftAnnex $ fromRepo gitAnnexLogFile + logfile <- 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 6b375f0d08..9b21e23854 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/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") diff --git a/Assistant/WebApp/Page.hs b/Assistant/WebApp/Page.hs index 875f3ec7b1..91bdea0805 100644 --- a/Assistant/WebApp/Page.hs +++ b/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") diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index 496a30c714..f5454466e5 100644 --- a/Assistant/WebApp/Types.hs +++ b/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 diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index 311bbfddca..623184505b 100644 --- a/Assistant/WebApp/Utility.hs +++ b/Assistant/WebApp/Utility.hs @@ -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