git-annex/Assistant/WebApp.hs

156 lines
4.9 KiB
Haskell
Raw Normal View History

{- git-annex assistant webapp core
2012-07-31 05:11:32 +00:00
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
2012-07-31 05:11:32 +00:00
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp where
import Assistant.WebApp.Types
2012-07-31 05:11:32 +00:00
import Assistant.Common
import Utility.NotificationBroadcaster
import Utility.Yesod
import Locations.UserConfig
2012-07-31 05:11:32 +00:00
import Yesod
import Text.Hamlet
import Data.Text (Text)
2012-07-31 05:11:32 +00:00
import Control.Concurrent.STM
import Control.Concurrent
2012-07-31 05:11:32 +00:00
data NavBarItem = DashBoard | Config | About
deriving (Eq)
navBarName :: NavBarItem -> Text
navBarName DashBoard = "Dashboard"
navBarName Config = "Configuration"
navBarName About = "About"
navBarRoute :: NavBarItem -> Route WebApp
navBarRoute DashBoard = HomeR
navBarRoute Config = ConfigR
navBarRoute About = AboutR
2012-07-31 05:11:32 +00:00
2012-07-31 18:23:17 +00:00
defaultNavBar :: [NavBarItem]
defaultNavBar = [DashBoard, Config, About]
firstRunNavBar :: [NavBarItem]
firstRunNavBar = [Config, About]
selectNavBar :: Handler [NavBarItem]
selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod
{- Used instead of defaultContent; highlights the current page if it's
- on the navbar. -}
bootstrap :: Maybe NavBarItem -> Widget -> Handler RepHtml
bootstrap navbaritem content = do
webapp <- getYesod
2012-07-31 18:23:17 +00:00
navbar <- map navdetails <$> selectNavBar
page <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
addStylesheet $ StaticR css_bootstrap_responsive_css
addScript $ StaticR jquery_full_js
addScript $ StaticR js_bootstrap_dropdown_js
addScript $ StaticR js_bootstrap_modal_js
$(widgetFile "page")
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
2012-10-31 06:34:03 +00:00
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
2012-07-31 05:11:32 +00:00
newWebAppState :: IO (TMVar WebAppState)
newWebAppState = do
otherrepos <- listOtherRepos
atomically $ newTMVar $ WebAppState
{ showIntro = True
, otherRepos = otherrepos }
2012-07-31 05:11:32 +00:00
liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a
liftAssistant a = liftIO . runAssistant a =<< assistantData <$> getYesod
2012-07-31 05:11:32 +00:00
getWebAppState :: forall sub. GHandler sub WebApp WebAppState
getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp ()
modifyWebAppState a = go =<< webAppState <$> getYesod
2012-10-31 06:34:03 +00:00
where
go s = liftIO $ atomically $ do
v <- takeTMVar s
putTMVar s $ a v
2012-07-31 05:11:32 +00:00
{- Runs an Annex action from the webapp.
-
- When the webapp is run outside a git-annex repository, the fallback
- value is returned.
-}
runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a
runAnnex fallback a = ifM (noAnnex <$> getYesod)
( return fallback
, liftAssistant $ liftAnnex a
)
2012-11-03 01:13:06 +00:00
waitNotifier :: forall sub. (Assistant NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
waitNotifier getbroadcaster nid = liftAssistant $ do
b <- getbroadcaster
liftIO $ waitNotification $ notificationHandleFromId b nid
2012-07-31 05:11:32 +00:00
2012-11-03 01:13:06 +00:00
newNotifier :: forall sub. (Assistant NotificationBroadcaster) -> GHandler sub WebApp NotificationId
newNotifier getbroadcaster = liftAssistant $ do
b <- getbroadcaster
liftIO $ notificationHandleToId <$> newNotificationHandle b
2012-07-31 05:11:32 +00:00
{- Adds the auth parameter as a hidden field on a form. Must be put into
- every form. -}
webAppFormAuthToken :: Widget
webAppFormAuthToken = do
webapp <- lift getYesod
[whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
2012-08-08 21:07:38 +00:00
2012-09-27 16:55:00 +00:00
{- A button with an icon, and maybe label or tooltip, that can be
- clicked to perform some action.
2012-08-08 21:07:38 +00:00
- With javascript, clicking it POSTs the Route, and remains on the same
- page.
- With noscript, clicking it GETs the Route. -}
2012-09-27 16:55:00 +00:00
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
{- 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, HomeR -}
redirectBack :: Handler ()
redirectBack = do
clearUltDest
setUltDestReferer
redirectUltDest HomeR
{- List of other known repsitories, and link to add a new one. -}
otherReposWidget :: Widget
otherReposWidget = do
repolist <- lift $ otherRepos <$> getWebAppState
$(widgetFile "otherrepos")
listOtherRepos :: IO [(String, String)]
listOtherRepos = do
f <- autoStartFile
dirs <- nub <$> ifM (doesFileExist f) ( lines <$> readFile f, return [])
names <- mapM relHome dirs
return $ sort $ zip names dirs