diff options
| -rw-r--r-- | Assistant.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 55 | ||||
| -rw-r--r-- | Assistant/WebApp.hs | 2 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 1 | ||||
| -rw-r--r-- | Command/WebApp.hs | 31 | ||||
| -rw-r--r-- | templates/bootstrap.hamlet | 6 | ||||
| -rw-r--r-- | templates/configurators/intro.hamlet | 51 | ||||
| -rw-r--r-- | templates/page.hamlet | 21 |
8 files changed, 96 insertions, 75 deletions
diff --git a/Assistant.hs b/Assistant.hs index 22a87fe8c..4bb85975b 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -122,7 +122,7 @@ import Utility.ThreadScheduler import Control.Concurrent -startDaemon :: Bool -> Bool -> Maybe (IO ()) -> Annex () +startDaemon :: Bool -> Bool -> Maybe (FilePath -> IO ()) -> Annex () startDaemon assistant foreground webappwaiter | foreground = do showStart (if assistant then "assistant" else "watch") "." @@ -155,7 +155,7 @@ startDaemon assistant foreground webappwaiter , mountWatcherThread st dstatus scanremotes , transferScannerThread st dstatus scanremotes transferqueue #ifdef WITH_WEBAPP - , webAppThread st dstatus transferqueue webappwaiter + , webAppThread (Just st) dstatus transferqueue webappwaiter #endif , watchThread st dstatus transferqueue changechan ] diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 9cdbae451..ad2bff892 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -1,4 +1,4 @@ -{- git-annex assistant webapp +{- git-annex assistant webapp thread - - Copyright 2012 Joey Hess <joey@kitenet.net> - @@ -38,47 +38,46 @@ thisThread = "WebApp" mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") -webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO () -webAppThread st dstatus transferqueue onstartup = do - webapp <- mkWebApp +webAppThread :: (Maybe ThreadState) -> DaemonStatusHandle -> TransferQueue -> Maybe (FilePath -> IO ()) -> IO () +webAppThread mst dstatus transferqueue onstartup = do + webapp <- WebApp + <$> pure mst + <*> pure dstatus + <*> pure transferqueue + <*> (pack <$> genRandomToken) + <*> getreldir mst + <*> pure $(embed "static") + <*> newWebAppState app <- toWaiAppPlain webapp app' <- ifM debugEnabled ( return $ httpDebugLogger app , return app ) - runWebApp app' $ \port -> do - runThreadState st $ writeHtmlShim webapp port - maybe noop id onstartup + 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 - mkWebApp = do + getreldir Nothing = return Nothing + getreldir (Just st) = do dir <- absPath =<< runThreadState st (fromRepo repoPath) home <- myHomeDir - let reldir = if dirContains home dir + return $ Just $ if dirContains home dir then relPathDirToFile home dir else dir - token <- genRandomToken - s <- newWebAppState - return $ WebApp - { threadState = Just st - , daemonStatus = dstatus - , transferQueue = transferqueue - , secretToken = pack token - , relDir = reldir - , getStatic = $(embed "static") - , webAppState = s - } + go port webapp htmlshim = do + writeHtmlShim webapp port htmlshim + maybe noop (\a -> a 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 -> Annex () -writeHtmlShim webapp port = do - liftIO $ debug thisThread ["running on port", show port] - htmlshim <- fromRepo gitAnnexHtmlShim - liftIO $ viaTmp go htmlshim $ genHtmlShim webapp port +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 file content = do - h <- openFile file WriteMode - modifyFileMode file $ removeModes [groupReadMode, otherReadMode] + go tmpfile content = do + h <- openFile tmpfile WriteMode + modifyFileMode tmpfile $ removeModes [groupReadMode, otherReadMode] hPutStr h content hClose h diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index f7fb7bb6e..2a1fcb6b4 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -34,7 +34,7 @@ data WebApp = WebApp , daemonStatus :: DaemonStatusHandle , transferQueue :: TransferQueue , secretToken :: Text - , relDir :: FilePath + , relDir :: Maybe FilePath , getStatic :: Static , webAppState :: TMVar WebAppState } diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index ee3209ce2..66d92ebc0 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -25,7 +25,6 @@ import Data.Text (Text) introDisplay :: Text -> Widget introDisplay ident = do webapp <- lift getYesod - let reldir = relDir webapp l <- lift $ runAnnex [] $ do u <- getUUID rs <- map Remote.uuid <$> Remote.remoteList diff --git a/Command/WebApp.hs b/Command/WebApp.hs index ee1274f97..6755763b3 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -10,12 +10,19 @@ module Command.WebApp where import Common.Annex import Command import Assistant +import Assistant.DaemonStatus +import Assistant.TransferQueue +import Assistant.Threads.WebApp import Utility.WebApp +import Utility.ThreadScheduler import Utility.Daemon (checkDaemon) import qualified Command.Watch +import Control.Concurrent.STM + def :: [Command] -def = [withOptions [Command.Watch.foregroundOption, Command.Watch.stopOption] $ +def = [oneShot $ noRepo firstRun $ dontCheck repoExists $ + withOptions [Command.Watch.foregroundOption, Command.Watch.stopOption] $ command "webapp" paramNothing seek "launch webapp"] seek :: [CommandSeek] @@ -30,8 +37,8 @@ start foreground stopdaemon = notBareRepo $ do else do f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim ifM (checkpid <&&> checkshim f) $ - ( liftIO $ go f - , startDaemon True foreground $ Just $ go f + ( liftIO $ openBrowser f + , startDaemon True foreground $ Just openBrowser ) stop where @@ -39,7 +46,17 @@ start foreground stopdaemon = notBareRepo $ do pidfile <- fromRepo gitAnnexPidFile liftIO $ isJust <$> checkDaemon pidfile checkshim f = liftIO $ doesFileExist f - go f = unlessM (runBrowser url) $ - error $ "failed to start web browser on url " ++ url - where - url = "file://" ++ f + +openBrowser :: FilePath -> IO () +openBrowser htmlshim = unlessM (runBrowser url) $ + error $ "failed to start web browser on url " ++ url + where + url = "file://" ++ htmlshim + +firstRun :: IO () +firstRun = do + dstatus <- atomically . newTMVar =<< newDaemonStatus + transferqueue <- newTransferQueue + webAppThread Nothing dstatus transferqueue $ Just $ \f -> do + openBrowser f + waitForTermination diff --git a/templates/bootstrap.hamlet b/templates/bootstrap.hamlet index cf686f843..f743a0d46 100644 --- a/templates/bootstrap.hamlet +++ b/templates/bootstrap.hamlet @@ -1,7 +1,11 @@ $doctype 5 <html> <head> - <title>#{relDir webapp} #{pageTitle page} + <title> + $maybe reldir <- relDir webapp + #{reldir} #{pageTitle page} + $nothing + #{pageTitle page} <link rel="icon" href=@{StaticR favicon_ico} type="image/x-icon"> <meta name="viewport" content="width=device-width,initial-scale=1.0"> ^{pageHead page} diff --git a/templates/configurators/intro.hamlet b/templates/configurators/intro.hamlet index ecb15f39c..5062346a8 100644 --- a/templates/configurators/intro.hamlet +++ b/templates/configurators/intro.hamlet @@ -1,27 +1,28 @@ <div .span9 ##{ident} .hero-unit> - <h2> - git-annex is watching over your files in <small><tt>#{reldir}</tt></small> - <p> - It will automatically notice changes, and keep files in sync between # - $if notenough - repositories on your devices ... - <h2> - But no other repositories are set up yet. - <a .btn .btn-primary .btn-large href="@{AddRepositoryR}">Add another repository</a> - $else - $if barelyenough - <span .badge .badge-warning>#{numrepos}</span> + $maybe reldir <- relDir webapp + <h2> + git-annex is watching over your files in <small><tt>#{reldir}</tt></small> + <p> + It will automatically notice changes, and keep files in sync between # + $if notenough + repositories on your devices ... + <h2> + But no other repositories are set up yet. + <a .btn .btn-primary .btn-large href="@{AddRepositoryR}">Add another repository</a> $else - <span .badge .badge-success>#{numrepos}</span> - \ repositories and devices: - <table .table .table-striped .table-condensed> - <tbody> - $forall (num, name) <- remotelist - <tr> - <td> - #{num} - <td> - #{name} - <a .btn .btn-primary .btn-large href="@{AddRepositoryR}">Add another repository</a> - <p> - Or just sit back, watch the magic, and get on with using your files. + $if barelyenough + <span .badge .badge-warning>#{numrepos}</span> + $else + <span .badge .badge-success>#{numrepos}</span> + \ repositories and devices: + <table .table .table-striped .table-condensed> + <tbody> + $forall (num, name) <- remotelist + <tr> + <td> + #{num} + <td> + #{name} + <a .btn .btn-primary .btn-large href="@{AddRepositoryR}">Add another repository</a> + <p> + Or just sit back, watch the magic, and get on with using your files. diff --git a/templates/page.hamlet b/templates/page.hamlet index 8a2df1e4b..29a091110 100644 --- a/templates/page.hamlet +++ b/templates/page.hamlet @@ -7,16 +7,17 @@ $forall (name, route, isactive) <- navbar <li :isactive:.active> <a href="@{route}">#{name}</a> - <ul .nav .pull-right> - <li .dropdown #menu1> - <a .dropdown-toggle data-toggle="dropdown" href="#menu1"> - Current Repository: #{relDir webapp} - <b .caret></b> - <ul .dropdown-menu> - <li><a href="#">#{relDir webapp}</a></li> - <li .divider></li> - <li><a href="@{AddRepositoryR}">Add another repository</a></li> - + $maybe reldir <- relDir webapp + <ul .nav .pull-right> + <li .dropdown #menu1> + <a .dropdown-toggle data-toggle="dropdown" href="#menu1"> + Current Repository: #{reldir} + <b .caret></b> + <ul .dropdown-menu> + <li><a href="#">#{reldir}</a></li> + <li .divider></li> + <li><a href="@{AddRepositoryR}">Add another repository</a></li> + $nothing <div .container-fluid> <div .row-fluid> ^{content} |