add liftH shim between yesod versions, to avoid needing zillions of ifdefs

Assistant/WebApp.hs

@@ -36,7 +36,7 @@ newNotifier getbroadcaster = liftAssistant $ do
  - every form. -}
 webAppFormAuthToken :: Widget
 webAppFormAuthToken = do
-	webapp <- handlerToWidget getYesod
+	webapp <- liftH getYesod
 	[whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
 
 {- A button with an icon, and maybe label or tooltip, that can be

Assistant/WebApp/Configurators/AWS.hs

@@ -119,10 +119,10 @@ postAddS3R :: Handler RepHtml
 #ifdef WITH_S3
 postAddS3R = awsConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ s3InputAForm defcreds
 	case result of
-		FormSuccess input -> handlerToWidget $ do
+		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
 			makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
@@ -145,10 +145,10 @@ postAddGlacierR :: Handler RepHtml
 #ifdef WITH_S3
 postAddGlacierR = glacierConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ glacierInputAForm defcreds
 	case result of
-		FormSuccess input -> handlerToWidget $ do
+		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
 			makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
@@ -191,10 +191,10 @@ enableAWSRemote :: RemoteType -> UUID -> Widget
 #ifdef WITH_S3
 enableAWSRemote remotetype uuid = do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ awsCredsAForm defcreds
 	case result of
-		FormSuccess creds -> handlerToWidget $ do
+		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m

Assistant/WebApp/Configurators/Delete.hs

@@ -72,14 +72,14 @@ postDeleteCurrentRepositoryR = deleteCurrentRepository
 
 deleteCurrentRepository :: Handler RepHtml
 deleteCurrentRepository = dangerPage $ do
-	reldir <- fromJust . relDir <$> handlerToWidget getYesod
+	reldir <- fromJust . relDir <$> liftH getYesod
 	havegitremotes <- haveremotes syncGitRemotes
 	havedataremotes <- haveremotes syncDataRemotes
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ sanityVerifierAForm $
 			SanityVerifier magicphrase
 	case result of
-		FormSuccess _ -> handlerToWidget $ do
+		FormSuccess _ -> liftH $ do
 			dir <- liftAnnex $ fromRepo Git.repoPath
 			liftIO $ removeAutoStartFile dir
 

Assistant/WebApp/Configurators/Edit.hs

@@ -177,10 +177,10 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
 	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
 	curr <- liftAnnex $ getRepoConfig uuid mremote
 	liftAnnex $ checkAssociatedDirectory curr mremote
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ editRepositoryAForm curr
 	case result of
-		FormSuccess input -> handlerToWidget $ do
+		FormSuccess input -> liftH $ do
 			setRepoConfig uuid mremote curr input
 			liftAnnex $ checkAssociatedDirectory input mremote
 			redirect DashboardR

Assistant/WebApp/Configurators/IA.hs

@@ -125,10 +125,10 @@ postAddIAR :: Handler RepHtml
 #ifdef WITH_S3
 postAddIAR = iaConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedIACreds
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ iaInputAForm defcreds
 	case result of
-		FormSuccess input -> handlerToWidget $ do
+		FormSuccess input -> liftH $ do
 			let name = escapeBucket $ T.unpack $ itemName input
 			AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $
 				M.fromList $ catMaybes
@@ -167,10 +167,10 @@ postEnableIAR _ = error "S3 not supported by this build"
 enableIARemote :: UUID -> Widget
 enableIARemote uuid = do
 	defcreds <- liftAnnex previouslyUsedIACreds
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ iaCredsAForm defcreds
 	case result of
-		FormSuccess creds -> handlerToWidget $ do
+		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m

Assistant/WebApp/Configurators/Local.hs

@@ -142,11 +142,11 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
 	let path = "/sdcard/annex"
 #else
 	let androidspecial = False
-	path <- liftIO . defaultRepositoryPath =<< handlerToWidget inFirstRun
+	path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun
 #endif
-	((res, form), enctype) <- handlerToWidget $ runFormPost $ newRepositoryForm path
+	((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm path
 	case res of
-		FormSuccess (RepositoryPath p) -> handlerToWidget $
+		FormSuccess (RepositoryPath p) -> liftH $
 			startFullAssistant (T.unpack p) ClientGroup
 		_ -> $(widgetFile "configurators/newrepository/first")
 
@@ -160,13 +160,13 @@ getNewRepositoryR = postNewRepositoryR
 postNewRepositoryR :: Handler RepHtml
 postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
 	home <- liftIO myHomeDir
-	((res, form), enctype) <- handlerToWidget $ runFormPost $ newRepositoryForm home
+	((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home
 	case res of
 		FormSuccess (RepositoryPath p) -> do
 			let path = T.unpack p
 			isnew <- liftIO $ makeRepo path False
 			u <- liftIO $ initRepo isnew True path Nothing
-			handlerToWidget $ liftAnnexOr () $ setStandardGroup u ClientGroup
+			liftH $ liftAnnexOr () $ setStandardGroup u ClientGroup
 			liftIO $ addAutoStartFile path
 			liftIO $ startAssistant path
 			askcombine u path
@@ -174,7 +174,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
   where
 	askcombine newrepouuid newrepopath = do
 		newrepo <- liftIO $ relHome newrepopath
-		mainrepo <- fromJust . relDir <$> handlerToWidget getYesod
+		mainrepo <- fromJust . relDir <$> liftH getYesod
 		$(widgetFile "configurators/newrepository/combine")
 
 getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml
@@ -215,10 +215,10 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
 	removabledrives <- liftIO $ driveList
 	writabledrives <- liftIO $
 		filterM (canWrite . T.unpack . mountPoint) removabledrives
-	((res, form), enctype) <- handlerToWidget $ runFormPost $
+	((res, form), enctype) <- liftH $ runFormPost $
 		selectDriveForm (sort writabledrives)
 	case res of
-		FormSuccess drive -> handlerToWidget $ redirect $ ConfirmAddDriveR drive
+		FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive
 		_ -> $(widgetFile "configurators/adddrive")
 
 {- The repo may already exist, when adding removable media

Assistant/WebApp/Configurators/Pairing.hs

@@ -146,7 +146,7 @@ getFinishLocalPairR = postFinishLocalPairR
 postFinishLocalPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	repodir <- handlerToWidget $ repoPath <$> liftAnnex gitRepo
+	repodir <- liftH $ repoPath <$> liftAnnex gitRepo
 	liftIO $ setup repodir
 	startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
   where
@@ -216,8 +216,8 @@ getRunningLocalPairR _ = noLocalPairing
  -}
 startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
 startLocalPairing stage oncancel alert muuid displaysecret secret = do
-	urlrender <- handlerToWidget getUrlRender
-	reldir <- fromJust . relDir <$> handlerToWidget getYesod
+	urlrender <- liftH getUrlRender
+	reldir <- fromJust . relDir <$> liftH getYesod
 
 	sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender
 	{- Generating a ssh key pair can take a while, so do it in the
@@ -235,7 +235,7 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do
 		startSending pip stage $ sendrequests sender
 	void $ liftIO $ forkIO thread
 
-	handlerToWidget $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
+	liftH $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
   where
 	{- Sends pairing messages until the thread is killed,
 	 - and shows an activity alert while doing it.
@@ -264,7 +264,7 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
  - that can validate it. -}
 promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
 promptSecret msg cont = pairPage $ do
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $
 			InputSecret <$> aopt textField "Secret phrase" Nothing
 	case result of

Assistant/WebApp/Configurators/Preferences.hs

@@ -86,11 +86,11 @@ getPreferencesR :: Handler RepHtml
 getPreferencesR = postPreferencesR
 postPreferencesR :: Handler RepHtml
 postPreferencesR = page "Preferences" (Just Configuration) $ do
-	((result, form), enctype) <- handlerToWidget $ do
+	((result, form), enctype) <- liftH $ do
 		current <- liftAnnex getPrefs
 		runFormPost $ renderBootstrap $ prefsAForm current
 	case result of
-		FormSuccess new -> handlerToWidget $ do
+		FormSuccess new -> liftH $ do
 			liftAnnex $ storePrefs new
 			redirect ConfigurationR
 		_ -> $(widgetFile "configurators/preferences")

Assistant/WebApp/Configurators/Ssh.hs

@@ -107,7 +107,7 @@ getAddSshR = postAddSshR
 postAddSshR :: Handler RepHtml
 postAddSshR = sshConfigurator $ do
 	u <- liftIO $ T.pack <$> myUserName
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ sshInputAForm textField $
 			SshInput Nothing (Just u) Nothing 22
 	case result of
@@ -115,7 +115,7 @@ postAddSshR = sshConfigurator $ do
 			s <- liftIO $ testServer sshinput
 			case s of
 				Left status -> showform form enctype status
-				Right sshdata -> handlerToWidget $ redirect $ ConfirmSshR sshdata
+				Right sshdata -> liftH $ redirect $ ConfirmSshR sshdata
 		_ -> showform form enctype UntestedServer
   where
 	showform form enctype status = $(widgetFile "configurators/ssh/add")
@@ -138,12 +138,12 @@ postEnableRsyncR u = do
 	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) <- handlerToWidget $
+			((result, form), enctype) <- liftH $
 				runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (inputHostname sshinput') ->
-						void $ handlerToWidget $ makeRsyncNet sshinput' reponame (const noop)
+						void $ liftH $ makeRsyncNet sshinput' reponame (const noop)
 					| otherwise -> do
 						s <- liftIO $ testServer sshinput'
 						case s of
@@ -156,7 +156,7 @@ postEnableRsyncR u = do
 	showform form enctype status = do
 		description <- liftAnnex $ T.pack <$> prettyUUID u
 		$(widgetFile "configurators/ssh/enable")
-	enable sshdata = handlerToWidget $ redirect $ ConfirmSshR $
+	enable sshdata = liftH $ redirect $ ConfirmSshR $
 		sshdata { rsyncOnly = True }
 
 {- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync

Assistant/WebApp/Configurators/WebDAV.hs

@@ -65,10 +65,10 @@ postAddBoxComR :: Handler RepHtml
 #ifdef WITH_WEBDAV
 postAddBoxComR = boxConfigurator $ do
 	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
-	((result, form), enctype) <- handlerToWidget $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ boxComAForm defcreds
 	case result of
-		FormSuccess input -> handlerToWidget $ 
+		FormSuccess input -> liftH $ 
 			makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("embedcreds", if embedCreds input then "yes" else "no")
@@ -99,7 +99,7 @@ postEnableWebDAVR uuid = do
 	mcreds <- liftAnnex $
 		getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
 	case mcreds of
-		Just creds -> webDAVConfigurator $ handlerToWidget $
+		Just creds -> webDAVConfigurator $ liftH $
 			makeWebDavRemote name creds (const noop) M.empty
 		Nothing
 			| "box.com/" `isInfixOf` url ->
@@ -111,10 +111,10 @@ postEnableWebDAVR uuid = do
 		defcreds <- liftAnnex $ 
 			maybe (pure Nothing) previouslyUsedWebDAVCreds $
 				urlHost url
-		((result, form), enctype) <- handlerToWidget $
+		((result, form), enctype) <- liftH $
 			runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
 		case result of
-			FormSuccess input -> handlerToWidget $
+			FormSuccess input -> liftH $
 				makeWebDavRemote name (toCredPair input) (const noop) M.empty
 			_ -> do
 				description <- liftAnnex $

Assistant/WebApp/Configurators/XMPP.hs

@@ -110,13 +110,13 @@ postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
 xmppform :: Route WebApp -> Handler RepHtml
 #ifdef WITH_XMPP
 xmppform next = xmppPage $ do
-	((result, form), enctype) <- handlerToWidget $ do
+	((result, form), enctype) <- liftH $ do
 		oldcreds <- liftAnnex getXMPPCreds
 		runFormPost $ renderBootstrap $ xmppAForm $
 			creds2Form <$> oldcreds
 	let showform problem = $(widgetFile "configurators/xmpp")
 	case result of
-		FormSuccess f -> either (showform . Just) (handlerToWidget . storecreds)
+		FormSuccess f -> either (showform . Just) (liftH . storecreds)
 			=<< liftIO (validateForm f)
 		_ -> showform Nothing
   where

Assistant/WebApp/DashBoard.hs

@@ -30,8 +30,8 @@ import Control.Concurrent
 {- A display of currently running and queued transfers. -}
 transfersDisplay :: Bool -> Widget
 transfersDisplay warnNoScript = do
-	webapp <- handlerToWidget getYesod
-	current <- handlerToWidget $ M.toList <$> getCurrentTransfers
+	webapp <- liftH getYesod
+	current <- liftH $ M.toList <$> getCurrentTransfers
 	queued <- take 10 <$> liftAssistant getTransferQueue
 	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
 	let transfers = simplifyTransfers $ current ++ queued

Assistant/WebApp/RepoList.hs

@@ -110,7 +110,7 @@ repoListDisplay reposelector = do
 	addScript $ StaticR jquery_ui_mouse_js
 	addScript $ StaticR jquery_ui_sortable_js
 
-	repolist <- handlerToWidget $ repoList reposelector
+	repolist <- liftH $ repoList reposelector
 	let addmore = nudgeAddMore reposelector
 	let nootherrepos = length repolist < 2
 

Assistant/WebApp/SideBar.hs

@@ -28,7 +28,7 @@ sideBarDisplay :: Widget
 sideBarDisplay = do
 	let content = do
 		{- Add newest alerts to the sidebar. -}
-		alertpairs <- handlerToWidget $ M.toList . alertMap
+		alertpairs <- liftH $ M.toList . alertMap
 			<$> liftAssistant getDaemonStatus
 		mapM_ renderalert $
 			take displayAlerts $ reverse $ sortAlertPairs alertpairs

Assistant/WebApp/Types.hs

@@ -91,7 +91,7 @@ instance LiftAnnex Handler where
 	liftAnnex = liftAnnexOr $ error "internal liftAnnex"
 
 instance LiftAnnex (WidgetT WebApp IO) where
-	liftAnnex = handlerToWidget . liftAnnex
+	liftAnnex = liftH . liftAnnex
 
 class LiftAssistant m where
 	liftAssistant :: Assistant a -> m a
@@ -101,7 +101,7 @@ instance LiftAssistant Handler where
 		=<< assistantData <$> getYesod
 
 instance LiftAssistant (WidgetT WebApp IO) where
-	liftAssistant = handlerToWidget . liftAssistant
+	liftAssistant = liftH . liftAssistant
 
 type Form x = MForm Handler (FormResult x, Widget)
 

Utility/Yesod.hs

@@ -1,11 +1,14 @@
 {- Yesod stuff, that's typically found in the scaffolded site.
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Also a bit of a compatability layer to make it easier to support yesod
+ - 1.1 and 1.2 in the same code base.
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, RankNTypes #-}
 
 module Utility.Yesod where
 
@@ -16,6 +19,9 @@ import Language.Haskell.TH.Syntax
 import Data.Default (def)
 import Text.Hamlet
 #endif
+#if MIN_VERSION_yesod_default(1,2,0)
+import Yesod.Core
+#endif
 
 widgetFile :: String -> Q Exp
 #if ! MIN_VERSION_yesod_default(1,1,0)
@@ -31,3 +37,12 @@ widgetFile = widgetFileNoReload $ def
 hamletTemplate :: FilePath -> FilePath
 hamletTemplate f = globFile "hamlet" f
 #endif
+
+{- Lift Handler to Widget -}
+#if ! MIN_VERSION_yesod(1,2,0)
+liftH :: forall t. Lift t => t -> Q Exp
+liftH = lift
+#else
+liftH :: Monad m => HandlerT site m a -> WidgetT site m a
+liftH = liftH
+#endif