2012-07-26 01:26:13 +00:00
|
|
|
{- git-annex assistant webapp
|
|
|
|
|
-
|
|
|
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
|
|
|
-
|
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
|
-}
|
|
|
|
|
|
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-}
|
|
|
|
|
|
|
|
|
|
module Assistant.Threads.WebApp where
|
|
|
|
|
|
|
|
|
|
import Assistant.Common
|
2012-07-26 03:13:01 +00:00
|
|
|
import Assistant.ThreadedMonad
|
2012-07-26 01:26:13 +00:00
|
|
|
import Assistant.DaemonStatus
|
|
|
|
|
import Utility.WebApp
|
|
|
|
|
|
|
|
|
|
import Yesod
|
2012-07-26 03:13:01 +00:00
|
|
|
import Network.Socket (PortNumber)
|
2012-07-26 01:26:13 +00:00
|
|
|
|
|
|
|
|
data WebApp = WebApp DaemonStatusHandle
|
|
|
|
|
|
|
|
|
|
mkYesod "WebApp" [parseRoutes|
|
|
|
|
|
/ HomeR GET
|
|
|
|
|
/config ConfigR GET
|
|
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
instance Yesod WebApp
|
|
|
|
|
|
|
|
|
|
getHomeR :: Handler RepHtml
|
|
|
|
|
getHomeR = defaultLayout [whamlet|Hello, World<p><a href=@{ConfigR}>config|]
|
|
|
|
|
|
|
|
|
|
getConfigR :: Handler RepHtml
|
|
|
|
|
getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|]
|
|
|
|
|
|
2012-07-26 03:13:01 +00:00
|
|
|
webAppThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
|
|
|
|
webAppThread st dstatus = do
|
2012-07-26 01:26:13 +00:00
|
|
|
app <- toWaiApp (WebApp dstatus)
|
|
|
|
|
app' <- ifM debugEnabled
|
|
|
|
|
( return $ httpDebugLogger app
|
|
|
|
|
, return app
|
|
|
|
|
)
|
2012-07-26 03:13:01 +00:00
|
|
|
runWebApp app' $ \p -> runThreadState st $ writeHtmlShim p
|
|
|
|
|
|
|
|
|
|
{- Creates a html shim file that's used to redirect into the webapp. -}
|
|
|
|
|
writeHtmlShim :: PortNumber -> Annex ()
|
|
|
|
|
writeHtmlShim port = do
|
|
|
|
|
htmlshim <- fromRepo gitAnnexHtmlShim
|
|
|
|
|
liftIO $ writeFile htmlshim $ genHtmlShim port
|
|
|
|
|
|
|
|
|
|
{- TODO: generate this static file using Yesod. -}
|
|
|
|
|
genHtmlShim :: PortNumber -> String
|
|
|
|
|
genHtmlShim port = unlines
|
|
|
|
|
[ "<html>"
|
|
|
|
|
, "<head>"
|
|
|
|
|
, "<meta http-equiv=\"refresh\" content=\"0; URL=" ++ url ++ "\">"
|
|
|
|
|
, "</head>"
|
|
|
|
|
, "<body>"
|
|
|
|
|
, "<p>"
|
|
|
|
|
, "<a href=\"" ++ url ++ "\">Starting webapp...</a>"
|
|
|
|
|
, "</p>"
|
|
|
|
|
, "</body>"
|
|
|
|
|
]
|
2012-07-26 01:26:13 +00:00
|
|
|
where
|
2012-07-26 03:13:01 +00:00
|
|
|
url = "http://localhost:" ++ show port ++ "/"
|
