diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 22 | ||||
| -rw-r--r-- | Assistant/WebApp.hs | 1 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 41 |
3 files changed, 55 insertions, 9 deletions
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 |