summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-18 17:50:07 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-18 17:50:07 -0400
commit18bae020ede6770dfbe00a3335c0e9f8b7f7fdf6 (patch)
tree74eb967c26258c40649e80d8992aee556b04f6f0 /Assistant
parent467844d7d3f703f99fcde1f951f33efda5e90074 (diff)
make other repositories list list all autostarted repos
And add a form to add another, unrelated repository
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Threads/WebApp.hs34
-rw-r--r--Assistant/TransferQueue.hs6
-rw-r--r--Assistant/WebApp.hs21
-rw-r--r--Assistant/WebApp/Configurators/Local.hs35
-rw-r--r--Assistant/WebApp/DashBoard.hs4
-rw-r--r--Assistant/WebApp/OtherRepos.hs53
-rw-r--r--Assistant/WebApp/Types.hs3
-rw-r--r--Assistant/WebApp/routes7
8 files changed, 131 insertions, 32 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 646734776..8a5ab4ec6 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -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
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 1941c23ef..e2c3f167b 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -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 $
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 64dcd48e3..c8eaeecf0 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -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
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index e77986674..a86d13026 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -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
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index b4e46bd68..fc6b8ea1b 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -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
diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs
new file mode 100644
index 000000000..0c429d182
--- /dev/null
+++ b/Assistant/WebApp/OtherRepos.hs
@@ -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
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index c00150b65..4198cd428 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -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
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index bfc658372..d26e0c567 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-06 01:12:20 +0000