implemented git-annex-shell p2pstdio

Not 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.

1 files changed, 44 insertions, 0 deletions

diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs
new file mode 100644
index 000000000..f6e4ae0f0
--- /dev/null
+++ b/Command/P2PStdIO.hs
@@ -0,0 +1,44 @@
+{- 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