6ddfa9807bNot yet used by git-annex, but this will allow faster transfers etc than using individual ssh connections and rsync. Not called git-annex-shell p2p, because git-annex p2p does something else and I don't want two subcommands with the same name between the two for sanity reasons. This commit was sponsored by Øyvind Andersen Holm.
44 lines
1.2 KiB
Haskell
44 lines
1.2 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2018 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.P2PStdIO where
|
|
|
|
import Command
|
|
import P2P.IO
|
|
import P2P.Annex
|
|
import qualified P2P.Protocol as P2P
|
|
import Git.Types
|
|
import qualified Annex
|
|
import Annex.UUID
|
|
import qualified CmdLine.GitAnnexShell.Checks as Checks
|
|
import qualified CmdLine.GitAnnexShell.Fields as Fields
|
|
import Utility.AuthToken
|
|
import Utility.Tmp.Dir
|
|
|
|
cmd :: Command
|
|
cmd = noMessages $ command "p2pstdio" SectionPlumbing
|
|
"communicate in P2P protocol over stdio"
|
|
paramNothing (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek = withNothing start
|
|
|
|
start :: CommandStart
|
|
start = do
|
|
servermode <- liftIO $
|
|
Checks.checkEnvSet Checks.readOnlyEnv >>= return . \case
|
|
True -> P2P.ServeReadOnly
|
|
False -> P2P.ServeReadWrite
|
|
theiruuid <- Fields.getField Fields.remoteUUID >>= \case
|
|
Nothing -> giveup "missing remoteuuid field"
|
|
Just u -> return (toUUID u)
|
|
myuuid <- getUUID
|
|
conn <- stdioP2PConnection <$> Annex.gitRepo
|
|
let server = P2P.serveAuthed servermode myuuid
|
|
runFullProto (Serving theiruuid Nothing) conn server >>= \case
|
|
Right () -> next $ next $ return True
|
|
Left e -> giveup e
|