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.ByteString.Char8 as S8
import qualified Data.Text as T 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 waitNotifier getbroadcaster nid = liftAssistant $ do
b <- getbroadcaster b <- getbroadcaster
liftIO $ waitNotification $ notificationHandleFromId b nid liftIO $ waitNotification $ notificationHandleFromId b nid
newNotifier :: forall sub. (Assistant NotificationBroadcaster) -> GHandler sub WebApp NotificationId newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId
newNotifier getbroadcaster = liftAssistant $ do newNotifier getbroadcaster = liftAssistant $ do
b <- getbroadcaster b <- getbroadcaster
liftIO $ notificationHandleToId <$> newNotificationHandle True b liftIO $ notificationHandleToId <$> newNotificationHandle True b
@ -36,7 +36,7 @@ newNotifier getbroadcaster = liftAssistant $ do
- every form. -} - every form. -}
webAppFormAuthToken :: Widget webAppFormAuthToken :: Widget
webAppFormAuthToken = do webAppFormAuthToken = do
webapp <- lift getYesod webapp <- handlerToWidget getYesod
[whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|] [whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
{- A button with an icon, and maybe label or tooltip, that can be {- 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 :: AWSInput -> AWSCreds
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i) extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
s3InputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput s3InputAForm :: Maybe CredPair -> AForm Handler AWSInput
s3InputAForm defcreds = AWSInput s3InputAForm defcreds = AWSInput
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> defcreds) <*> secretAccessKeyField (T.pack . snd <$> defcreds)
@ -78,7 +78,7 @@ s3InputAForm defcreds = AWSInput
, ("Reduced redundancy (costs less)", ReducedRedundancy) , ("Reduced redundancy (costs less)", ReducedRedundancy)
] ]
glacierInputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput glacierInputAForm :: Maybe CredPair -> AForm Handler AWSInput
glacierInputAForm defcreds = AWSInput glacierInputAForm defcreds = AWSInput
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> defcreds) <*> secretAccessKeyField (T.pack . snd <$> defcreds)
@ -87,15 +87,15 @@ glacierInputAForm defcreds = AWSInput
<*> areq textField "Repository name" (Just "glacier") <*> areq textField "Repository name" (Just "glacier")
<*> enableEncryptionField <*> enableEncryptionField
awsCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWSCreds awsCredsAForm :: Maybe CredPair -> AForm Handler AWSCreds
awsCredsAForm defcreds = AWSCreds awsCredsAForm defcreds = AWSCreds
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> 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 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 accessKeyIDFieldWithHelp def = accessKeyIDField help def
where where
help = [whamlet| help = [whamlet|
@ -103,10 +103,10 @@ accessKeyIDFieldWithHelp def = accessKeyIDField help def
Get Amazon access keys 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 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 datacenterField service = areq (selectFieldList list) "Datacenter" defregion
where where
list = M.toList $ AWS.regionMap service list = M.toList $ AWS.regionMap service
@ -119,10 +119,10 @@ postAddS3R :: Handler RepHtml
#ifdef WITH_S3 #ifdef WITH_S3
postAddS3R = awsConfigurator $ do postAddS3R = awsConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ s3InputAForm defcreds runFormPost $ renderBootstrap $ s3InputAForm defcreds
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> handlerToWidget $ do
let name = T.unpack $ repoName input let name = T.unpack $ repoName input
makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
[ configureEncryption $ enableEncryption input [ configureEncryption $ enableEncryption input
@ -145,10 +145,10 @@ postAddGlacierR :: Handler RepHtml
#ifdef WITH_S3 #ifdef WITH_S3
postAddGlacierR = glacierConfigurator $ do postAddGlacierR = glacierConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ glacierInputAForm defcreds runFormPost $ renderBootstrap $ glacierInputAForm defcreds
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> handlerToWidget $ do
let name = T.unpack $ repoName input let name = T.unpack $ repoName input
makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
[ configureEncryption $ enableEncryption input [ configureEncryption $ enableEncryption input
@ -191,10 +191,10 @@ enableAWSRemote :: RemoteType -> UUID -> Widget
#ifdef WITH_S3 #ifdef WITH_S3
enableAWSRemote remotetype uuid = do enableAWSRemote remotetype uuid = do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ awsCredsAForm defcreds runFormPost $ renderBootstrap $ awsCredsAForm defcreds
case result of case result of
FormSuccess creds -> lift $ do FormSuccess creds -> handlerToWidget $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $ let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m fromJust $ M.lookup uuid m

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

@ -72,14 +72,14 @@ postDeleteCurrentRepositoryR = deleteCurrentRepository
deleteCurrentRepository :: Handler RepHtml deleteCurrentRepository :: Handler RepHtml
deleteCurrentRepository = dangerPage $ do deleteCurrentRepository = dangerPage $ do
reldir <- fromJust . relDir <$> lift getYesod reldir <- fromJust . relDir <$> handlerToWidget getYesod
havegitremotes <- haveremotes syncGitRemotes havegitremotes <- haveremotes syncGitRemotes
havedataremotes <- haveremotes syncDataRemotes havedataremotes <- haveremotes syncDataRemotes
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ sanityVerifierAForm $ runFormPost $ renderBootstrap $ sanityVerifierAForm $
SanityVerifier magicphrase SanityVerifier magicphrase
case result of case result of
FormSuccess _ -> lift $ do FormSuccess _ -> handlerToWidget $ do
dir <- liftAnnex $ fromRepo Git.repoPath dir <- liftAnnex $ fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir liftIO $ removeAutoStartFile dir
@ -107,7 +107,7 @@ deleteCurrentRepository = dangerPage $ do
data SanityVerifier = SanityVerifier T.Text data SanityVerifier = SanityVerifier T.Text
deriving (Eq) deriving (Eq)
sanityVerifierAForm :: SanityVerifier -> AForm WebApp WebApp SanityVerifier sanityVerifierAForm :: SanityVerifier -> AForm Handler SanityVerifier
sanityVerifierAForm template = SanityVerifier sanityVerifierAForm template = SanityVerifier
<$> areq checksanity "Confirm deletion?" Nothing <$> areq checksanity "Confirm deletion?" Nothing
where where

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

@ -132,7 +132,7 @@ setRepoConfig uuid mremote oldc newc = do
legalName = makeLegalName . T.unpack . repoName legalName = makeLegalName . T.unpack . repoName
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig editRepositoryAForm :: RepoConfig -> AForm Handler RepoConfig
editRepositoryAForm def = RepoConfig editRepositoryAForm def = RepoConfig
<$> areq textField "Name" (Just $ repoName def) <$> areq textField "Name" (Just $ repoName def)
<*> aopt textField "Description" (Just $ repoDescription 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 mremote <- liftAnnex $ Remote.remoteFromUUID uuid
curr <- liftAnnex $ getRepoConfig uuid mremote curr <- liftAnnex $ getRepoConfig uuid mremote
liftAnnex $ checkAssociatedDirectory curr mremote liftAnnex $ checkAssociatedDirectory curr mremote
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ editRepositoryAForm curr runFormPost $ renderBootstrap $ editRepositoryAForm curr
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> handlerToWidget $ do
setRepoConfig uuid mremote curr input setRepoConfig uuid mremote curr input
liftAnnex $ checkAssociatedDirectory input mremote liftAnnex $ checkAssociatedDirectory input mremote
redirect DashboardR redirect DashboardR

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

@ -79,7 +79,7 @@ showMediaType MediaVideo = "videos & movies"
showMediaType MediaAudio = "audio & music" showMediaType MediaAudio = "audio & music"
showMediaType MediaOmitted = "other" showMediaType MediaOmitted = "other"
iaInputAForm :: Maybe CredPair -> AForm WebApp WebApp IAInput iaInputAForm :: Maybe CredPair -> AForm Handler IAInput
iaInputAForm defcreds = IAInput iaInputAForm defcreds = IAInput
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
@ -99,7 +99,7 @@ itemNameHelp = [whamlet|
will be uploaded to your Internet Archive item. 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 iaCredsAForm defcreds = AWS.AWSCreds
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
@ -110,7 +110,7 @@ previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
AWS.isIARemoteConfig . Remote.config AWS.isIARemoteConfig . Remote.config
#endif #endif
accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text accessKeyIDFieldWithHelp :: Maybe Text -> AForm Handler Text
accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
where where
help = [whamlet| help = [whamlet|
@ -125,10 +125,10 @@ postAddIAR :: Handler RepHtml
#ifdef WITH_S3 #ifdef WITH_S3
postAddIAR = iaConfigurator $ do postAddIAR = iaConfigurator $ do
defcreds <- liftAnnex previouslyUsedIACreds defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ iaInputAForm defcreds runFormPost $ renderBootstrap $ iaInputAForm defcreds
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> handlerToWidget $ do
let name = escapeBucket $ T.unpack $ itemName input let name = escapeBucket $ T.unpack $ itemName input
AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $ AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $
M.fromList $ catMaybes M.fromList $ catMaybes
@ -167,10 +167,10 @@ postEnableIAR _ = error "S3 not supported by this build"
enableIARemote :: UUID -> Widget enableIARemote :: UUID -> Widget
enableIARemote uuid = do enableIARemote uuid = do
defcreds <- liftAnnex previouslyUsedIACreds defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ iaCredsAForm defcreds runFormPost $ renderBootstrap $ iaCredsAForm defcreds
case result of case result of
FormSuccess creds -> lift $ do FormSuccess creds -> handlerToWidget $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $ let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m 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 - Validates that the path entered is not empty, and is a safe value
- to use as a repository. -} - 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 repositoryPathField autofocus = Field
#if ! MIN_VERSION_yesod_form(1,2,0) #if ! MIN_VERSION_yesod_form(1,2,0)
{ fieldParse = parse { fieldParse = parse
@ -119,7 +119,7 @@ defaultRepositoryPath firstrun = do
) )
legit d = not <$> doesFileExist (d </> "git-annex") legit d = not <$> doesFileExist (d </> "git-annex")
newRepositoryForm :: FilePath -> Form RepositoryPath newRepositoryForm :: FilePath -> Html -> Form RepositoryPath
newRepositoryForm defpath msg = do newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) "" (pathRes, pathView) <- mreq (repositoryPathField True) ""
(Just $ T.pack $ addTrailingPathSeparator defpath) (Just $ T.pack $ addTrailingPathSeparator defpath)
@ -142,11 +142,11 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
let path = "/sdcard/annex" let path = "/sdcard/annex"
#else #else
let androidspecial = False let androidspecial = False
path <- liftIO . defaultRepositoryPath =<< lift inFirstRun path <- liftIO . defaultRepositoryPath =<< handlerToWidget inFirstRun
#endif #endif
((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm path ((res, form), enctype) <- handlerToWidget $ runFormPost $ newRepositoryForm path
case res of case res of
FormSuccess (RepositoryPath p) -> lift $ FormSuccess (RepositoryPath p) -> handlerToWidget $
startFullAssistant (T.unpack p) ClientGroup startFullAssistant (T.unpack p) ClientGroup
_ -> $(widgetFile "configurators/newrepository/first") _ -> $(widgetFile "configurators/newrepository/first")
@ -160,13 +160,13 @@ getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler RepHtml postNewRepositoryR :: Handler RepHtml
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
home <- liftIO myHomeDir home <- liftIO myHomeDir
((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm home ((res, form), enctype) <- handlerToWidget $ runFormPost $ newRepositoryForm home
case res of case res of
FormSuccess (RepositoryPath p) -> do FormSuccess (RepositoryPath p) -> do
let path = T.unpack p let path = T.unpack p
isnew <- liftIO $ makeRepo path False isnew <- liftIO $ makeRepo path False
u <- liftIO $ initRepo isnew True path Nothing u <- liftIO $ initRepo isnew True path Nothing
lift $ liftAnnexOr () $ setStandardGroup u ClientGroup handlerToWidget $ liftAnnexOr () $ setStandardGroup u ClientGroup
liftIO $ addAutoStartFile path liftIO $ addAutoStartFile path
liftIO $ startAssistant path liftIO $ startAssistant path
askcombine u path askcombine u path
@ -174,7 +174,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
where where
askcombine newrepouuid newrepopath = do askcombine newrepouuid newrepopath = do
newrepo <- liftIO $ relHome newrepopath newrepo <- liftIO $ relHome newrepopath
mainrepo <- fromJust . relDir <$> lift getYesod mainrepo <- fromJust . relDir <$> handlerToWidget getYesod
$(widgetFile "configurators/newrepository/combine") $(widgetFile "configurators/newrepository/combine")
getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml
@ -185,7 +185,7 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
where where
remotename = takeFileName newrepopath remotename = takeFileName newrepopath
selectDriveForm :: [RemovableDrive] -> Form RemovableDrive selectDriveForm :: [RemovableDrive] -> Html -> Form RemovableDrive
selectDriveForm drives = renderBootstrap $ RemovableDrive selectDriveForm drives = renderBootstrap $ RemovableDrive
<$> pure Nothing <$> pure Nothing
<*> areq (selectFieldList pairs) "Select drive:" Nothing <*> areq (selectFieldList pairs) "Select drive:" Nothing
@ -215,10 +215,10 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO $ driveList removabledrives <- liftIO $ driveList
writabledrives <- liftIO $ writabledrives <- liftIO $
filterM (canWrite . T.unpack . mountPoint) removabledrives filterM (canWrite . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- lift $ runFormPost $ ((res, form), enctype) <- handlerToWidget $ runFormPost $
selectDriveForm (sort writabledrives) selectDriveForm (sort writabledrives)
case res of case res of
FormSuccess drive -> lift $ redirect $ ConfirmAddDriveR drive FormSuccess drive -> handlerToWidget $ redirect $ ConfirmAddDriveR drive
_ -> $(widgetFile "configurators/adddrive") _ -> $(widgetFile "configurators/adddrive")
{- The repo may already exist, when adding removable media {- 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 postFinishLocalPairR :: PairMsg -> Handler RepHtml
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
repodir <- lift $ repoPath <$> liftAnnex gitRepo repodir <- handlerToWidget $ repoPath <$> liftAnnex gitRepo
liftIO $ setup repodir liftIO $ setup repodir
startLocalPairing PairAck (cleanup repodir) alert uuid "" secret startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
where where
@ -216,8 +216,8 @@ getRunningLocalPairR _ = noLocalPairing
-} -}
startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
startLocalPairing stage oncancel alert muuid displaysecret secret = do startLocalPairing stage oncancel alert muuid displaysecret secret = do
urlrender <- lift getUrlRender urlrender <- handlerToWidget getUrlRender
reldir <- fromJust . relDir <$> lift getYesod reldir <- fromJust . relDir <$> handlerToWidget getYesod
sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender
{- Generating a ssh key pair can take a while, so do it in the {- 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 startSending pip stage $ sendrequests sender
void $ liftIO $ forkIO thread void $ liftIO $ forkIO thread
lift $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret handlerToWidget $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
where where
{- Sends pairing messages until the thread is killed, {- Sends pairing messages until the thread is killed,
- and shows an activity alert while doing it. - and shows an activity alert while doing it.
@ -264,7 +264,7 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
- that can validate it. -} - that can validate it. -}
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
promptSecret msg cont = pairPage $ do promptSecret msg cont = pairPage $ do
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ runFormPost $ renderBootstrap $
InputSecret <$> aopt textField "Secret phrase" Nothing InputSecret <$> aopt textField "Secret phrase" Nothing
case result of case result of

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

@ -29,7 +29,7 @@ data PrefsForm = PrefsForm
, debugEnabled :: Bool , debugEnabled :: Bool
} }
prefsAForm :: PrefsForm -> AForm WebApp WebApp PrefsForm prefsAForm :: PrefsForm -> AForm Handler PrefsForm
prefsAForm def = PrefsForm prefsAForm def = PrefsForm
<$> areq (storageField `withNote` diskreservenote) <$> areq (storageField `withNote` diskreservenote)
"Disk reserve" (Just $ diskReserve def) "Disk reserve" (Just $ diskReserve def)
@ -86,11 +86,11 @@ getPreferencesR :: Handler RepHtml
getPreferencesR = postPreferencesR getPreferencesR = postPreferencesR
postPreferencesR :: Handler RepHtml postPreferencesR :: Handler RepHtml
postPreferencesR = page "Preferences" (Just Configuration) $ do postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- lift $ do ((result, form), enctype) <- handlerToWidget $ do
current <- liftAnnex getPrefs current <- liftAnnex getPrefs
runFormPost $ renderBootstrap $ prefsAForm current runFormPost $ renderBootstrap $ prefsAForm current
case result of case result of
FormSuccess new -> lift $ do FormSuccess new -> handlerToWidget $ do
liftAnnex $ storePrefs new liftAnnex $ storePrefs new
redirect ConfigurationR redirect ConfigurationR
_ -> $(widgetFile "configurators/preferences") _ -> $(widgetFile "configurators/preferences")

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

@ -58,7 +58,7 @@ mkSshInput s = SshInput
, inputPort = sshPort s , 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 sshInputAForm hostnamefield def = SshInput
<$> aopt check_hostname "Host name" (Just $ inputHostname def) <$> aopt check_hostname "Host name" (Just $ inputHostname def)
<*> aopt check_username "User name" (Just $ inputUsername def) <*> aopt check_username "User name" (Just $ inputUsername def)
@ -107,7 +107,7 @@ getAddSshR = postAddSshR
postAddSshR :: Handler RepHtml postAddSshR :: Handler RepHtml
postAddSshR = sshConfigurator $ do postAddSshR = sshConfigurator $ do
u <- liftIO $ T.pack <$> myUserName u <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ sshInputAForm textField $ runFormPost $ renderBootstrap $ sshInputAForm textField $
SshInput Nothing (Just u) Nothing 22 SshInput Nothing (Just u) Nothing 22
case result of case result of
@ -115,7 +115,7 @@ postAddSshR = sshConfigurator $ do
s <- liftIO $ testServer sshinput s <- liftIO $ testServer sshinput
case s of case s of
Left status -> showform form enctype status Left status -> showform form enctype status
Right sshdata -> lift $ redirect $ ConfirmSshR sshdata Right sshdata -> handlerToWidget $ redirect $ ConfirmSshR sshdata
_ -> showform form enctype UntestedServer _ -> showform form enctype UntestedServer
where where
showform form enctype status = $(widgetFile "configurators/ssh/add") showform form enctype status = $(widgetFile "configurators/ssh/add")
@ -138,12 +138,12 @@ postEnableRsyncR u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
(Just sshinput, Just reponame) -> sshConfigurator $ do (Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
case result of case result of
FormSuccess sshinput' FormSuccess sshinput'
| isRsyncNet (inputHostname sshinput') -> | isRsyncNet (inputHostname sshinput') ->
void $ lift $ makeRsyncNet sshinput' reponame (const noop) void $ handlerToWidget $ makeRsyncNet sshinput' reponame (const noop)
| otherwise -> do | otherwise -> do
s <- liftIO $ testServer sshinput' s <- liftIO $ testServer sshinput'
case s of case s of
@ -156,7 +156,7 @@ postEnableRsyncR u = do
showform form enctype status = do showform form enctype status = do
description <- liftAnnex $ T.pack <$> prettyUUID u description <- liftAnnex $ T.pack <$> prettyUUID u
$(widgetFile "configurators/ssh/enable") $(widgetFile "configurators/ssh/enable")
enable sshdata = lift $ redirect $ ConfirmSshR $ enable sshdata = handlerToWidget $ redirect $ ConfirmSshR $
sshdata { rsyncOnly = True } sshdata { rsyncOnly = True }
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync {- 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 :: WebDAVInput -> CredPair
toCredPair input = (T.unpack $ user input, T.unpack $ password input) 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 boxComAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" (T.pack . fst <$> defcreds) <$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds) <*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
@ -51,7 +51,7 @@ boxComAForm defcreds = WebDAVInput
<*> areq textField "Directory" (Just "annex") <*> areq textField "Directory" (Just "annex")
<*> enableEncryptionField <*> enableEncryptionField
webDAVCredsAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput webDAVCredsAForm :: Maybe CredPair -> AForm Handler WebDAVInput
webDAVCredsAForm defcreds = WebDAVInput webDAVCredsAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" (T.pack . fst <$> defcreds) <$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Password" (T.pack . snd <$> defcreds) <*> areq passwordField "Password" (T.pack . snd <$> defcreds)
@ -65,10 +65,10 @@ postAddBoxComR :: Handler RepHtml
#ifdef WITH_WEBDAV #ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com" defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ boxComAForm defcreds runFormPost $ renderBootstrap $ boxComAForm defcreds
case result of case result of
FormSuccess input -> lift $ FormSuccess input -> handlerToWidget $
makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
[ configureEncryption $ enableEncryption input [ configureEncryption $ enableEncryption input
, ("embedcreds", if embedCreds input then "yes" else "no") , ("embedcreds", if embedCreds input then "yes" else "no")
@ -99,7 +99,7 @@ postEnableWebDAVR uuid = do
mcreds <- liftAnnex $ mcreds <- liftAnnex $
getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid) getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
case mcreds of case mcreds of
Just creds -> webDAVConfigurator $ lift $ Just creds -> webDAVConfigurator $ handlerToWidget $
makeWebDavRemote name creds (const noop) M.empty makeWebDavRemote name creds (const noop) M.empty
Nothing Nothing
| "box.com/" `isInfixOf` url -> | "box.com/" `isInfixOf` url ->
@ -111,10 +111,10 @@ postEnableWebDAVR uuid = do
defcreds <- liftAnnex $ defcreds <- liftAnnex $
maybe (pure Nothing) previouslyUsedWebDAVCreds $ maybe (pure Nothing) previouslyUsedWebDAVCreds $
urlHost url urlHost url
((result, form), enctype) <- lift $ ((result, form), enctype) <- handlerToWidget $
runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
case result of case result of
FormSuccess input -> lift $ FormSuccess input -> handlerToWidget $
makeWebDavRemote name (toCredPair input) (const noop) M.empty makeWebDavRemote name (toCredPair input) (const noop) M.empty
_ -> do _ -> do
description <- liftAnnex $ description <- liftAnnex $

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

@ -110,13 +110,13 @@ postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
xmppform :: Route WebApp -> Handler RepHtml xmppform :: Route WebApp -> Handler RepHtml
#ifdef WITH_XMPP #ifdef WITH_XMPP
xmppform next = xmppPage $ do xmppform next = xmppPage $ do
((result, form), enctype) <- lift $ do ((result, form), enctype) <- handlerToWidget $ do
oldcreds <- liftAnnex getXMPPCreds oldcreds <- liftAnnex getXMPPCreds
runFormPost $ renderBootstrap $ xmppAForm $ runFormPost $ renderBootstrap $ xmppAForm $
creds2Form <$> oldcreds creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp") let showform problem = $(widgetFile "configurators/xmpp")
case result of case result of
FormSuccess f -> either (showform . Just) (lift . storecreds) FormSuccess f -> either (showform . Just) (handlerToWidget . storecreds)
=<< liftIO (validateForm f) =<< liftIO (validateForm f)
_ -> showform Nothing _ -> showform Nothing
where where
@ -171,12 +171,12 @@ data XMPPForm = XMPPForm
creds2Form :: XMPPCreds -> XMPPForm creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c) creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
xmppAForm :: (Maybe XMPPForm) -> AForm WebApp WebApp XMPPForm xmppAForm :: (Maybe XMPPForm) -> AForm Handler XMPPForm
xmppAForm def = XMPPForm xmppAForm def = XMPPForm
<$> areq jidField "Jabber address" (formJID <$> def) <$> areq jidField "Jabber address" (formJID <$> def)
<*> areq passwordField "Password" Nothing <*> areq passwordField "Password" Nothing
jidField :: Field WebApp WebApp Text jidField :: Field Handler Text
jidField = checkBool (isJust . parseJID) bad textField jidField = checkBool (isJust . parseJID) bad textField
where where
bad :: Text bad :: Text

4
Assistant/WebApp/DashBoard.hs
View file

@ -30,8 +30,8 @@ import Control.Concurrent
{- A display of currently running and queued transfers. -} {- A display of currently running and queued transfers. -}
transfersDisplay :: Bool -> Widget transfersDisplay :: Bool -> Widget
transfersDisplay warnNoScript = do transfersDisplay warnNoScript = do
webapp <- lift getYesod webapp <- handlerToWidget getYesod
current <- lift $ M.toList <$> getCurrentTransfers current <- handlerToWidget $ M.toList <$> getCurrentTransfers
queued <- take 10 <$> liftAssistant getTransferQueue queued <- take 10 <$> liftAssistant getTransferQueue
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int) autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued 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. - 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 textField = F.textField
{ fieldView = \theId name attrs val _isReq -> [whamlet| { fieldView = \theId name attrs val _isReq -> [whamlet|
<input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}"> <input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}">
@ -32,7 +32,7 @@ textField = F.textField
} }
{- Also without required attribute. -} {- 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 passwordField = F.passwordField
{ fieldView = \theId name attrs val _isReq -> toWidget [hamlet| { fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
<input id="#{theId}" name="#{name}" *{attrs} type="password" value="#{either id id val}"> <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. -} {- 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 } withNote field note = field { fieldView = newview }
where where
newview theId name attrs val isReq = newview theId name attrs val isReq =
@ -48,7 +48,7 @@ withNote field note = field { fieldView = newview }
in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|] in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|]
{- Note that the toggle string must be unique on the form. -} {- 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| withExpandableNote field (toggle, note) = withNote field $ [whamlet|
<a .btn data-toggle="collapse" data-target="##{ident}"> <a .btn data-toggle="collapse" data-target="##{ident}">
#{toggle} #{toggle}
@ -62,7 +62,7 @@ data EnableEncryption = SharedEncryption | NoEncryption
deriving (Eq) deriving (Eq)
{- Adds a check box to an AForm to control encryption. -} {- 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) enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just SharedEncryption)
where where
choices :: [(Text, EnableEncryption)] 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_mouse_js
addScript $ StaticR jquery_ui_sortable_js addScript $ StaticR jquery_ui_sortable_js
repolist <- lift $ repoList reposelector repolist <- handlerToWidget $ repoList reposelector
let addmore = nudgeAddMore reposelector let addmore = nudgeAddMore reposelector
let nootherrepos = length repolist < 2 let nootherrepos = length repolist < 2

6
Assistant/WebApp/SideBar.hs
View file

@ -28,7 +28,7 @@ sideBarDisplay :: Widget
sideBarDisplay = do sideBarDisplay = do
let content = do let content = do
{- Add newest alerts to the sidebar. -} {- Add newest alerts to the sidebar. -}
alertpairs <- lift $ M.toList . alertMap alertpairs <- handlerToWidget $ M.toList . alertMap
<$> liftAssistant getDaemonStatus <$> liftAssistant getDaemonStatus
mapM_ renderalert $ mapM_ renderalert $
take displayAlerts $ reverse $ sortAlertPairs alertpairs take displayAlerts $ reverse $ sortAlertPairs alertpairs
@ -92,7 +92,7 @@ getClickAlert i = do
redirect $ buttonUrl b redirect $ buttonUrl b
_ -> redirectBack _ -> redirectBack
htmlIcon :: AlertIcon -> GWidget WebApp WebApp () htmlIcon :: AlertIcon -> Widget
htmlIcon ActivityIcon = [whamlet|<img src="@{StaticR activityicon_gif}" alt="">|] htmlIcon ActivityIcon = [whamlet|<img src="@{StaticR activityicon_gif}" alt="">|]
htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|] htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|]
htmlIcon InfoIcon = bootstrapIcon "info-sign" htmlIcon InfoIcon = bootstrapIcon "info-sign"
@ -101,5 +101,5 @@ htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
-- utf-8 umbrella (utf-8 cloud looks too stormy) -- utf-8 umbrella (utf-8 cloud looks too stormy)
htmlIcon TheCloud = [whamlet|&#9730;|] htmlIcon TheCloud = [whamlet|&#9730;|]
bootstrapIcon :: Text -> GWidget sub master () bootstrapIcon :: Text -> Widget
bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|] 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 - When the webapp is run outside a git-annex repository, the fallback
- value is returned. - 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) liftAnnexOr fallback a = ifM (noAnnex <$> getYesod)
( return fallback ( return fallback
, liftAssistant $ liftAnnex a , liftAssistant $ liftAnnex a
) )
instance LiftAnnex (GHandler sub WebApp) where instance LiftAnnex Handler where
liftAnnex = liftAnnexOr $ error "internal runAnnex" liftAnnex = liftAnnexOr $ error "internal liftAnnex"
instance LiftAnnex (GWidget WebApp WebApp) where instance LiftAnnex (WidgetT WebApp IO) where
liftAnnex = lift . liftAnnex liftAnnex = handlerToWidget . liftAnnex
class LiftAssistant m where class LiftAssistant m where
liftAssistant :: Assistant a -> m a liftAssistant :: Assistant a -> m a
instance LiftAssistant (GHandler sub WebApp) where instance LiftAssistant Handler where
liftAssistant a = liftIO . flip runAssistant a liftAssistant a = liftIO . flip runAssistant a
=<< assistantData <$> getYesod =<< assistantData <$> getYesod
instance LiftAssistant (GWidget WebApp WebApp) where instance LiftAssistant (WidgetT WebApp IO) where
liftAssistant = lift . liftAssistant liftAssistant = handlerToWidget . liftAssistant
type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget) type Form x = MForm Handler (FormResult x, Widget)
data RepoSelector = RepoSelector data RepoSelector = RepoSelector
{ onlyCloud :: Bool { 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 {- Rather than storing a session key on disk, use a random key
- that will only be valid for this run of the webapp. -} - 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 webAppSessionBackend _ = do
g <- newGenIO :: IO SystemRandom g <- newGenIO :: IO SystemRandom
case genBytes 96 g of case genBytes 96 g of
@ -189,6 +189,10 @@ webAppSessionBackend _ = do
where where
timeout = 120 * 60 -- 120 minutes timeout = 120 * 60 -- 120 minutes
use key = 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) #if MIN_VERSION_yesod(1,1,7)
Just . Yesod.clientSessionBackend2 key . fst Just . Yesod.clientSessionBackend2 key . fst
<$> Yesod.clientSessionDateCacher timeout <$> Yesod.clientSessionDateCacher timeout
@ -196,6 +200,7 @@ webAppSessionBackend _ = do
return $ Just $ return $ Just $
Yesod.clientSessionBackend key timeout Yesod.clientSessionBackend key timeout
#endif #endif
#endif
{- Generates a random sha512 string, suitable to be used for an {- Generates a random sha512 string, suitable to be used for an
- authentication secret. -} - authentication secret. -}
@ -213,7 +218,7 @@ genRandomToken = do
- Note that the usual Yesod error page is bypassed on error, to avoid - Note that the usual Yesod error page is bypassed on error, to avoid
- possibly leaking the auth token in urls on that page! - 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 checkAuthToken extractToken = do
webapp <- Yesod.getYesod webapp <- Yesod.getYesod
req <- Yesod.getRequest req <- Yesod.getRequest

2
git-annex.cabal
View file

@ -133,7 +133,7 @@ Executable git-annex
if flag(Webapp) if flag(Webapp)
Build-Depends: 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, case-insensitive, http-types, transformers, wai, wai-logger, warp,
blaze-builder, crypto-api, hamlet, clientsession, aeson, blaze-builder, crypto-api, hamlet, clientsession, aeson,
template-haskell, data-default template-haskell, data-default