e213ef310f
* Fix minor FD leak in journal code. Closes: #754608 * direct: Fix handling of case where a work tree subdirectory cannot be written to due to permissions. * migrate: Avoid re-checksumming when migrating from hashE to hash backend. * uninit: Avoid failing final removal in some direct mode repositories due to file modes. * S3: Deal with AWS ACL configurations that do not allow creating or checking the location of a bucket, but only reading and writing content to it. * resolvemerge: New plumbing command that runs the automatic merge conflict resolver. * Deal with change in git 2.0 that made indirect mode merge conflict resolution leave behind old files. * sync: Fix git sync with local git remotes even when they don't have an annex.uuid set. (The assistant already did so.) * Set gcrypt-publish-participants when setting up a gcrypt repository, to avoid unncessary passphrase prompts. This is a security/usability tradeoff. To avoid exposing the gpg key ids who can decrypt the repository, users can unset gcrypt-publish-participants. * Install nautilus hooks even when ~/.local/share/nautilus/ does not yet exist, since it is not automatically created for Gnome 3 users. * Windows: Move .vbs files out of git\bin, to avoid that being in the PATH, which caused some weird breakage. (Thanks, divB) * Windows: Fix locking issue that prevented the webapp starting (since 5.20140707). # imported from the archive
74 lines
2.5 KiB
Haskell
74 lines
2.5 KiB
Haskell
{- git-annex assistant webapp core
|
|
-
|
|
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
|
|
|
module Assistant.WebApp where
|
|
|
|
import Assistant.WebApp.Types
|
|
import Assistant.Common
|
|
import Utility.NotificationBroadcaster
|
|
import Utility.Yesod
|
|
import Utility.WebApp
|
|
|
|
import Data.Text (Text)
|
|
import Control.Concurrent
|
|
import qualified Network.Wai as W
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import qualified Data.Text as T
|
|
|
|
waitNotifier :: Assistant NotificationBroadcaster -> NotificationId -> Handler ()
|
|
waitNotifier getbroadcaster nid = liftAssistant $ do
|
|
b <- getbroadcaster
|
|
liftIO $ waitNotification $ notificationHandleFromId b nid
|
|
|
|
newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId
|
|
newNotifier getbroadcaster = liftAssistant $ do
|
|
b <- getbroadcaster
|
|
liftIO $ notificationHandleToId <$> newNotificationHandle True b
|
|
|
|
{- Adds the auth parameter as a hidden field on a form. Must be put into
|
|
- every form. -}
|
|
webAppFormAuthToken :: Widget
|
|
webAppFormAuthToken = do
|
|
webapp <- liftH getYesod
|
|
[whamlet|<input type="hidden" name="auth" value="#{fromAuthToken (authToken webapp)}">|]
|
|
|
|
{- A button with an icon, and maybe label or tooltip, that can be
|
|
- clicked to perform some action.
|
|
- With javascript, clicking it POSTs the Route, and remains on the same
|
|
- page.
|
|
- With noscript, clicking it GETs the Route. -}
|
|
actionButton :: Route WebApp -> (Maybe String) -> (Maybe String) -> String -> String -> Widget
|
|
actionButton route label tooltip buttonclass iconclass = $(widgetFile "actionbutton")
|
|
|
|
type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text
|
|
type UrlRenderer = MVar (UrlRenderFunc)
|
|
|
|
newUrlRenderer :: IO UrlRenderer
|
|
newUrlRenderer = newEmptyMVar
|
|
|
|
setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO ()
|
|
setUrlRenderer = putMVar
|
|
|
|
inFirstRun :: Handler Bool
|
|
inFirstRun = isNothing . relDir <$> getYesod
|
|
|
|
{- Blocks until the webapp is running and has called setUrlRenderer. -}
|
|
renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text
|
|
renderUrl urlrenderer route params = do
|
|
r <- readMVar urlrenderer
|
|
return $ r route params
|
|
|
|
{- Redirects back to the referring page, or if there's none, DashboardR -}
|
|
redirectBack :: Handler ()
|
|
redirectBack = do
|
|
mr <- lookup "referer" . W.requestHeaders <$> waiRequest
|
|
case mr of
|
|
Nothing -> redirect DashboardR
|
|
Just r -> redirect $ T.pack $ S8.unpack r
|