split up webapp files

1 files changed, 7 insertions, 297 deletions

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 79a388463..7b794b6eb 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -11,321 +11,31 @@
 module Assistant.Threads.WebApp where
 
 import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.DashBoard
+import Assistant.WebApp.SideBar
+import Assistant.WebApp.Notifications
+import Assistant.WebApp.Configurators
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
-import Assistant.Alert hiding (Widget)
-import Utility.NotificationBroadcaster
 import Utility.WebApp
 import Utility.Yesod
 import Utility.FileMode
 import Utility.TempFile
 import Git
-import Logs.Transfer
-import Utility.Percentage
-import Utility.DataUnits
-import Types.Key
-import qualified Remote
-import Logs.Web (webUUID)
-import Logs.Trust
-import Annex.UUID (getUUID)
 
 import Yesod
 import Yesod.Static
 import Text.Hamlet
 import Network.Socket (PortNumber)
 import Text.Blaze.Renderer.String
-import Data.Text (Text, pack, unpack)
-import qualified Data.Text as T
-import qualified Data.Map as M
-import Control.Concurrent.STM
+import Data.Text (pack, unpack)
 
 thisThread :: String
 thisThread = "WebApp"
 
-data WebApp = WebApp
-	{ threadState :: ThreadState
-	, daemonStatus :: DaemonStatusHandle
-	, transferQueue :: TransferQueue
-	, secretToken :: Text
-	, relDir :: FilePath
-	, getStatic :: Static
-	, webAppState :: TMVar WebAppState
-	}
-
-data WebAppState = WebAppState
-	{ showIntro :: Bool
-	}
-
-newWebAppState :: IO (TMVar WebAppState)
-newWebAppState = liftIO $ atomically $
-	newTMVar $ WebAppState { showIntro = True }
-
-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
-	where
-		go s = liftIO $ atomically $ do
-			v <- takeTMVar s
-			putTMVar s $ a v
-
-waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
-waitNotifier selector nid = do
-	notifier <- getNotifier selector
-	liftIO $ waitNotification $ notificationHandleFromId notifier nid
-
-newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId
-newNotifier selector = do
-	notifier <- getNotifier selector
-	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
-
-getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
-getNotifier selector = do
-	webapp <- getYesod
-	liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
-
-staticFiles "static"
-
-mkYesod "WebApp" [parseRoutes|
-/ HomeR GET
-/noscript NoScriptR GET
-/noscriptauto NoScriptAutoR GET
-/transfers/#NotificationId TransfersR GET
-/sidebar/#NotificationId SideBarR GET
-/notifier/transfers NotifierTransfersR GET
-/notifier/sidebar NotifierSideBarR GET
-/closealert/#AlertId CloseAlert GET
-/config ConfigR GET
-/addrepository AddRepositoryR GET
-/static StaticR Static getStatic
-|]
-
-instance PathPiece NotificationId where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
-instance PathPiece AlertId where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
-instance Yesod WebApp where
-	defaultLayout content = do
-		webapp <- getYesod
-		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")
-
-	{- Require an auth token be set when accessing any (non-static route) -}
-	isAuthorized _ _ = checkAuthToken secretToken
-
-	{- Add the auth token to every url generated, except static subsite
-         - urls (which can show up in Permission Denied pages). -}
-	joinPath = insertAuthToken secretToken excludeStatic
-		where
-			excludeStatic [] = True
-			excludeStatic (p:_) = p /= "static"
-
-	makeSessionBackend = webAppSessionBackend
-	jsLoader _ = BottomOfHeadBlocking
-
-{- Add to any widget to make it auto-update using long polling.
- -
- - The widget should have a html element with an id=ident, which will be
- - replaced when it's updated.
- -
- - The geturl route should return the notifier url to use for polling.
- -
- - ms_delay is how long to delay between AJAX updates
- - ms_startdelay is how long to delay before updating with AJAX at the start
- -}
-autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
-autoUpdate ident geturl ms_delay ms_startdelay = do
-	let delay = show ms_delay
-	let startdelay = show ms_startdelay
-	addScript $ StaticR longpolling_js
-	$(widgetFile "longpolling")
-
-{- Notifier urls are requested by the javascript, to avoid allocation
- - of NotificationIds when noscript pages are loaded. This constructs a
- - notifier url for a given Route and NotificationBroadcaster.
- -}
-notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain
-notifierUrl route selector = do
-	(urlbits, _params) <- renderRoute . route <$> newNotifier selector
-	webapp <- getYesod
-	return $ RepPlain $ toContent $ T.concat
-		[ "/"
-		, T.intercalate "/" urlbits
-		, "?auth="
-		, secretToken webapp
-		]
-
-getNotifierTransfersR :: Handler RepPlain
-getNotifierTransfersR = notifierUrl TransfersR transferNotifier
-
-getNotifierSideBarR :: Handler RepPlain
-getNotifierSideBarR = notifierUrl SideBarR alertNotifier
-
-{- A display of currently running and queued transfers.
- -
- - Or, if there have never been any this run, an intro display. -}
-transfersDisplay :: Bool -> Widget
-transfersDisplay warnNoScript = do
-	webapp <- lift getYesod
-	current <- liftIO $ runThreadState (threadState webapp) $
-		M.toList . currentTransfers
-			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
-	queued <- liftIO $ getTransferQueue $ transferQueue webapp
-	let ident = "transfers"
-	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
-	let transfers = current ++ queued
-	if null transfers
-		then ifM (lift $ showIntro <$> getWebAppState)
-			( introDisplay ident
-			, $(widgetFile "transfers")
-			)
-		else $(widgetFile "transfers")
-
-{- An intro message, and list of repositories. -}
-introDisplay :: Text -> Widget
-introDisplay ident = do
-	webapp <- lift getYesod
-	let reldir = relDir webapp
-	l <- liftIO $ runThreadState (threadState webapp) $ do
-		u <- getUUID
-		rs <- map Remote.uuid <$> Remote.remoteList
-		rs' <- snd <$> trustPartition DeadTrusted rs
-		Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
-	let remotelist = zip counter l
-	let n = length l
-	let numrepos = show n
-	let notenough = n < 2
-	let barelyenough = n == 2
-	let morethanenough = n > 2
-	$(widgetFile "intro")
-	lift $ modifyWebAppState $ \s -> s { showIntro = False }
-	where
-		counter = map show ([1..] :: [Int])
-
-{- Called by client to get a display of currently in process transfers.
- -
- - Returns a div, which will be inserted into the calling page.
- -
- - Note that the head of the widget is not included, only its
- - body is. To get the widget head content, the widget is also 
- - inserted onto the getHomeR page.
- -}
-getTransfersR :: NotificationId -> Handler RepHtml
-getTransfersR nid = do
-	waitNotifier transferNotifier nid
-
-	page <- widgetToPageContent $ transfersDisplay False
-	hamletToRepHtml $ [hamlet|^{pageBody page}|]
-
-sideBarDisplay :: Widget
-sideBarDisplay = do
-	let content = do
-		{- Any yesod message appears as the first alert. -}
-		maybe noop rendermessage =<< lift getMessage
-	
-		{- Add newest alerts to the sidebar. -}
-		webapp <- lift getYesod
-		alertpairs <- M.toList . alertMap
-			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
-		mapM_ renderalert $
-			take displayAlerts $ reverse $ sortAlertPairs alertpairs
-	let ident = "sidebar"
-	$(widgetFile "sidebar")
-	autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
-	where
-		bootstrapclass Activity = "alert-info"
-		bootstrapclass Warning = "alert"
-		bootstrapclass Error = "alert-error"
-		bootstrapclass Success = "alert-success"
-		bootstrapclass Message = "alert-info"
-
-		renderalert (alertid, alert) = addalert
-			alertid
-			(alertClosable alert)
-			(alertBlockDisplay alert)
-			(bootstrapclass $ alertClass alert)
-			(alertHeader alert)
-			$ case alertMessage alert of
-				StringAlert s -> [whamlet|#{s}|]
-				WidgetAlert w -> w alert
-
-		rendermessage msg = addalert firstAlertId True False
-			"alert-info" Nothing [whamlet|#{msg}|]
-
-		addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
-		addalert i closable block divclass heading widget = do
-			let alertid = show i
-			let closealert = CloseAlert i
-			$(widgetFile "alert")
-
-{- Called by client to get a sidebar display.
- -
- - Returns a div, which will be inserted into the calling page.
- -
- - Note that the head of the widget is not included, only its
- - body is. To get the widget head content, the widget is also 
- - inserted onto all pages.
- -}
-getSideBarR :: NotificationId -> Handler RepHtml
-getSideBarR nid = do
-	waitNotifier alertNotifier nid
-
-	page <- widgetToPageContent sideBarDisplay
-	hamletToRepHtml $ [hamlet|^{pageBody page}|]
-
-{- Called by the client to close an alert. -}
-getCloseAlert :: AlertId -> Handler ()
-getCloseAlert i = do
-	webapp <- getYesod
-	void $ liftIO $ removeAlert (daemonStatus webapp) i
-
-{- The main dashboard. -}
-dashboard :: Bool -> Widget
-dashboard warnNoScript = do
-	sideBarDisplay
-	let content = transfersDisplay warnNoScript
-	$(widgetFile "dashboard")
-
-getHomeR :: Handler RepHtml
-getHomeR = defaultLayout $ dashboard True
-
-{- Same as HomeR, except with autorefreshing via meta refresh. -}
-getNoScriptAutoR :: Handler RepHtml
-getNoScriptAutoR = defaultLayout $ do
-	let ident = NoScriptR
-	let delayseconds = 3 :: Int
-	let this = NoScriptAutoR
-	toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
-	dashboard False
-
-{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
-getNoScriptR :: Handler RepHtml
-getNoScriptR = defaultLayout $
-	dashboard False
-
-getConfigR :: Handler RepHtml
-getConfigR = defaultLayout $ do
-	sideBarDisplay
-	setTitle "Configuration"
-	[whamlet|<a href="@{HomeR}">main|]
-
-getAddRepositoryR :: Handler RepHtml
-getAddRepositoryR = defaultLayout $ do
-	sideBarDisplay
-	setTitle "Add repository"
-	[whamlet|<a href="@{HomeR}">main|]
+mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 
 webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO ()
 webAppThread st dstatus transferqueue onstartup = do