diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 0812acb4d1..49aa046f82 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -22,12 +22,12 @@ import qualified Network.Wai as W
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T
-waitNotifier :: forall sub. (Assistant NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
+waitNotifier :: Assistant NotificationBroadcaster -> NotificationId -> Handler ()
waitNotifier getbroadcaster nid = liftAssistant $ do
b <- getbroadcaster
liftIO $ waitNotification $ notificationHandleFromId b nid
-newNotifier :: forall sub. (Assistant NotificationBroadcaster) -> GHandler sub WebApp NotificationId
+newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId
newNotifier getbroadcaster = liftAssistant $ do
b <- getbroadcaster
liftIO $ notificationHandleToId <$> newNotificationHandle True b
@@ -36,7 +36,7 @@ newNotifier getbroadcaster = liftAssistant $ do
- every form. -}
webAppFormAuthToken :: Widget
webAppFormAuthToken = do
- webapp <- lift getYesod
+ webapp <- handlerToWidget getYesod
[whamlet||]
{- A button with an icon, and maybe label or tooltip, that can be
diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs
index 7b499aff5e..fd7b74dc28 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 WebApp WebApp AWSInput
+s3InputAForm :: Maybe CredPair -> AForm Handler 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 WebApp WebApp AWSInput
+glacierInputAForm :: Maybe CredPair -> AForm Handler 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 WebApp WebApp AWSCreds
+awsCredsAForm :: Maybe CredPair -> AForm Handler AWSCreds
awsCredsAForm defcreds = AWSCreds
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> defcreds)
-accessKeyIDField :: Widget -> Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDField :: Widget -> Maybe Text -> AForm Handler Text
accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def
-accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDFieldWithHelp :: Maybe Text -> AForm Handler 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 WebApp WebApp Text
+secretAccessKeyField :: Maybe Text -> AForm Handler Text
secretAccessKeyField def = areq passwordField "Secret Access Key" def
-datacenterField :: AWS.Service -> AForm WebApp WebApp Text
+datacenterField :: AWS.Service -> AForm Handler Text
datacenterField service = areq (selectFieldList list) "Datacenter" defregion
where
list = M.toList $ AWS.regionMap service
@@ -119,10 +119,10 @@ postAddS3R :: Handler RepHtml
#ifdef WITH_S3
postAddS3R = awsConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds
- ((result, form), enctype) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ s3InputAForm defcreds
case result of
- FormSuccess input -> lift $ do
+ FormSuccess input -> handlerToWidget $ 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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ glacierInputAForm defcreds
case result of
- FormSuccess input -> lift $ do
+ FormSuccess input -> handlerToWidget $ 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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ awsCredsAForm defcreds
case result of
- FormSuccess creds -> lift $ do
+ FormSuccess creds -> handlerToWidget $ do
m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m
diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs
index c7fa5f3422..67bc26d6f9 100644
--- a/Assistant/WebApp/Configurators/Delete.hs
+++ b/Assistant/WebApp/Configurators/Delete.hs
@@ -72,14 +72,14 @@ postDeleteCurrentRepositoryR = deleteCurrentRepository
deleteCurrentRepository :: Handler RepHtml
deleteCurrentRepository = dangerPage $ do
- reldir <- fromJust . relDir <$> lift getYesod
+ reldir <- fromJust . relDir <$> handlerToWidget getYesod
havegitremotes <- haveremotes syncGitRemotes
havedataremotes <- haveremotes syncDataRemotes
- ((result, form), enctype) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ sanityVerifierAForm $
SanityVerifier magicphrase
case result of
- FormSuccess _ -> lift $ do
+ FormSuccess _ -> handlerToWidget $ do
dir <- liftAnnex $ fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir
@@ -107,7 +107,7 @@ deleteCurrentRepository = dangerPage $ do
data SanityVerifier = SanityVerifier T.Text
deriving (Eq)
-sanityVerifierAForm :: SanityVerifier -> AForm WebApp WebApp SanityVerifier
+sanityVerifierAForm :: SanityVerifier -> AForm Handler 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 a433987822..ed586a6147 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 WebApp WebApp RepoConfig
+editRepositoryAForm :: RepoConfig -> AForm Handler RepoConfig
editRepositoryAForm def = RepoConfig
<$> areq textField "Name" (Just $ repoName def)
<*> aopt textField "Description" (Just $ repoDescription def)
@@ -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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ editRepositoryAForm curr
case result of
- FormSuccess input -> lift $ do
+ FormSuccess input -> handlerToWidget $ do
setRepoConfig uuid mremote curr input
liftAnnex $ checkAssociatedDirectory input mremote
redirect DashboardR
diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs
index 6887ff996e..6b28f6dc0f 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 WebApp WebApp IAInput
+iaInputAForm :: Maybe CredPair -> AForm Handler 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 WebApp WebApp AWS.AWSCreds
+iaCredsAForm :: Maybe CredPair -> AForm Handler 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 WebApp WebApp Text
+accessKeyIDFieldWithHelp :: Maybe Text -> AForm Handler Text
accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
where
help = [whamlet|
@@ -125,10 +125,10 @@ postAddIAR :: Handler RepHtml
#ifdef WITH_S3
postAddIAR = iaConfigurator $ do
defcreds <- liftAnnex previouslyUsedIACreds
- ((result, form), enctype) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ iaInputAForm defcreds
case result of
- FormSuccess input -> lift $ do
+ FormSuccess input -> handlerToWidget $ 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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ iaCredsAForm defcreds
case result of
- FormSuccess creds -> lift $ do
+ FormSuccess creds -> handlerToWidget $ do
m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index e7d20a49fd..f8dbada3b2 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -46,7 +46,7 @@ data RepositoryPath = RepositoryPath Text
-
- Validates that the path entered is not empty, and is a safe value
- to use as a repository. -}
-repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
+repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
repositoryPathField autofocus = Field
#if ! MIN_VERSION_yesod_form(1,2,0)
{ fieldParse = parse
@@ -119,7 +119,7 @@ defaultRepositoryPath firstrun = do
)
legit d = not <$> doesFileExist (d "git-annex")
-newRepositoryForm :: FilePath -> Form RepositoryPath
+newRepositoryForm :: FilePath -> Html -> Form RepositoryPath
newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) ""
(Just $ T.pack $ addTrailingPathSeparator defpath)
@@ -142,11 +142,11 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
let path = "/sdcard/annex"
#else
let androidspecial = False
- path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
+ path <- liftIO . defaultRepositoryPath =<< handlerToWidget inFirstRun
#endif
- ((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm path
+ ((res, form), enctype) <- handlerToWidget $ runFormPost $ newRepositoryForm path
case res of
- FormSuccess (RepositoryPath p) -> lift $
+ FormSuccess (RepositoryPath p) -> handlerToWidget $
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) <- lift $ runFormPost $ newRepositoryForm home
+ ((res, form), enctype) <- handlerToWidget $ 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
- lift $ liftAnnexOr () $ setStandardGroup u ClientGroup
+ handlerToWidget $ 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 <$> lift getYesod
+ mainrepo <- fromJust . relDir <$> handlerToWidget getYesod
$(widgetFile "configurators/newrepository/combine")
getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml
@@ -185,7 +185,7 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
where
remotename = takeFileName newrepopath
-selectDriveForm :: [RemovableDrive] -> Form RemovableDrive
+selectDriveForm :: [RemovableDrive] -> Html -> Form RemovableDrive
selectDriveForm drives = renderBootstrap $ RemovableDrive
<$> pure Nothing
<*> areq (selectFieldList pairs) "Select drive:" Nothing
@@ -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) <- lift $ runFormPost $
+ ((res, form), enctype) <- handlerToWidget $ runFormPost $
selectDriveForm (sort writabledrives)
case res of
- FormSuccess drive -> lift $ redirect $ ConfirmAddDriveR drive
+ FormSuccess drive -> handlerToWidget $ redirect $ ConfirmAddDriveR drive
_ -> $(widgetFile "configurators/adddrive")
{- The repo may already exist, when adding removable media
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 624123f17a..2cc7305728 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/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 <- lift $ repoPath <$> liftAnnex gitRepo
+ repodir <- handlerToWidget $ 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 <- lift getUrlRender
- reldir <- fromJust . relDir <$> lift getYesod
+ urlrender <- handlerToWidget getUrlRender
+ reldir <- fromJust . relDir <$> handlerToWidget 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
- lift $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
+ handlerToWidget $ 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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $
InputSecret <$> aopt textField "Secret phrase" Nothing
case result of
diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs
index e14f613fe6..02d14d2854 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 WebApp WebApp PrefsForm
+prefsAForm :: PrefsForm -> AForm Handler PrefsForm
prefsAForm def = PrefsForm
<$> areq (storageField `withNote` diskreservenote)
"Disk reserve" (Just $ diskReserve def)
@@ -86,11 +86,11 @@ getPreferencesR :: Handler RepHtml
getPreferencesR = postPreferencesR
postPreferencesR :: Handler RepHtml
postPreferencesR = page "Preferences" (Just Configuration) $ do
- ((result, form), enctype) <- lift $ do
+ ((result, form), enctype) <- handlerToWidget $ do
current <- liftAnnex getPrefs
runFormPost $ renderBootstrap $ prefsAForm current
case result of
- FormSuccess new -> lift $ do
+ FormSuccess new -> handlerToWidget $ do
liftAnnex $ storePrefs new
redirect ConfigurationR
_ -> $(widgetFile "configurators/preferences")
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 49d8946d97..767a843a7e 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -58,7 +58,7 @@ mkSshInput s = SshInput
, inputPort = sshPort s
}
-sshInputAForm :: (Field WebApp WebApp Text) -> SshInput -> AForm WebApp WebApp SshInput
+sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
sshInputAForm hostnamefield def = SshInput
<$> aopt check_hostname "Host name" (Just $ inputHostname def)
<*> aopt check_username "User name" (Just $ inputUsername def)
@@ -107,7 +107,7 @@ getAddSshR = postAddSshR
postAddSshR :: Handler RepHtml
postAddSshR = sshConfigurator $ do
u <- liftIO $ T.pack <$> myUserName
- ((result, form), enctype) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
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 -> lift $ redirect $ ConfirmSshR sshdata
+ Right sshdata -> handlerToWidget $ 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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
case result of
FormSuccess sshinput'
| isRsyncNet (inputHostname sshinput') ->
- void $ lift $ makeRsyncNet sshinput' reponame (const noop)
+ void $ handlerToWidget $ 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 = lift $ redirect $ ConfirmSshR $
+ enable sshdata = handlerToWidget $ redirect $ ConfirmSshR $
sshdata { rsyncOnly = True }
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs
index a14359edad..8e551f8446 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 WebApp WebApp WebDAVInput
+boxComAForm :: Maybe CredPair -> AForm Handler 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 WebApp WebApp WebDAVInput
+webDAVCredsAForm :: Maybe CredPair -> AForm Handler WebDAVInput
webDAVCredsAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Password" (T.pack . snd <$> defcreds)
@@ -65,10 +65,10 @@ postAddBoxComR :: Handler RepHtml
#ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
- ((result, form), enctype) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ boxComAForm defcreds
case result of
- FormSuccess input -> lift $
+ FormSuccess input -> handlerToWidget $
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 $ lift $
+ Just creds -> webDAVConfigurator $ handlerToWidget $
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) <- lift $
+ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
case result of
- FormSuccess input -> lift $
+ FormSuccess input -> handlerToWidget $
makeWebDavRemote name (toCredPair input) (const noop) M.empty
_ -> do
description <- liftAnnex $
diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs
index 04c2d4b068..3a589ac94c 100644
--- a/Assistant/WebApp/Configurators/XMPP.hs
+++ b/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) <- lift $ do
+ ((result, form), enctype) <- handlerToWidget $ do
oldcreds <- liftAnnex getXMPPCreds
runFormPost $ renderBootstrap $ xmppAForm $
creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp")
case result of
- FormSuccess f -> either (showform . Just) (lift . storecreds)
+ FormSuccess f -> either (showform . Just) (handlerToWidget . storecreds)
=<< liftIO (validateForm f)
_ -> showform Nothing
where
@@ -171,12 +171,12 @@ data XMPPForm = XMPPForm
creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
-xmppAForm :: (Maybe XMPPForm) -> AForm WebApp WebApp XMPPForm
+xmppAForm :: (Maybe XMPPForm) -> AForm Handler XMPPForm
xmppAForm def = XMPPForm
<$> areq jidField "Jabber address" (formJID <$> def)
<*> areq passwordField "Password" Nothing
-jidField :: Field WebApp WebApp Text
+jidField :: Field Handler Text
jidField = checkBool (isJust . parseJID) bad textField
where
bad :: Text
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index bb97074155..54bcbea6c7 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/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 <- lift getYesod
- current <- lift $ M.toList <$> getCurrentTransfers
+ webapp <- handlerToWidget getYesod
+ current <- handlerToWidget $ M.toList <$> getCurrentTransfers
queued <- take 10 <$> liftAssistant getTransferQueue
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued
diff --git a/Assistant/WebApp/Form.hs b/Assistant/WebApp/Form.hs
index 7664fc301d..b474f76d88 100644
--- a/Assistant/WebApp/Form.hs
+++ b/Assistant/WebApp/Form.hs
@@ -24,7 +24,7 @@ import Data.Text (Text)
-
- Required fields are still checked by Yesod.
-}
-textField :: RenderMessage master FormMessage => Field sub master Text
+textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
textField = F.textField
{ fieldView = \theId name attrs val _isReq -> [whamlet|
@@ -32,7 +32,7 @@ textField = F.textField
}
{- Also without required attribute. -}
-passwordField :: RenderMessage master FormMessage => Field sub master Text
+passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
passwordField = F.passwordField
{ fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@@ -40,7 +40,7 @@ passwordField = F.passwordField
}
{- Makes a note widget be displayed after a field. -}
-withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
+withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
withNote field note = field { fieldView = newview }
where
newview theId name attrs val isReq =
@@ -48,7 +48,7 @@ withNote field note = field { fieldView = newview }
in [whamlet|^{fieldwidget} ^{note}|]
{- Note that the toggle string must be unique on the form. -}
-withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
+withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v
withExpandableNote field (toggle, note) = withNote field $ [whamlet|
#{toggle}
@@ -62,7 +62,7 @@ data EnableEncryption = SharedEncryption | NoEncryption
deriving (Eq)
{- Adds a check box to an AForm to control encryption. -}
-enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
+enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just SharedEncryption)
where
choices :: [(Text, EnableEncryption)]
diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs
index f7d10468b8..e84cab28ab 100644
--- a/Assistant/WebApp/RepoList.hs
+++ b/Assistant/WebApp/RepoList.hs
@@ -110,7 +110,7 @@ repoListDisplay reposelector = do
addScript $ StaticR jquery_ui_mouse_js
addScript $ StaticR jquery_ui_sortable_js
- repolist <- lift $ repoList reposelector
+ repolist <- handlerToWidget $ repoList reposelector
let addmore = nudgeAddMore reposelector
let nootherrepos = length repolist < 2
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index 0be3e1023e..d0358dc22f 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -28,7 +28,7 @@ sideBarDisplay :: Widget
sideBarDisplay = do
let content = do
{- Add newest alerts to the sidebar. -}
- alertpairs <- lift $ M.toList . alertMap
+ alertpairs <- handlerToWidget $ M.toList . alertMap
<$> liftAssistant getDaemonStatus
mapM_ renderalert $
take displayAlerts $ reverse $ sortAlertPairs alertpairs
@@ -92,7 +92,7 @@ getClickAlert i = do
redirect $ buttonUrl b
_ -> redirectBack
-htmlIcon :: AlertIcon -> GWidget WebApp WebApp ()
+htmlIcon :: AlertIcon -> Widget
htmlIcon ActivityIcon = [whamlet|
|]
htmlIcon SyncIcon = [whamlet|
|]
htmlIcon InfoIcon = bootstrapIcon "info-sign"
@@ -101,5 +101,5 @@ htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
-- utf-8 umbrella (utf-8 cloud looks too stormy)
htmlIcon TheCloud = [whamlet|☂|]
-bootstrapIcon :: Text -> GWidget sub master ()
+bootstrapIcon :: Text -> Widget
bootstrapIcon name = [whamlet||]
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index 2d0123479f..6245e3dcbc 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -81,29 +81,29 @@ instance RenderMessage WebApp FormMessage where
- 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 :: forall a. a -> Annex a -> Handler 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 Handler where
+ liftAnnex = liftAnnexOr $ error "internal liftAnnex"
-instance LiftAnnex (GWidget WebApp WebApp) where
- liftAnnex = lift . liftAnnex
+instance LiftAnnex (WidgetT WebApp IO) where
+ liftAnnex = handlerToWidget . liftAnnex
class LiftAssistant m where
liftAssistant :: Assistant a -> m a
-instance LiftAssistant (GHandler sub WebApp) where
+instance LiftAssistant Handler where
liftAssistant a = liftIO . flip runAssistant a
=<< assistantData <$> getYesod
-instance LiftAssistant (GWidget WebApp WebApp) where
- liftAssistant = lift . liftAssistant
+instance LiftAssistant (WidgetT WebApp IO) where
+ liftAssistant = handlerToWidget . liftAssistant
-type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
+type Form x = MForm Handler (FormResult x, Widget)
data RepoSelector = RepoSelector
{ onlyCloud :: Bool
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index 4c112bbe63..240d097b00 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -178,7 +178,7 @@ 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. -}
-webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe (Yesod.SessionBackend y))
+webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend)
webAppSessionBackend _ = do
g <- newGenIO :: IO SystemRandom
case genBytes 96 g of
@@ -189,6 +189,10 @@ webAppSessionBackend _ = do
where
timeout = 120 * 60 -- 120 minutes
use key =
+#if MIN_VERSION_yesod(1,2,0)
+ Just . Yesod.clientSessionBackend key . fst
+ <$> Yesod.clientSessionDateCacher timeout
+#else
#if MIN_VERSION_yesod(1,1,7)
Just . Yesod.clientSessionBackend2 key . fst
<$> Yesod.clientSessionDateCacher timeout
@@ -196,6 +200,7 @@ webAppSessionBackend _ = do
return $ Just $
Yesod.clientSessionBackend key timeout
#endif
+#endif
{- Generates a random sha512 string, suitable to be used for an
- authentication secret. -}
@@ -213,7 +218,7 @@ 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!
-}
-checkAuthToken :: forall t sub. (t -> T.Text) -> Yesod.GHandler sub t Yesod.AuthResult
+checkAuthToken :: (Monad m, Yesod.MonadHandler m) => (Yesod.HandlerSite m -> T.Text) -> m Yesod.AuthResult
checkAuthToken extractToken = do
webapp <- Yesod.getYesod
req <- Yesod.getRequest
diff --git a/git-annex.cabal b/git-annex.cabal
index b01e13c8a0..a97ee38944 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -133,7 +133,7 @@ Executable git-annex
if flag(Webapp)
Build-Depends:
- yesod (< 1.2), yesod-default (< 1.2), yesod-static (< 1.2), yesod-form (< 1.3),
+ yesod, yesod-default, yesod-static, yesod-form,
case-insensitive, http-types, transformers, wai, wai-logger, warp,
blaze-builder, crypto-api, hamlet, clientsession, aeson,
template-haskell, data-default