diff options
| -rw-r--r-- | Assistant.hs | 24 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 22 | ||||
| -rw-r--r-- | Assistant/WebApp.hs | 1 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 41 | ||||
| -rw-r--r-- | Command/WebApp.hs | 47 |
5 files changed, 110 insertions, 25 deletions
diff --git a/Assistant.hs b/Assistant.hs index 4bb85975b..be84fab55 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -122,7 +122,10 @@ import Utility.ThreadScheduler import Control.Concurrent -startDaemon :: Bool -> Bool -> Maybe (FilePath -> IO ()) -> Annex () +stopDaemon :: Annex () +stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile + +startDaemon :: Bool -> Bool -> Maybe (Url -> FilePath -> IO ()) -> Annex () startDaemon assistant foreground webappwaiter | foreground = do showStart (if assistant then "assistant" else "watch") "." @@ -132,10 +135,15 @@ startDaemon assistant foreground webappwaiter pidfile <- fromRepo gitAnnexPidFile go $ Utility.Daemon.daemonize logfd (Just pidfile) False where - go daemonize = withThreadState $ \st -> do - checkCanWatch - dstatus <- startDaemonStatus - liftIO $ daemonize $ run dstatus st + go d = startAssistant assistant d webappwaiter + +startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (Url -> FilePath -> IO ()) -> Annex () +startAssistant assistant daemonize webappwaiter = do + withThreadState $ \st -> do + checkCanWatch + dstatus <- startDaemonStatus + liftIO $ daemonize $ run dstatus st + where run dstatus st = do changechan <- newChangeChan commitchan <- newCommitChan @@ -155,12 +163,8 @@ startDaemon assistant foreground webappwaiter , mountWatcherThread st dstatus scanremotes , transferScannerThread st dstatus scanremotes transferqueue #ifdef WITH_WEBAPP - , webAppThread (Just st) dstatus transferqueue webappwaiter + , webAppThread (Just st) dstatus transferqueue Nothing webappwaiter #endif , watchThread st dstatus transferqueue changechan ] - debug "Assistant" ["all threads started"] waitForTermination - -stopDaemon :: Annex () -stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index ad2bff892..a5484b5be 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -38,8 +38,16 @@ thisThread = "WebApp" mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") -webAppThread :: (Maybe ThreadState) -> DaemonStatusHandle -> TransferQueue -> Maybe (FilePath -> IO ()) -> IO () -webAppThread mst dstatus transferqueue onstartup = do +type Url = String + +webAppThread + :: (Maybe ThreadState) + -> DaemonStatusHandle + -> TransferQueue + -> Maybe (IO String) + -> Maybe (Url -> FilePath -> IO ()) + -> IO () +webAppThread mst dstatus transferqueue postfirstrun onstartup = do webapp <- WebApp <$> pure mst <*> pure dstatus @@ -48,6 +56,7 @@ webAppThread mst dstatus transferqueue onstartup = do <*> getreldir mst <*> pure $(embed "static") <*> newWebAppState + <*> pure postfirstrun app <- toWaiAppPlain webapp app' <- ifM debugEnabled ( return $ httpDebugLogger app @@ -66,7 +75,7 @@ webAppThread mst dstatus transferqueue onstartup = do else dir go port webapp htmlshim = do writeHtmlShim webapp port htmlshim - maybe noop (\a -> a htmlshim) onstartup + 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. -} @@ -85,5 +94,8 @@ writeHtmlShim webapp port file = do genHtmlShim :: WebApp -> PortNumber -> String genHtmlShim webapp port = renderHtml $(shamletFile $ hamletTemplate "htmlshim") where - url = "http://localhost:" ++ show port ++ - "/?auth=" ++ unpack (secretToken webapp) + url = myUrl webapp port + +myUrl :: WebApp -> PortNumber -> Url +myUrl webapp port = "http://localhost:" ++ show port ++ + "/?auth=" ++ unpack (secretToken webapp) diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index c2a021246..1b767c642 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -37,6 +37,7 @@ data WebApp = WebApp , relDir :: Maybe FilePath , getStatic :: Static , webAppState :: TMVar WebAppState + , postFirstRun :: Maybe (IO String) } data NavBarItem = DashBoard | Config | About diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index b9630b10a..5c2a1f25e 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -17,11 +17,16 @@ import qualified Remote import Logs.Web (webUUID) import Logs.Trust import Annex.UUID (getUUID) +import Init +import qualified Git.Construct +import qualified Git.Config +import qualified Annex import Yesod import Data.Text (Text) import qualified Data.Text as T import Data.Char +import System.Posix.Directory {- An intro message, list of repositories, and nudge to make more. -} introDisplay :: Text -> Widget @@ -104,7 +109,7 @@ defaultRepositoryPath :: Bool -> IO FilePath defaultRepositoryPath firstrun = do cwd <- liftIO $ getCurrentDirectory home <- myHomeDir - if home == cwd && firstRun + if home == cwd && firstrun then ifM (doesDirectoryExist $ home </> "Desktop") (return "~/Desktop/annex", return "~/annex") else return cwd @@ -112,8 +117,8 @@ defaultRepositoryPath firstrun = do addRepositoryForm :: Form RepositoryPath addRepositoryForm msg = do path <- T.pack . addTrailingPathSeparator - <$> liftIO defaultRepositoryPath =<< lift inFirstRun - (pathRes, pathView) <- mreq (repositoryPathField True) ""(Just path) + <$> (liftIO . defaultRepositoryPath =<< lift inFirstRun) + (pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path) let (err, errmsg) = case pathRes of FormMissing -> (False, "") FormFailure l -> (True, concat $ map T.unpack l) @@ -128,8 +133,36 @@ addRepository firstrun = do setTitle $ if firstrun then "Getting started" else "Add repository" ((res, form), enctype) <- lift $ runFormGet addRepositoryForm case res of - FormSuccess (RepositoryPath p) -> error $ "TODO" ++ show p + FormSuccess (RepositoryPath p) -> go $ T.unpack p _ -> $(widgetFile "configurators/addrepository") + where + go path + | firstrun = lift $ startFullAssistant path + | otherwise = error "TODO" + +{- Bootstraps from first run mode to a fully running assistant in a + - repository, by running the postFirstRun callback, which returns the + - url to the new webapp. -} +startFullAssistant :: FilePath -> Handler () +startFullAssistant path = do + webapp <- getYesod + url <- liftIO $ do + makeRepo path + changeWorkingDirectory path + putStrLn "pre run" + r <- fromJust $ postFirstRun webapp + putStrLn $ "got " ++ r + return r + redirect $ T.pack url + +{- Makes a new git-annex repository. -} +makeRepo :: FilePath -> IO () +makeRepo path = do + unlessM (boolSystem "git" [Param "init", Param "--quiet", File path]) $ + error "git init failed!" + g <- Git.Config.read =<< Git.Construct.fromPath path + state <- Annex.new g + Annex.eval state $ initialize $ Just "new repo" getAddRepositoryR :: Handler RepHtml getAddRepositoryR = bootstrap (Just Config) $ do diff --git a/Command/WebApp.hs b/Command/WebApp.hs index e2442c37e..0ddf65c58 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -14,11 +14,13 @@ import Assistant.DaemonStatus import Assistant.TransferQueue import Assistant.Threads.WebApp import Utility.WebApp -import Utility.ThreadScheduler import Utility.Daemon (checkDaemon) import Init import qualified Command.Watch +import qualified Git.CurrentRepo +import qualified Annex +import Control.Concurrent import Control.Concurrent.STM def :: [Command] @@ -42,7 +44,8 @@ start foreground stopdaemon = notBareRepo $ do f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim ifM (checkpid <&&> checkshim f) $ ( liftIO $ openBrowser f - , startDaemon True foreground $ Just openBrowser + , startDaemon True foreground $ Just $ + const openBrowser ) checkpid = do pidfile <- fromRepo gitAnnexPidFile @@ -53,12 +56,44 @@ openBrowser :: FilePath -> IO () openBrowser htmlshim = unlessM (runBrowser url) $ error $ "failed to start web browser on url " ++ url where - url = "file://" ++ htmlshim + url = fileUrl htmlshim +fileUrl :: FilePath -> String +fileUrl file = "file://" ++ file + +{- Run the webapp without a repository, which prompts the user, makes one, + - changes to it, starts the regular assistant, and redirects the + - browser to its url. + - + - This is a very tricky dance -- The first webapp calls the signaler, + - which signals the main thread when it's ok to continue by writing to a + - MVar. The main thread starts the second webapp, and uses its callback + - to write its url back to the MVar, from where the signaler retrieves it, + - returning it to the first webapp, which does the redirect. + - + - Note that it's important that mainthread never terminates! Much + - of this complication is due to needing to keep the mainthread running. + -} firstRun :: IO () firstRun = do dstatus <- atomically . newTMVar =<< newDaemonStatus transferqueue <- newTransferQueue - webAppThread Nothing dstatus transferqueue $ Just $ \f -> do - openBrowser f - waitForTermination + v <- newEmptyMVar + let callback a = Just $ a v + webAppThread Nothing dstatus transferqueue (callback signaler) (callback mainthread) + where + signaler v = do + putMVar v "" + putStrLn "signaler waiting..." + r <- takeMVar v + putStrLn "signaler got value" + return r + mainthread v _url htmlshim = do + openBrowser htmlshim + + _wait <- takeMVar v + + state <- Annex.new =<< Git.CurrentRepo.get + Annex.eval state $ + startAssistant True id $ Just $ sendurlback v + sendurlback v url _htmlshim = putMVar v url |