diff options
| -rw-r--r-- | Assistant.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 8 | ||||
| -rw-r--r-- | Command/Watch.hs | 2 | ||||
| -rw-r--r-- | Command/WebApp.hs | 43 | ||||
| -rw-r--r-- | Utility/WebApp.hs | 5 |
5 files changed, 27 insertions, 40 deletions
diff --git a/Assistant.hs b/Assistant.hs index 6b155a4a6..ca428988f 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -124,8 +124,8 @@ import Utility.ThreadScheduler import Control.Concurrent -startDaemon :: Bool -> Bool -> Annex () -startDaemon assistant foreground +startDaemon :: Bool -> Bool -> Maybe (IO ()) -> Annex () +startDaemon assistant foreground webappwaiter | foreground = do showStart (if assistant then "assistant" else "watch") "." go id @@ -157,12 +157,11 @@ startDaemon assistant foreground , mountWatcherThread st dstatus scanremotes , transferScannerThread st scanremotes transferqueue #ifdef WITH_WEBAPP - , webAppThread st dstatus transferqueue + , webAppThread st dstatus transferqueue webappwaiter #endif , watchThread st dstatus transferqueue changechan ] - debug "assistant" - ["all git-annex assistant threads started"] + debug "Assistant" ["all threads started"] waitForTermination stopDaemon :: Annex () diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 171c7fd9c..f0acaeb22 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -145,15 +145,17 @@ getConfigR = defaultLayout $ do setTitle "configuration" [whamlet|<a href="@{HomeR}">main|] -webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> IO () -webAppThread st dstatus transferqueue = do +webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO () +webAppThread st dstatus transferqueue onstartup = do webapp <- mkWebApp app <- toWaiAppPlain webapp app' <- ifM debugEnabled ( return $ httpDebugLogger app , return app ) - runWebApp app' $ \port -> runThreadState st $ writeHtmlShim webapp port + runWebApp app' $ \port -> do + runThreadState st $ writeHtmlShim webapp port + maybe noop id onstartup where mkWebApp = do dir <- absPath =<< runThreadState st (fromRepo repoPath) diff --git a/Command/Watch.hs b/Command/Watch.hs index 744844c4d..61c859106 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -34,5 +34,5 @@ start :: Bool -> Bool -> Bool -> CommandStart start assistant foreground stopdaemon = notBareRepo $ do if stopdaemon then stopDaemon - else startDaemon assistant foreground -- does not return + else startDaemon assistant foreground Nothing -- does not return stop diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 7d0a310d4..1635ac044 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -12,12 +12,8 @@ import Command import Assistant import Utility.WebApp import Utility.Daemon (checkDaemon) -import qualified Annex import Option -import Control.Concurrent -import System.Posix.Process - def :: [Command] def = [withOptions [restartOption] $ command "webapp" paramNothing seek "launch webapp"] @@ -34,31 +30,20 @@ start restart = notBareRepo $ do if restart then do stopDaemon - nuke =<< fromRepo gitAnnexPidFile - startassistant f - else unlessM (checkpid f) $ + void $ liftIO . nukeFile =<< fromRepo gitAnnexPidFile startassistant f - let url = "file://" ++ f - ifM (liftIO $ runBrowser url) - ( stop - , error $ "failed to start web browser on url " ++ url - ) + else ifM (checkpid <&&> checkshim f) $ + ( liftIO $ go f + , startassistant f + ) + stop where - nuke f = void $ liftIO $ catchMaybeIO $ removeFile f - checkpid f = do + checkpid = do pidfile <- fromRepo gitAnnexPidFile - liftIO $ - doesFileExist f <&&> (isJust <$> checkDaemon pidfile) - startassistant f = do - nuke f - {- Fork a separate process to run the assistant, - - with a copy of the Annex state. -} - state <- Annex.getState id - liftIO $ void $ forkProcess $ - Annex.eval state $ startDaemon True False - waitdaemon f (1000 :: Int) - waitdaemon _ 0 = error "failed to start git-annex assistant" - waitdaemon f n = unlessM (checkpid f) $ do - -- wait 0.1 seconds before retry - liftIO $ threadDelay 100000 - waitdaemon f (n - 1) + liftIO $ isJust <$> checkDaemon pidfile + checkshim f = liftIO $ doesFileExist f + startassistant = startDaemon True False . Just . go + go f = unlessM (runBrowser url) $ + error $ "failed to start web browser on url " ++ url + where + url = "file://" ++ f diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 69864dc6d..75e8dde9e 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -32,6 +32,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Blaze.ByteString.Builder (Builder) import Data.Monoid import Control.Arrow ((***)) +import Control.Concurrent localhost :: String localhost = "localhost" @@ -52,12 +53,12 @@ runBrowser url = boolSystem cmd [Param url] - - An IO action can also be run, to do something with the port number, - such as start a web browser to view the webapp. - -} + -} runWebApp :: Application -> (PortNumber -> IO ()) -> IO () runWebApp app observer = do sock <- localSocket + void $ forkIO $ runSettingsSocket defaultSettings sock app observer =<< socketPort sock - runSettingsSocket defaultSettings sock app {- Binds to a local socket, selecting any free port. - |