4ac2fd0a22
I now have this topology working:
assistant ---> {bare repo, special remote} <--- assistant
And, I think, also this one:
+----------- bare repo --------+
v v
assistant ---> special remote <--- assistant
While before with assistant <---> assistant connections, both sides got
location info updated after a transfer, in this topology, the bare repo
*might* get its location info updated, but the other assistant has no way to
know that it did. And a special remote doesn't record location info,
so transfers to it won't propigate out location log changes at all.
So, for these to work, after a transfer succeeds, the git-annex branch
needs to be pushed. This is done by recording a synthetic commit has
occurred, which lets the pusher handle pushing out the change (which will
include actually committing any still journalled changes to the git-annex
branch).
Of course, this means rather a lot more syncing action than happened
before. At least the pusher bundles together very close together pushes,
somewhat. Currently it just waits 2 seconds between each push.
135 lines
3.8 KiB
Haskell
135 lines
3.8 KiB
Haskell
{- git-annex assistant webapp thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Assistant.Threads.WebApp where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp.DashBoard
|
|
import Assistant.WebApp.SideBar
|
|
import Assistant.WebApp.Notifications
|
|
import Assistant.WebApp.Configurators
|
|
import Assistant.WebApp.Configurators.Edit
|
|
import Assistant.WebApp.Configurators.Local
|
|
import Assistant.WebApp.Configurators.Ssh
|
|
import Assistant.WebApp.Configurators.Pairing
|
|
#ifdef WITH_S3
|
|
import Assistant.WebApp.Configurators.S3
|
|
#endif
|
|
import Assistant.WebApp.Configurators.XMPP
|
|
import Assistant.WebApp.Documentation
|
|
import Assistant.WebApp.OtherRepos
|
|
import Assistant.ThreadedMonad
|
|
import Assistant.DaemonStatus
|
|
import Assistant.ScanRemotes
|
|
import Assistant.TransferQueue
|
|
import Assistant.TransferSlots
|
|
import Assistant.Pushes
|
|
import Assistant.Commits
|
|
import Utility.WebApp
|
|
import Utility.FileMode
|
|
import Utility.TempFile
|
|
import Git
|
|
|
|
import Yesod
|
|
import Yesod.Static
|
|
import Network.Socket (PortNumber)
|
|
import Data.Text (pack, unpack)
|
|
|
|
thisThread :: String
|
|
thisThread = "WebApp"
|
|
|
|
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
|
|
|
type Url = String
|
|
|
|
webAppThread
|
|
:: Maybe ThreadState
|
|
-> DaemonStatusHandle
|
|
-> ScanRemoteMap
|
|
-> TransferQueue
|
|
-> TransferSlots
|
|
-> PushNotifier
|
|
-> CommitChan
|
|
-> UrlRenderer
|
|
-> Maybe (IO String)
|
|
-> Maybe (Url -> FilePath -> IO ())
|
|
-> NamedThread
|
|
webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer postfirstrun onstartup = thread $ do
|
|
webapp <- WebApp
|
|
<$> pure mst
|
|
<*> pure dstatus
|
|
<*> pure scanremotes
|
|
<*> pure transferqueue
|
|
<*> pure transferslots
|
|
<*> pure pushnotifier
|
|
<*> pure commitchan
|
|
<*> (pack <$> genRandomToken)
|
|
<*> getreldir mst
|
|
<*> pure $(embed "static")
|
|
<*> newWebAppState
|
|
<*> pure postfirstrun
|
|
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
|
|
app <- toWaiAppPlain webapp
|
|
app' <- ifM debugEnabled
|
|
( return $ httpDebugLogger app
|
|
, return app
|
|
)
|
|
runWebApp app' $ \port -> case mst of
|
|
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 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 :: String -> FilePath -> IO ()
|
|
writeHtmlShim url file = viaTmp go file $ genHtmlShim url
|
|
where
|
|
go tmpfile content = do
|
|
h <- openFile tmpfile WriteMode
|
|
modifyFileMode tmpfile $ removeModes [groupReadMode, otherReadMode]
|
|
hPutStr h content
|
|
hClose h
|
|
|
|
{- TODO: generate this static file using Yesod. -}
|
|
genHtmlShim :: String -> String
|
|
genHtmlShim url = unlines
|
|
[ "<html>"
|
|
, "<head>"
|
|
, "<title>Starting webapp...</title>"
|
|
, "<meta http-equiv=\"refresh\" content=\"0; URL="++url++"\">"
|
|
, "<body>"
|
|
, "<p>"
|
|
, "<a href=\"" ++ url ++ "\">Starting webapp...</a>"
|
|
, "</p>"
|
|
, "</body>"
|
|
, "</html>"
|
|
]
|
|
|
|
myUrl :: WebApp -> PortNumber -> Url
|
|
myUrl webapp port = unpack $ yesodRender webapp urlbase HomeR []
|
|
where
|
|
urlbase = pack $ "http://localhost:" ++ show port
|