make other repositories list list all autostarted repos
And add a form to add another, unrelated repository
This commit is contained in:
Joey Hess
parent
467844d7d3
commit
18bae020ed
15 changed files with 166 additions and 38 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
53
Assistant/WebApp/OtherRepos.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue