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
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue