implemented firstrun repository creation and redirection to full webapp

Some of the trickiest code I've possibly ever written.
This commit is contained in:
Joey Hess 2012-08-01 16:10:26 -04:00
parent 1efe4f3332
commit ecc168aba3
5 changed files with 110 additions and 25 deletions

View file

@ -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
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

View file

@ -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 ++
url = myUrl webapp port
myUrl :: WebApp -> PortNumber -> Url
myUrl webapp port = "http://localhost:" ++ show port ++
"/?auth=" ++ unpack (secretToken webapp)

View file

@ -37,6 +37,7 @@ data WebApp = WebApp
, relDir :: Maybe FilePath
, getStatic :: Static
, webAppState :: TMVar WebAppState
, postFirstRun :: Maybe (IO String)
}
data NavBarItem = DashBoard | Config | About

View file

@ -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

View file

@ -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