mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

WIP yesod 1.2

Browse source
This commit is contained in:
Joey Hess 2013-06-02 15:57:22 -04:00
parent 92f036fcb4
commit 79fd677805
18 changed files with 94 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Assistant/WebApp.hs
View file

@ -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|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
{- A button with an icon, and maybe label or tooltip, that can be

26
Assistant/WebApp/Configurators/AWS.hs
View file

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

8
Assistant/WebApp/Configurators/Delete.hs
View file

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

6
Assistant/WebApp/Configurators/Edit.hs
View file

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

14
Assistant/WebApp/Configurators/IA.hs
View file

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

22
Assistant/WebApp/Configurators/Local.hs
View file

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

10
Assistant/WebApp/Configurators/Pairing.hs
View file

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

6
Assistant/WebApp/Configurators/Preferences.hs
View file

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

12
Assistant/WebApp/Configurators/Ssh.hs
View file

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

14
Assistant/WebApp/Configurators/WebDAV.hs
View file

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

8
Assistant/WebApp/Configurators/XMPP.hs
View file

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

4
Assistant/WebApp/DashBoard.hs
View file

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

10
Assistant/WebApp/Form.hs
View file

@ -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|
<input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}">
@ -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|
<input id="#{theId}" name="#{name}" *{attrs} type="password" value="#{either id id val}">
@ -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}&nbsp;&nbsp;<span>^{note}</span>|]
{- 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|
<a .btn data-toggle="collapse" data-target="##{ident}">
#{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)]

2
Assistant/WebApp/RepoList.hs
View file

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

6
Assistant/WebApp/SideBar.hs
View file

@ -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|<img src="@{StaticR activityicon_gif}" alt="">|]
htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|]
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|&#9730;|]
bootstrapIcon :: Text -> GWidget sub master ()
bootstrapIcon :: Text -> Widget
bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]

18
Assistant/WebApp/Types.hs
View file

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

9
Utility/WebApp.hs
View file

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

2
git-annex.cabal
View file

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