diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index b0beefb59f..1681e3c492 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -63,7 +63,7 @@ data AWSCreds = AWSCreds Text Text extractCreds :: AWSInput -> AWSCreds extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i) -s3InputAForm :: Maybe CredPair -> AForm Handler AWSInput +s3InputAForm :: Maybe CredPair -> MkAForm AWSInput s3InputAForm defcreds = AWSInput <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <*> secretAccessKeyField (T.pack . snd <$> defcreds) @@ -78,7 +78,7 @@ s3InputAForm defcreds = AWSInput , ("Reduced redundancy (costs less)", ReducedRedundancy) ] -glacierInputAForm :: Maybe CredPair -> AForm Handler AWSInput +glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput glacierInputAForm defcreds = AWSInput <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <*> secretAccessKeyField (T.pack . snd <$> defcreds) @@ -87,15 +87,15 @@ glacierInputAForm defcreds = AWSInput <*> areq textField "Repository name" (Just "glacier") <*> enableEncryptionField -awsCredsAForm :: Maybe CredPair -> AForm Handler AWSCreds +awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds awsCredsAForm defcreds = AWSCreds <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <*> secretAccessKeyField (T.pack . snd <$> defcreds) -accessKeyIDField :: Widget -> Maybe Text -> AForm Handler Text +accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def -accessKeyIDFieldWithHelp :: Maybe Text -> AForm Handler Text +accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text accessKeyIDFieldWithHelp def = accessKeyIDField help def where help = [whamlet| @@ -103,10 +103,10 @@ accessKeyIDFieldWithHelp def = accessKeyIDField help def Get Amazon access keys |] -secretAccessKeyField :: Maybe Text -> AForm Handler Text +secretAccessKeyField :: Maybe Text -> MkAForm Text secretAccessKeyField def = areq passwordField "Secret Access Key" def -datacenterField :: AWS.Service -> AForm Handler Text +datacenterField :: AWS.Service -> MkAForm Text datacenterField service = areq (selectFieldList list) "Datacenter" defregion where list = M.toList $ AWS.regionMap service diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 3b0d6b78b5..8d706ff2c5 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -107,7 +107,7 @@ deleteCurrentRepository = dangerPage $ do data SanityVerifier = SanityVerifier T.Text deriving (Eq) -sanityVerifierAForm :: SanityVerifier -> AForm Handler SanityVerifier +sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier sanityVerifierAForm template = SanityVerifier <$> areq checksanity "Confirm deletion?" Nothing where diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index abd3c95827..96361e0bf6 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -132,7 +132,7 @@ setRepoConfig uuid mremote oldc newc = do legalName = makeLegalName . T.unpack . repoName -editRepositoryAForm :: RepoConfig -> AForm Handler RepoConfig +editRepositoryAForm :: RepoConfig -> MkAForm RepoConfig editRepositoryAForm def = RepoConfig <$> areq textField "Name" (Just $ repoName def) <*> aopt textField "Description" (Just $ repoDescription def) diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index 15536adb95..f42c841c34 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -79,7 +79,7 @@ showMediaType MediaVideo = "videos & movies" showMediaType MediaAudio = "audio & music" showMediaType MediaOmitted = "other" -iaInputAForm :: Maybe CredPair -> AForm Handler IAInput +iaInputAForm :: Maybe CredPair -> MkAForm IAInput iaInputAForm defcreds = IAInput <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) @@ -99,7 +99,7 @@ itemNameHelp = [whamlet| will be uploaded to your Internet Archive item. |] -iaCredsAForm :: Maybe CredPair -> AForm Handler AWS.AWSCreds +iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds iaCredsAForm defcreds = AWS.AWSCreds <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) @@ -110,7 +110,7 @@ previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $ AWS.isIARemoteConfig . Remote.config #endif -accessKeyIDFieldWithHelp :: Maybe Text -> AForm Handler Text +accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def where help = [whamlet| diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 0b551c4383..e5ba193687 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -46,7 +46,11 @@ data RepositoryPath = RepositoryPath Text - - Validates that the path entered is not empty, and is a safe value - to use as a repository. -} +#if MIN_VERSION_yesod(1,2,0) repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text +#else +repositoryPathField :: forall sub. Bool -> Field sub WebApp Text +#endif repositoryPathField autofocus = Field #if ! MIN_VERSION_yesod_form(1,2,0) { fieldParse = parse @@ -119,7 +123,7 @@ defaultRepositoryPath firstrun = do ) legit d = not <$> doesFileExist (d "git-annex") -newRepositoryForm :: FilePath -> Html -> Form RepositoryPath +newRepositoryForm :: FilePath -> Html -> MkMForm RepositoryPath newRepositoryForm defpath msg = do (pathRes, pathView) <- mreq (repositoryPathField True) "" (Just $ T.pack $ addTrailingPathSeparator defpath) @@ -185,7 +189,7 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do where remotename = takeFileName newrepopath -selectDriveForm :: [RemovableDrive] -> Html -> Form RemovableDrive +selectDriveForm :: [RemovableDrive] -> Html -> MkMForm RemovableDrive selectDriveForm drives = renderBootstrap $ RemovableDrive <$> pure Nothing <*> areq (selectFieldList pairs) "Select drive:" Nothing diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs index 8842ae14bc..2bd161351d 100644 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -29,7 +29,7 @@ data PrefsForm = PrefsForm , debugEnabled :: Bool } -prefsAForm :: PrefsForm -> AForm Handler PrefsForm +prefsAForm :: PrefsForm -> MkAForm PrefsForm prefsAForm def = PrefsForm <$> areq (storageField `withNote` diskreservenote) "Disk reserve" (Just $ diskReserve def) diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index cbb6d76a76..3baff59f30 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, FlexibleContexts #-} {-# LANGUAGE CPP #-} module Assistant.WebApp.Configurators.Ssh where @@ -58,7 +58,11 @@ mkSshInput s = SshInput , inputPort = sshPort s } +#if MIN_VERSION_yesod(1,2,0) sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput +#else +sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput +#endif sshInputAForm hostnamefield def = SshInput <$> aopt check_hostname "Host name" (Just $ inputHostname def) <*> aopt check_username "User name" (Just $ inputUsername def) diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 49af3c5a17..9046033ffb 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -43,7 +43,7 @@ data WebDAVInput = WebDAVInput toCredPair :: WebDAVInput -> CredPair toCredPair input = (T.unpack $ user input, T.unpack $ password input) -boxComAForm :: Maybe CredPair -> AForm Handler WebDAVInput +boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput boxComAForm defcreds = WebDAVInput <$> areq textField "Username or Email" (T.pack . fst <$> defcreds) <*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds) @@ -51,7 +51,7 @@ boxComAForm defcreds = WebDAVInput <*> areq textField "Directory" (Just "annex") <*> enableEncryptionField -webDAVCredsAForm :: Maybe CredPair -> AForm Handler WebDAVInput +webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput webDAVCredsAForm defcreds = WebDAVInput <$> areq textField "Username or Email" (T.pack . fst <$> defcreds) <*> areq passwordField "Password" (T.pack . snd <$> defcreds) diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index 30f141188c..b29f0d295d 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, FlexibleContexts #-} {-# LANGUAGE CPP #-} module Assistant.WebApp.Configurators.XMPP where @@ -171,12 +171,12 @@ data XMPPForm = XMPPForm creds2Form :: XMPPCreds -> XMPPForm creds2Form c = XMPPForm (xmppJID c) (xmppPassword c) -xmppAForm :: (Maybe XMPPForm) -> AForm Handler XMPPForm +xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm xmppAForm def = XMPPForm <$> areq jidField "Jabber address" (formJID <$> def) <*> areq passwordField "Password" Nothing -jidField :: Field Handler Text +jidField :: MkField Text jidField = checkBool (isJust . parseJID) bad textField where bad :: Text diff --git a/Assistant/WebApp/Form.hs b/Assistant/WebApp/Form.hs index b474f76d88..d7a6c621c2 100644 --- a/Assistant/WebApp/Form.hs +++ b/Assistant/WebApp/Form.hs @@ -8,10 +8,12 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# LANGUAGE CPP #-} module Assistant.WebApp.Form where import Types.Remote (RemoteConfigKey) +import Assistant.WebApp.Types import Yesod hiding (textField, passwordField) import Yesod.Form.Fields as F @@ -24,7 +26,7 @@ import Data.Text (Text) - - Required fields are still checked by Yesod. -} -textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text +textField :: MkField Text textField = F.textField { fieldView = \theId name attrs val _isReq -> [whamlet| @@ -32,7 +34,7 @@ textField = F.textField } {- Also without required attribute. -} -passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text +passwordField :: MkField Text passwordField = F.passwordField { fieldView = \theId name attrs val _isReq -> toWidget [hamlet| @@ -40,7 +42,11 @@ passwordField = F.passwordField } {- Makes a note widget be displayed after a field. -} +#if MIN_VERSION_yesod(1,2,0) withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v +#else +withNote :: Field sub master v -> GWidget sub master () -> Field sub master v +#endif withNote field note = field { fieldView = newview } where newview theId name attrs val isReq = @@ -48,7 +54,11 @@ withNote field note = field { fieldView = newview } in [whamlet|^{fieldwidget}  ^{note}|] {- Note that the toggle string must be unique on the form. -} +#if MIN_VERSION_yesod(1,2,0) withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v +#else +withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v +#endif withExpandableNote field (toggle, note) = withNote field $ [whamlet| #{toggle} @@ -62,7 +72,11 @@ data EnableEncryption = SharedEncryption | NoEncryption deriving (Eq) {- Adds a check box to an AForm to control encryption. -} +#if MIN_VERSION_yesod(1,2,0) enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption +#else +enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption +#endif enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just SharedEncryption) where choices :: [(Text, EnableEncryption)] diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index eae7269407..4191e028da 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -7,7 +7,8 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Assistant.WebApp.Types where @@ -81,29 +82,65 @@ instance RenderMessage WebApp FormMessage where - When the webapp is run outside a git-annex repository, the fallback - value is returned. -} +#if MIN_VERSION_yesod(1,2,0) liftAnnexOr :: forall a. a -> Annex a -> Handler a +#else +liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a +#endif liftAnnexOr fallback a = ifM (noAnnex <$> getYesod) ( return fallback , liftAssistant $ liftAnnex a ) +#if MIN_VERSION_yesod(1,2,0) instance LiftAnnex Handler where +#else +instance LiftAnnex (GHandler sub WebApp) where +#endif liftAnnex = liftAnnexOr $ error "internal liftAnnex" +#if MIN_VERSION_yesod(1,2,0) instance LiftAnnex (WidgetT WebApp IO) where +#else +instance LiftAnnex (GWidget WebApp WebApp) where +#endif liftAnnex = liftH . liftAnnex class LiftAssistant m where liftAssistant :: Assistant a -> m a +#if MIN_VERSION_yesod(1,2,0) instance LiftAssistant Handler where +#else +instance LiftAssistant (GHandler sub WebApp) where +#endif liftAssistant a = liftIO . flip runAssistant a =<< assistantData <$> getYesod +#if MIN_VERSION_yesod(1,2,0) instance LiftAssistant (WidgetT WebApp IO) where +#else +instance LiftAssistant (GWidget WebApp WebApp) where +#endif liftAssistant = liftH . liftAssistant -type Form x = MForm Handler (FormResult x, Widget) +#if MIN_VERSION_yesod(1,2,0) +type MkMForm x = MForm Handler (FormResult x, Widget) +#else +type MkMForm x = MForm WebApp WebApp (FormResult x, Widget) +#endif + +#if MIN_VERSION_yesod(1,2,0) +type MkAForm x = AForm Handler x +#else +type MkAForm x = AForm WebApp WebApp x +#endif + +#if MIN_VERSION_yesod(1,2,0) +type MkField x = Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x +#else +type MkField x = RenderMessage master FormMessage => Field sub master x +#endif data RepoSelector = RepoSelector { onlyCloud :: Bool diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 240d097b00..f3c0d3a6b3 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -178,7 +178,11 @@ lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req {- Rather than storing a session key on disk, use a random key - that will only be valid for this run of the webapp. -} +#if MIN_VERSION_yesod(1,2,0) webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend) +#else +webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe (Yesod.SessionBackend y)) +#endif webAppSessionBackend _ = do g <- newGenIO :: IO SystemRandom case genBytes 96 g of @@ -218,7 +222,11 @@ genRandomToken = do - Note that the usual Yesod error page is bypassed on error, to avoid - possibly leaking the auth token in urls on that page! -} +#if MIN_VERSION_yesod(1,2,0) checkAuthToken :: (Monad m, Yesod.MonadHandler m) => (Yesod.HandlerSite m -> T.Text) -> m Yesod.AuthResult +#else +checkAuthToken :: forall t sub. (t -> T.Text) -> Yesod.GHandler sub t Yesod.AuthResult +#endif checkAuthToken extractToken = do webapp <- Yesod.getYesod req <- Yesod.getRequest diff --git a/Utility/Yesod.hs b/Utility/Yesod.hs index ef9ad5fc57..e437326b02 100644 --- a/Utility/Yesod.hs +++ b/Utility/Yesod.hs @@ -8,20 +8,21 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP, RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} module Utility.Yesod where +import Yesod +#if MIN_VERSION_yesod_default(1,2,0) +import Yesod.Core +#endif #ifndef __ANDROID__ import Yesod.Default.Util -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax (Q, Exp) #if MIN_VERSION_yesod_default(1,1,0) 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) @@ -39,10 +40,10 @@ 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 +#if MIN_VERSION_yesod(1,2,0) liftH :: Monad m => HandlerT site m a -> WidgetT site m a liftH = liftH +#else +liftH :: MonadLift base m => base a -> m a +liftH = lift #endif diff --git a/git-annex.cabal b/git-annex.cabal index a97ee38944..14d6da7a50 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -133,7 +133,7 @@ Executable git-annex if flag(Webapp) Build-Depends: - yesod, yesod-default, yesod-static, yesod-form, + yesod, yesod-default, yesod-static, yesod-form, yesod-core, case-insensitive, http-types, transformers, wai, wai-logger, warp, blaze-builder, crypto-api, hamlet, clientsession, aeson, template-haskell, data-default