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.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
	-> Maybe (IO String)
	-> Maybe (Url -> FilePath -> IO ())
	-> NamedThread
webAppThread mst dstatus scanremotes transferqueue transferslots 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
	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 "/") 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 "/"

myUrl :: WebApp -> PortNumber -> FilePath -> Url
myUrl webapp port page = "http://localhost:" ++ show port ++ page ++
	"?auth=" ++ unpack (secretToken webapp)
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`
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`
			`:: (Maybe ThreadState)`
			`-> 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`
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`
			`webAppThread mst dstatus scanremotes transferqueue transferslots 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`
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`
			`)`
webapp now starts up when run not in a git repo 2012-07-31 16:17:31 +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`
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			`maybe noop (\a -> a (myUrl webapp port "/") 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`
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			`url = myUrl webapp port "/"`
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
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			`myUrl :: WebApp -> PortNumber -> FilePath -> Url`
			`myUrl webapp port page = "http://localhost:" ++ show port ++ page ++`
			`"?auth=" ++ unpack (secretToken webapp)`