implemented firstrun repository creation and redirection to full webapp
Some of the trickiest code I've possibly ever written.
This commit is contained in:
parent
1efe4f3332
commit
ecc168aba3
5 changed files with 110 additions and 25 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue