git-annex/Assistant/Threads/WebApp.hs

{- git-annex assistant webapp thread
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Assistant.Threads.WebApp where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.DashBoard
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Documentation
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.TransferSlots
import Utility.WebApp
import Utility.FileMode
import Utility.TempFile
import Git

import Yesod
import Yesod.Static
import Network.Socket (PortNumber)
import Data.Text (pack, unpack)

thisThread :: String
thisThread = "WebApp"

mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")

type Url = String

webAppThread 
	:: Maybe ThreadState
	-> DaemonStatusHandle
	-> ScanRemoteMap
	-> TransferQueue
	-> TransferSlots
	-> UrlRenderer
	-> Maybe (IO String)
	-> Maybe (Url -> FilePath -> IO ())
	-> NamedThread
webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer postfirstrun onstartup = thread $ do
	webapp <- WebApp
		<$> pure mst
		<*> pure dstatus
		<*> pure scanremotes
		<*> pure transferqueue
		<*> pure transferslots
		<*> (pack <$> genRandomToken)
		<*> getreldir mst
		<*> pure $(embed "static")
		<*> newWebAppState
		<*> pure postfirstrun
	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
	app <- toWaiAppPlain webapp
	app' <- ifM debugEnabled
		( return $ httpDebugLogger app
		, return app
		)
	runWebApp app' $ \port -> case mst of
		Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
		Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
	where
		thread = NamedThread thisThread
		getreldir Nothing = return Nothing
		getreldir (Just st) = Just <$>
			(relHome =<< absPath
				=<< runThreadState st (fromRepo repoPath))
		go port webapp htmlshim = do
			writeHtmlShim webapp port htmlshim
			maybe noop (\a -> a (myUrl webapp port HomeR) htmlshim) onstartup

{- Creates a html shim file that's used to redirect into the webapp,
 - to avoid exposing the secretToken when launching the web browser. -}
writeHtmlShim :: WebApp -> PortNumber -> FilePath -> IO ()
writeHtmlShim webapp port file = do
	debug thisThread ["running on port", show port]
	viaTmp go file $ genHtmlShim webapp port
	where
		go tmpfile content = do
			h <- openFile tmpfile WriteMode
			modifyFileMode tmpfile $ removeModes [groupReadMode, otherReadMode]
			hPutStr h content
			hClose h

{- TODO: generate this static file using Yesod. -}
genHtmlShim :: WebApp -> PortNumber -> String
genHtmlShim webapp port = unlines
	[ "<html>"
	, "<head>"
	, "<title>Starting webapp...</title>"
	, "<meta http-equiv=\"refresh\" content=\"0; URL="++url++"\">"
	, "<body>"
	, "<p>"
	, "<a href=\"" ++ url ++ "\">Starting webapp...</a>"
	, "</p>"
	, "</body>"
	, "</html>"
	]
	where
		url = myUrl webapp port HomeR

myUrl :: WebApp -> PortNumber -> Route WebApp -> Url
myUrl webapp port route = unpack $ yesodRender webapp urlbase route []
	where
		urlbase = pack $ "http://localhost:" ++ show port
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`{- git-annex assistant webapp thread`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00			`-`
			`- Copyright 2012 Joey Hess <joey@kitenet.net>`
			`-`
			`- Licensed under the GNU GPL version 3 or higher.`
			`-}`

refactor 2012-07-29 12:52:57 +00:00			`{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}`
add NotificationID to StatusR, and use it to block 2012-07-29 01:21:22 +00:00			`{-# OPTIONS_GHC -fno-warn-orphans #-}`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00
			`module Assistant.Threads.WebApp where`

			`import Assistant.Common`
split up webapp files 2012-07-31 05:11:32 +00:00			`import Assistant.WebApp`
add ssh confirmation page also broke out webapp types into a separate module 2012-09-02 04:27:48 +00:00			`import Assistant.WebApp.Types`
split up webapp files 2012-07-31 05:11:32 +00:00			`import Assistant.WebApp.DashBoard`
			`import Assistant.WebApp.SideBar`
			`import Assistant.WebApp.Notifications`
			`import Assistant.WebApp.Configurators`
split out local repo configurators 2012-08-31 19:17:12 +00:00			`import Assistant.WebApp.Configurators.Local`
			`import Assistant.WebApp.Configurators.Ssh`
yesod skelton and routes for pairing yet more changes to pairing message data types 2012-09-08 04:26:47 +00:00			`import Assistant.WebApp.Configurators.Pairing`
made navbar work also added an About page and a stub Config page. 2012-07-31 06:30:26 +00:00			`import Assistant.WebApp.Documentation`
git annex webapp now opens a browser to the webapp Also, starts the assistant if it wasn't already running. 2012-07-26 03:13:01 +00:00			`import Assistant.ThreadedMonad`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00			`import Assistant.DaemonStatus`
wire up scan and transfer to newly added removable drive remote setup still todo 2012-08-05 01:18:57 +00:00			`import Assistant.ScanRemotes`
webapp now displays the real running and queued transfers yowza!!! 2012-07-27 15:47:34 +00:00			`import Assistant.TransferQueue`
implement resuming of paused transfers Currently waits for a new transfer slot to open up, which probably needs to change.. 2012-08-12 16:11:20 +00:00			`import Assistant.TransferSlots`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00			`import Utility.WebApp`
generate random token and launch webapp using it 2012-07-26 07:38:20 +00:00			`import Utility.FileMode`
			`import Utility.TempFile`
added a custom defaultLayout, static site, and favicon Broke hamlet out into standalone files. I don't like the favicon display; it should be served from /favicon.ico, but I could only get the static site to serve /static/favicon.ico, so I had to use a <link rel=icon> to pull it in. I looked at Yesod.Default.Handlers.getFaviconR, but it doesn't seem to embed the favicon into the binary? 2012-07-26 06:45:01 +00:00			`import Git`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00
			`import Yesod`
added a custom defaultLayout, static site, and favicon Broke hamlet out into standalone files. I don't like the favicon display; it should be served from /favicon.ico, but I could only get the static site to serve /static/favicon.ico, so I had to use a <link rel=icon> to pull it in. I looked at Yesod.Default.Handlers.getFaviconR, but it doesn't seem to embed the favicon into the binary? 2012-07-26 06:45:01 +00:00			`import Yesod.Static`
git annex webapp now opens a browser to the webapp Also, starts the assistant if it wasn't already running. 2012-07-26 03:13:01 +00:00			`import Network.Socket (PortNumber)`
split up webapp files 2012-07-31 05:11:32 +00:00			`import Data.Text (pack, unpack)`
use the secret token for authentication, and add to all dynamic urls 2012-07-26 08:50:09 +00:00
			`thisThread :: String`
			`thisThread = "WebApp"`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00
split up webapp files 2012-07-31 05:11:32 +00:00			`mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00
implemented firstrun repository creation and redirection to full webapp Some of the trickiest code I've possibly ever written. 2012-08-01 20:10:26 +00:00			`type Url = String`

			`webAppThread`
hlint 2012-09-13 04:57:52 +00:00			`:: Maybe ThreadState`
implemented firstrun repository creation and redirection to full webapp Some of the trickiest code I've possibly ever written. 2012-08-01 20:10:26 +00:00			`-> DaemonStatusHandle`
wire up scan and transfer to newly added removable drive remote setup still todo 2012-08-05 01:18:57 +00:00			`-> ScanRemoteMap`
implemented firstrun repository creation and redirection to full webapp Some of the trickiest code I've possibly ever written. 2012-08-01 20:10:26 +00:00			`-> TransferQueue`
implement resuming of paused transfers Currently waits for a new transfer slot to open up, which probably needs to change.. 2012-08-12 16:11:20 +00:00			`-> TransferSlots`
first pass at alert buttons They work fine. But I had to go to a lot of trouble to get Yesod to render routes in a pure function. It may instead make more sense to have each alert have an assocated IO action, and a single route that runs the IO action of a given alert id. I just wish I'd realized that before the past several hours of struggling with something Yesod really doesn't want to allow. 2012-09-08 23:57:15 +00:00			`-> UrlRenderer`
implemented firstrun repository creation and redirection to full webapp Some of the trickiest code I've possibly ever written. 2012-08-01 20:10:26 +00:00			`-> Maybe (IO String)`
			`-> Maybe (Url -> FilePath -> IO ())`
display errors when any named thread crashes 2012-09-06 18:56:04 +00:00			`-> NamedThread`
first pass at alert buttons They work fine. But I had to go to a lot of trouble to get Yesod to render routes in a pure function. It may instead make more sense to have each alert have an assocated IO action, and a single route that runs the IO action of a given alert id. I just wish I'd realized that before the past several hours of struggling with something Yesod really doesn't want to allow. 2012-09-08 23:57:15 +00:00			`webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer postfirstrun onstartup = thread $ do`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`webapp <- WebApp`
			`<$> pure mst`
			`<*> pure dstatus`
wire up scan and transfer to newly added removable drive remote setup still todo 2012-08-05 01:18:57 +00:00			`<*> pure scanremotes`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`<*> pure transferqueue`
implement resuming of paused transfers Currently waits for a new transfer slot to open up, which probably needs to change.. 2012-08-12 16:11:20 +00:00			`<*> pure transferslots`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`<*> (pack <$> genRandomToken)`
			`<*> getreldir mst`
			`<*> pure $(embed "static")`
			`<*> newWebAppState`
implemented firstrun repository creation and redirection to full webapp Some of the trickiest code I've possibly ever written. 2012-08-01 20:10:26 +00:00			`<*> pure postfirstrun`
first pass at alert buttons They work fine. But I had to go to a lot of trouble to get Yesod to render routes in a pure function. It may instead make more sense to have each alert have an assocated IO action, and a single route that runs the IO action of a given alert id. I just wish I'd realized that before the past several hours of struggling with something Yesod really doesn't want to allow. 2012-09-08 23:57:15 +00:00			`setUrlRenderer urlrenderer $ yesodRender webapp (pack "")`
added jquery to static site Had to switch to toWaiAppPlain to avoid a seeming bug in toWaiApp; chromium only received a partial copy of jquery. Always the same length each time, which makes me think it's a bug in the compression, although a bug in the autohead middleware is also a possibility. Anyway, there's little need for compression for a local webapp. Not wasting time compressing things is probably a net gain. Similarly, I've not worried about minifying this yet. Although that would avoid bloating the git-annex binary quite so much. 2012-07-27 03:55:51 +00:00			`app <- toWaiAppPlain webapp`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00			`app' <- ifM debugEnabled`
			`( return $ httpDebugLogger app`
			`, return app`
			`)`
hlint 2012-09-13 04:57:52 +00:00			`runWebApp app' $ \port -> case mst of`
			`Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile`
			`Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)`
webapp now displays the real running and queued transfers yowza!!! 2012-07-27 15:47:34 +00:00			`where`
display errors when any named thread crashes 2012-09-06 18:56:04 +00:00			`thread = NamedThread thisThread`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`getreldir Nothing = return Nothing`
better ~/ handling 2012-08-02 11:47:50 +00:00			`getreldir (Just st) = Just <$>`
			`(relHome =<< absPath`
			`=<< runThreadState st (fromRepo repoPath))`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`go port webapp htmlshim = do`
			`writeHtmlShim webapp port htmlshim`
render webapp staitc file url using yesod 2012-09-09 00:03:06 +00:00			`maybe noop (\a -> a (myUrl webapp port HomeR) htmlshim) onstartup`
git annex webapp now opens a browser to the webapp Also, starts the assistant if it wasn't already running. 2012-07-26 03:13:01 +00:00
use the secret token for authentication, and add to all dynamic urls 2012-07-26 08:50:09 +00:00			`{- Creates a html shim file that's used to redirect into the webapp,`
			`- to avoid exposing the secretToken when launching the web browser. -}`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`writeHtmlShim :: WebApp -> PortNumber -> FilePath -> IO ()`
			`writeHtmlShim webapp port file = do`
			`debug thisThread ["running on port", show port]`
			`viaTmp go file $ genHtmlShim webapp port`
generate random token and launch webapp using it 2012-07-26 07:38:20 +00:00			`where`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +00:00			`go tmpfile content = do`
			`h <- openFile tmpfile WriteMode`
			`modifyFileMode tmpfile $ removeModes [groupReadMode, otherReadMode]`
generate random token and launch webapp using it 2012-07-26 07:38:20 +00:00			`hPutStr h content`
			`hClose h`
git annex webapp now opens a browser to the webapp Also, starts the assistant if it wasn't already running. 2012-07-26 03:13:01 +00:00
			`{- TODO: generate this static file using Yesod. -}`
generate random token and launch webapp using it 2012-07-26 07:38:20 +00:00			`genHtmlShim :: WebApp -> PortNumber -> String`
don't use hamlet for htmlshim This allows me to not build-depend on blaze-markup, which was causing me some trouble when tring to build with cabal on debian. Seems debian ships Text.Blaze.Renderer.String in two packages. 2012-08-02 01:26:36 +00:00			`genHtmlShim webapp port = unlines`
			`[ "<html>"`
			`, "<head>"`
			`, "<title>Starting webapp...</title>"`
			`, "<meta http-equiv=\"refresh\" content=\"0; URL="++url++"\">"`
			`, "<body>"`
			`, "<p>"`
			`, "<a href=\"" ++ url ++ "\">Starting webapp...</a>"`
			`, "</p>"`
			`, "</body>"`
			`, "</html>"`
			`]`
run yesod, and launch webapp on startup 2012-07-26 01:26:13 +00:00			`where`
render webapp staitc file url using yesod 2012-09-09 00:03:06 +00:00			`url = myUrl webapp port HomeR`
implemented firstrun repository creation and redirection to full webapp Some of the trickiest code I've possibly ever written. 2012-08-01 20:10:26 +00:00
render webapp staitc file url using yesod 2012-09-09 00:03:06 +00:00			`myUrl :: WebApp -> PortNumber -> Route WebApp -> Url`
			`myUrl webapp port route = unpack $ yesodRender webapp urlbase route []`
			`where`
			`urlbase = pack $ "http://localhost:" ++ show port`