mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

make other repositories list list all autostarted repos

Browse source 
And add a form to add another, unrelated repository
This commit is contained in:
Joey Hess 2012-09-18 17:50:07 -04:00
parent 467844d7d3
commit 18bae020ed
15 changed files with 166 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
Assistant/Threads/WebApp.hs
View file

@ -21,6 +21,7 @@ import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Documentation
import Assistant.WebApp.OtherRepos
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
@ -72,24 +73,29 @@ webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer pos
, return app
)
runWebApp app' $ \port -> case mst of
Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
Nothing -> withTempFile "webapp.html" $ \tmpfile _ ->
go port webapp tmpfile Nothing
Just st -> do
htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
go port webapp htmlshim (Just urlfile)
where
thread = NamedThread thisThread
getreldir Nothing = return Nothing
getreldir (Just st) = Just <$>
(relHome =<< absPath
=<< runThreadState st (fromRepo repoPath))
go port webapp htmlshim = do
writeHtmlShim webapp port htmlshim
maybe noop (\a -> a (myUrl webapp port HomeR) htmlshim) onstartup
go port webapp htmlshim urlfile = do
debug thisThread ["running on port", show port]
let url = myUrl webapp port
maybe noop (`writeFile` url) urlfile
writeHtmlShim url htmlshim
maybe noop (\a -> a url 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. -}
writeHtmlShim :: WebApp -> PortNumber -> FilePath -> IO ()
writeHtmlShim webapp port file = do
debug thisThread ["running on port", show port]
viaTmp go file $ genHtmlShim webapp port
writeHtmlShim :: String -> FilePath -> IO ()
writeHtmlShim url file = viaTmp go file $ genHtmlShim url
where
go tmpfile content = do
h <- openFile tmpfile WriteMode
@ -98,8 +104,8 @@ writeHtmlShim webapp port file = do
hClose h
{- TODO: generate this static file using Yesod. -}
genHtmlShim :: WebApp -> PortNumber -> String
genHtmlShim webapp port = unlines
genHtmlShim :: String -> String
genHtmlShim url = unlines
[ "<html>"
, "<head>"
, "<title>Starting webapp...</title>"
@ -111,10 +117,8 @@ genHtmlShim webapp port = unlines
, "</body>"
, "</html>"
]
where
url = myUrl webapp port HomeR
myUrl :: WebApp -> PortNumber -> Route WebApp -> Url
myUrl webapp port route = unpack $ yesodRender webapp urlbase route []
myUrl :: WebApp -> PortNumber -> Url
myUrl webapp port = unpack $ yesodRender webapp urlbase HomeR []
where
urlbase = pack $ "http://localhost:" ++ show port

6
Assistant/TransferQueue.hs
View file

@ -61,12 +61,12 @@ queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> Asso
queueTransfers = queueTransfersMatching (const True)
{- Adds transfers to queue for some of the known remotes, that match a
- predicate. -}
- condition. -}
queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
queueTransfersMatching pred schedule q dstatus k f direction = do
queueTransfersMatching matching schedule q dstatus k f direction = do
rs <- sufficientremotes
=<< knownRemotes <$> liftIO (getDaemonStatus dstatus)
let matchingrs = filter (pred . Remote.uuid) rs
let matchingrs = filter (matching . Remote.uuid) rs
if null matchingrs
then defer
else forM_ matchingrs $ \r -> liftIO $

21
Assistant/WebApp.hs
View file

@ -15,6 +15,7 @@ import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Utility.NotificationBroadcaster
import Utility.Yesod
import Locations.UserConfig
import Yesod
import Text.Hamlet
@ -65,8 +66,11 @@ bootstrap navbaritem content = do
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
newWebAppState :: IO (TMVar WebAppState)
newWebAppState = liftIO $ atomically $
newTMVar $ WebAppState { showIntro = True }
newWebAppState = do
otherrepos <- listOtherRepos
atomically $ newTMVar $ WebAppState
{ showIntro = True
, otherRepos = otherrepos }
getWebAppState :: forall sub. GHandler sub WebApp WebAppState
getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
@ -139,3 +143,16 @@ redirectBack = do
clearUltDest
setUltDestReferer
redirectUltDest HomeR
{- List of other known repsitories, and link to add a new one. -}
otherReposWidget :: Widget
otherReposWidget = do
repolist <- lift $ otherRepos <$> getWebAppState
$(widgetFile "otherrepos")
listOtherRepos :: IO [(String, String)]
listOtherRepos = do
f <- autoStartFile
dirs <- ifM (doesFileExist f) ( lines <$> readFile f, return [])
names <- mapM relHome dirs
return $ sort $ zip names dirs

35
Assistant/WebApp/Configurators/Local.hs
View file

@ -104,30 +104,47 @@ defaultRepositoryPath firstrun = do
)
else return cwd
firstRepositoryForm :: Form RepositoryPath
firstRepositoryForm msg = do
path <- T.pack . addTrailingPathSeparator
<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
newRepositoryForm :: FilePath -> Form RepositoryPath
newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) ""
(Just $ T.pack $ addTrailingPathSeparator defpath)
let (err, errmsg) = case pathRes of
FormMissing -> (False, "")
FormFailure l -> (True, concat $ map T.unpack l)
FormSuccess _ -> (False, "")
let form = do
webAppFormAuthToken
$(widgetFile "configurators/firstrepository/form")
$(widgetFile "configurators/newrepository/form")
return (RepositoryPath <$> pathRes, form)
{- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler RepHtml
getFirstRepositoryR = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Getting started"
((res, form), enctype) <- lift $ runFormGet firstRepositoryForm
setTitle "Getting started"
path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path
case res of
FormSuccess (RepositoryPath p) -> lift $
startFullAssistant $ T.unpack p
_ -> $(widgetFile "configurators/firstrepository")
_ -> $(widgetFile "configurators/newrepository/first")
{- Adding a new, separate repository. -}
getNewRepositoryR :: Handler RepHtml
getNewRepositoryR = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Add another repository"
home <- liftIO myHomeDir
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home
case res of
FormSuccess (RepositoryPath p) -> lift $ do
let path = T.unpack p
liftIO $ do
makeRepo path False
initRepo path Nothing
addAutoStart path
redirect $ SwitchToRepositoryR path
_ -> $(widgetFile "configurators/newrepository")
data RemovableDrive = RemovableDrive
{ diskFree :: Maybe Integer

4
Assistant/WebApp/DashBoard.hs
View file

@ -94,6 +94,10 @@ getHomeR = ifM (inFirstRun)
, bootstrap (Just DashBoard) $ dashboard True
)
{- Used to test if the webapp is running. -}
headHomeR :: Handler ()
headHomeR = noop
{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
getNoScriptR :: Handler RepHtml
getNoScriptR = bootstrap (Just DashBoard) $ dashboard False

53
Assistant/WebApp/OtherRepos.hs Normal file
View file

@ -0,0 +1,53 @@
{- git-annex assistant webapp switching to other repos
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.OtherRepos where
import Assistant.Common
import Assistant.WebApp.Types
import qualified Git.Construct
import qualified Git.Config
import Locations.UserConfig
import qualified Utility.Url as Url
import Yesod
import Control.Concurrent
import System.Process (cwd)
{- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. Once it's running, redirect to it.
-}
getSwitchToRepositoryR :: FilePath -> Handler RepHtml
getSwitchToRepositoryR repo = do
liftIO startassistant
url <- liftIO geturl
redirect url
where
startassistant = do
program <- readProgramFile
void $ forkIO $ void $ createProcess $
(proc program ["assistant"])
{ cwd = Just repo }
geturl = do
r <- Git.Config.read =<< Git.Construct.fromPath repo
waiturl $ gitAnnexUrlFile r
waiturl urlfile = do
v <- tryIO $ readFile urlfile
case v of
Left _ -> delayed $ waiturl urlfile
Right url -> ifM (listening url)
( return url
, delayed $ waiturl urlfile
)
listening url = catchBoolIO $
fst <$> Url.exists url []
delayed a = do
threadDelay 100000 -- 1/10th of a second
a

3
Assistant/WebApp/Types.hs
View file

@ -65,7 +65,8 @@ instance RenderMessage WebApp FormMessage where
type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
data WebAppState = WebAppState
{ showIntro :: Bool
{ showIntro :: Bool -- should the into message be displayed?
, otherRepos :: [(String, String)] -- name and path to other repos
}
instance PathPiece SshData where

7
Assistant/WebApp/routes
View file

@ -1,11 +1,14 @@
/ HomeR GET
/ HomeR GET HEAD
/noscript NoScriptR GET
/noscript/auto NoScriptAutoR GET
/about AboutR GET
/config ConfigR GET
/config/repository RepositoriesR GET
/config/repository/first FirstRepositoryR GET
/config/repository/new/first FirstRepositoryR GET
/config/repository/new NewRepositoryR GET
/config/repository/switchto/#FilePath SwitchToRepositoryR GET
/config/repository/add/drive AddDriveR GET
/config/repository/add/ssh AddSshR GET

5
Locations.hs
View file

@ -27,6 +27,7 @@ module Locations (
gitAnnexDaemonStatusFile,
gitAnnexLogFile,
gitAnnexHtmlShim,
gitAnnexUrlFile,
gitAnnexSshDir,
gitAnnexRemotesDir,
gitAnnexAssistantDefaultDir,
@ -167,6 +168,10 @@ gitAnnexLogFile r = gitAnnexDir r </> "daemon.log"
gitAnnexHtmlShim :: Git.Repo -> FilePath
gitAnnexHtmlShim r = gitAnnexDir r </> "webapp.html"
{- File containing the url to the webapp. -}
gitAnnexUrlFile :: Git.Repo -> FilePath
gitAnnexUrlFile r = gitAnnexDir r </> "url"
{- .git/annex/ssh/ is used for ssh connection caching -}
gitAnnexSshDir :: Git.Repo -> FilePath
gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"

1
Logs/Transfer.hs
View file

@ -10,7 +10,6 @@ module Logs.Transfer where
import Common.Annex
import Annex.Perms
import Annex.Exception
import Annex.UUID
import qualified Git
import Types.Remote
import Types.Key

15
templates/configurators/newrepository.hamlet Normal file
View file

@ -0,0 +1,15 @@
<div .span9 .hero-unit>
<h2>
Add another repository
<p>
The form below will make a separate repository, that is not synced #
with your existing repository. You can use the new repository for #
different sorts of files, that are synced and shared with other #
devices and users.
<p>
<form .form-inline enctype=#{enctype}>
^{form}
<p>
<i .icon-asterisk></i> #
Do you want to add another repository that is kept in sync with #
the current one? If so, <a href="@{RepositoriesR}">go here</a>.

4
templates/configurators/firstrepository.hamlet → templates/configurators/newrepository/first.hamlet
View file

@ -10,5 +10,5 @@
Files in this repository will managed by git-annex, #
and kept in sync with your repositories on other devices.
<p>
<form .form-inline enctype=#{enctype}>
^{form}
<form .form-inline enctype=#{enctype}>
^{form}

0
templates/configurators/firstrepository/form.hamlet → templates/configurators/newrepository/form.hamlet
View file

10
templates/otherrepos.hamlet Normal file
View file

@ -0,0 +1,10 @@
<ul .dropdown-menu>
$forall (name, path) <- repolist
<li>
<a href="@{SwitchToRepositoryR path}">
#{name}
$if not (null repolist)
<li .divider></li>
<li>
<a href="@{NewRepositoryR}">
Add another repository

6
templates/page.hamlet
View file

@ -6,7 +6,8 @@
<ul .nav>
$forall (name, route, isactive) <- navbar
<li :isactive:.active>
<a href="@{route}">#{name}</a>
<a href="@{route}">
#{name}
$maybe reldir <- relDir webapp
<ul .nav .pull-right>
<li>
@ -15,8 +16,7 @@
<a .dropdown-toggle data-toggle="dropdown" href="#menu1">
Current Repository: #{reldir}
<b .caret></b>
<ul .dropdown-menu>
<li><a href="@{RepositoriesR}">Add another repository</a></li>
^{otherReposWidget}
$nothing
<div .container-fluid>
<div .row-fluid>