mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 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.Ssh
import Assistant.WebApp.Configurators.Pairing import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Documentation import Assistant.WebApp.Documentation
import Assistant.WebApp.OtherRepos
import Assistant.ThreadedMonad import Assistant.ThreadedMonad
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.ScanRemotes import Assistant.ScanRemotes
@ -72,24 +73,29 @@ webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer pos
, return app , return app
) )
runWebApp app' $ \port -> case mst of runWebApp app' $ \port -> case mst of
Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile Nothing -> withTempFile "webapp.html" $ \tmpfile _ ->
Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim) 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 where
thread = NamedThread thisThread thread = NamedThread thisThread
getreldir Nothing = return Nothing getreldir Nothing = return Nothing
getreldir (Just st) = Just <$> getreldir (Just st) = Just <$>
(relHome =<< absPath (relHome =<< absPath
=<< runThreadState st (fromRepo repoPath)) =<< runThreadState st (fromRepo repoPath))
go port webapp htmlshim = do go port webapp htmlshim urlfile = do
writeHtmlShim webapp port htmlshim debug thisThread ["running on port", show port]
maybe noop (\a -> a (myUrl webapp port HomeR) htmlshim) onstartup 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, {- Creates a html shim file that's used to redirect into the webapp,
- to avoid exposing the secretToken when launching the web browser. -} - to avoid exposing the secretToken when launching the web browser. -}
writeHtmlShim :: WebApp -> PortNumber -> FilePath -> IO () writeHtmlShim :: String -> FilePath -> IO ()
writeHtmlShim webapp port file = do writeHtmlShim url file = viaTmp go file $ genHtmlShim url
debug thisThread ["running on port", show port]
viaTmp go file $ genHtmlShim webapp port
where where
go tmpfile content = do go tmpfile content = do
h <- openFile tmpfile WriteMode h <- openFile tmpfile WriteMode
@ -98,8 +104,8 @@ writeHtmlShim webapp port file = do
hClose h hClose h
{- TODO: generate this static file using Yesod. -} {- TODO: generate this static file using Yesod. -}
genHtmlShim :: WebApp -> PortNumber -> String genHtmlShim :: String -> String
genHtmlShim webapp port = unlines genHtmlShim url = unlines
[ "<html>" [ "<html>"
, "<head>" , "<head>"
, "<title>Starting webapp...</title>" , "<title>Starting webapp...</title>"
@ -111,10 +117,8 @@ genHtmlShim webapp port = unlines
, "</body>" , "</body>"
, "</html>" , "</html>"
] ]
where
url = myUrl webapp port HomeR
myUrl :: WebApp -> PortNumber -> Route WebApp -> Url myUrl :: WebApp -> PortNumber -> Url
myUrl webapp port route = unpack $ yesodRender webapp urlbase route [] myUrl webapp port = unpack $ yesodRender webapp urlbase HomeR []
where where
urlbase = pack $ "http://localhost:" ++ show port 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) queueTransfers = queueTransfersMatching (const True)
{- Adds transfers to queue for some of the known remotes, that match a {- 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 :: (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 rs <- sufficientremotes
=<< knownRemotes <$> liftIO (getDaemonStatus dstatus) =<< knownRemotes <$> liftIO (getDaemonStatus dstatus)
let matchingrs = filter (pred . Remote.uuid) rs let matchingrs = filter (matching . Remote.uuid) rs
if null matchingrs if null matchingrs
then defer then defer
else forM_ matchingrs $ \r -> liftIO $ else forM_ matchingrs $ \r -> liftIO $

21
Assistant/WebApp.hs
View file

@ -15,6 +15,7 @@ import Assistant.ThreadedMonad
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Yesod import Utility.Yesod
import Locations.UserConfig
import Yesod import Yesod
import Text.Hamlet import Text.Hamlet
@ -65,8 +66,11 @@ bootstrap navbaritem content = do
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem) navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
newWebAppState :: IO (TMVar WebAppState) newWebAppState :: IO (TMVar WebAppState)
newWebAppState = liftIO $ atomically $ newWebAppState = do
newTMVar $ WebAppState { showIntro = True } otherrepos <- listOtherRepos
atomically $ newTMVar $ WebAppState
{ showIntro = True
, otherRepos = otherrepos }
getWebAppState :: forall sub. GHandler sub WebApp WebAppState getWebAppState :: forall sub. GHandler sub WebApp WebAppState
getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
@ -139,3 +143,16 @@ redirectBack = do
clearUltDest clearUltDest
setUltDestReferer setUltDestReferer
redirectUltDest HomeR 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

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

@ -104,18 +104,17 @@ defaultRepositoryPath firstrun = do
) )
else return cwd else return cwd
firstRepositoryForm :: Form RepositoryPath newRepositoryForm :: FilePath -> Form RepositoryPath
firstRepositoryForm msg = do newRepositoryForm defpath msg = do
path <- T.pack . addTrailingPathSeparator (pathRes, pathView) <- mreq (repositoryPathField True) ""
<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun) (Just $ T.pack $ addTrailingPathSeparator defpath)
(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
let (err, errmsg) = case pathRes of let (err, errmsg) = case pathRes of
FormMissing -> (False, "") FormMissing -> (False, "")
FormFailure l -> (True, concat $ map T.unpack l) FormFailure l -> (True, concat $ map T.unpack l)
FormSuccess _ -> (False, "") FormSuccess _ -> (False, "")
let form = do let form = do
webAppFormAuthToken webAppFormAuthToken
$(widgetFile "configurators/firstrepository/form") $(widgetFile "configurators/newrepository/form")
return (RepositoryPath <$> pathRes, form) return (RepositoryPath <$> pathRes, form)
{- Making the first repository, when starting the webapp for the first time. -} {- Making the first repository, when starting the webapp for the first time. -}
@ -123,11 +122,29 @@ getFirstRepositoryR :: Handler RepHtml
getFirstRepositoryR = bootstrap (Just Config) $ do getFirstRepositoryR = bootstrap (Just Config) $ do
sideBarDisplay sideBarDisplay
setTitle "Getting started" setTitle "Getting started"
((res, form), enctype) <- lift $ runFormGet firstRepositoryForm path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path
case res of case res of
FormSuccess (RepositoryPath p) -> lift $ FormSuccess (RepositoryPath p) -> lift $
startFullAssistant $ T.unpack p 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 data RemovableDrive = RemovableDrive
{ diskFree :: Maybe Integer { diskFree :: Maybe Integer

4
Assistant/WebApp/DashBoard.hs
View file

@ -94,6 +94,10 @@ getHomeR = ifM (inFirstRun)
, bootstrap (Just DashBoard) $ dashboard True , 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). -} {- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
getNoScriptR :: Handler RepHtml getNoScriptR :: Handler RepHtml
getNoScriptR = bootstrap (Just DashBoard) $ dashboard False 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) type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
data WebAppState = WebAppState 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 instance PathPiece SshData where

7
Assistant/WebApp/routes
View file

@ -1,11 +1,14 @@
/ HomeR GET / HomeR GET HEAD
/noscript NoScriptR GET /noscript NoScriptR GET
/noscript/auto NoScriptAutoR GET /noscript/auto NoScriptAutoR GET
/about AboutR GET /about AboutR GET
/config ConfigR GET /config ConfigR GET
/config/repository RepositoriesR 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/drive AddDriveR GET
/config/repository/add/ssh AddSshR GET /config/repository/add/ssh AddSshR GET

5
Locations.hs
View file

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

1
Logs/Transfer.hs
View file

@ -10,7 +10,6 @@ module Logs.Transfer where
import Common.Annex import Common.Annex
import Annex.Perms import Annex.Perms
import Annex.Exception import Annex.Exception
import Annex.UUID
import qualified Git import qualified Git
import Types.Remote import Types.Remote
import Types.Key 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>.

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

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