started servant implementation of HTTP P2P protocol

BuildFlags.hs

@@ -52,6 +52,11 @@ buildFlags = filter (not . null)
 #ifdef WITH_MAGICMIME
 	, "MagicMime"
 #endif
+#ifdef WITH_SERVANT
+	, "Servant"
+#else
+#warning Building without servant, no git-annex p2phttp.
+#endif
 #ifdef WITH_BENCHMARK
 	, "Benchmark"
 #endif

CHANGELOG

@@ -5,6 +5,8 @@ git-annex (10.20240702) UNRELEASED; urgency=medium
   * Avoid potential data loss in situations where git-annex-shell or
     git-annex remotedaemon is killed while locking a key to prevent its
     removal.
+  * New HTTP API that is equivilant to the P2P protocol.
+  * Added a build flag for servant, enabling git-annex p2phttp.
   * Added a dependency on clock.
 
  -- Joey Hess <id@joeyh.name>  Tue, 02 Jul 2024 12:14:53 -0400

CmdLine/GitAnnex.hs

@@ -1,6 +1,6 @@
 {- git-annex main program
  -
- - Copyright 2010-2022 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -118,6 +118,9 @@ import qualified Command.Upgrade
 import qualified Command.Forget
 import qualified Command.OldKeys
 import qualified Command.P2P
+#ifdef WITH_SERVANT
+import qualified Command.P2PHttp
+#endif
 import qualified Command.Proxy
 import qualified Command.DiffDriver
 import qualified Command.Smudge
@@ -245,6 +248,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator = map addGitAnnexCommonOption
 	, Command.Forget.cmd
 	, Command.OldKeys.cmd
 	, Command.P2P.cmd
+#ifdef WITH_SERVANT
+	, Command.P2PHttp.cmd
+#endif
 	, Command.Proxy.cmd
 	, Command.DiffDriver.cmd
 	, Command.Smudge.cmd

Command/P2PHttp.hs

@@ -0,0 +1,120 @@
+{- git-annex command
+ -
+ - Copyright 2024 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Command.P2PHttp where
+
+import Command
+import qualified P2P.Protocol as P2P
+import Utility.Base64
+import Utility.MonotonicClock
+
+import Servant
+import Servant.API.WebSocket
+import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString as B
+
+cmd :: Command
+cmd = command "p2phttp" SectionPlumbing
+	"communicate in P2P protocol over http"
+	paramNothing (withParams seek)
+
+seek :: CmdParams -> CommandSeek
+seek = error "TODO"
+
+type API
+	= "git-annex" 
+		:> (("key" :> CaptureKey) :<|> ("v3" :> "key" :> CaptureKey))
+		:> CommonParams Optional
+		:> AssociatedFileParam
+		:> OffsetParam
+		:> StreamGet NoFraming OctetStream (SourceIO B.ByteString)
+	:<|> "git-annex" :> "v3" :> "checkpresent"
+		:> KeyParam
+		:> CommonParams Required
+		:> Post '[JSON] CheckPresentResult
+	:<|> "git-annex" :> "v3" :> "lockcontent"
+		:> KeyParam
+		:> CommonParams Required
+		:> WebSocket
+	:<|> "git-annex" :> "v3" :> "remove"
+		:> KeyParam
+		:> CommonParams Required
+		:> Post '[JSON] RemoveResult
+	:<|> "git-annex" :> "v3" :> "remove-before"
+		:> KeyParam
+		:> CommonParams Required
+		:> QueryParam' '[Required] "timestamp" MonotonicTimestamp
+		:> Post '[JSON] RemoveResult
+	:<|> "git-annex" :> "v3" :> "gettimestamp"
+		:> CommonParams Required
+		:> Post '[JSON] GetTimestampResult
+	:<|> "git-annex" :> "v3" :> "put"
+		:> KeyParam
+		:> AssociatedFileParam
+		:> OffsetParam
+		:> Header' '[Required] "X-git-annex-object-size" ObjectSize
+		:> CommonParams Required
+		:> StreamBody NoFraming OctetStream (SourceIO B.ByteString)
+		:> Post '[JSON] PutResult
+
+type CommonParams req
+	= QueryParam' '[req] "clientuuid" B64UUID 
+	:> QueryParam' '[req] "serveruuid" B64UUID
+	:> QueryParams "bypass" B64UUID
+
+type CaptureKey = Capture "key" B64Key
+
+type KeyParam = QueryParam' '[Required] "key"
+
+type AssociatedFileParam = QueryParam "associatedfile" B64FilePath
+	
+type OffsetParam = QueryParam "offset" P2P.Offset
+
+type GetKey
+	= Capture "key" B64Key
+	:> CommonParams Optional
+	:> AssociatedFileParam
+	:> OffsetParam
+	:> StreamGet NoFraming OctetStream (SourceIO B.ByteString)
+
+newtype ObjectSize = ObjectSize Integer
+
+newtype CheckPresentResult = CheckPresentResult Bool
+
+newtype RemoveResult = RemoveResult Bool
+
+newtype GetTimestampResult = GetTimestmapResult MonotonicTimestamp
+
+newtype PutResult = PutResult Bool
+
+-- Keys, UUIDs, and filenames are base64 encoded since Servant uses 
+-- Text and so needs UTF-8.
+newtype B64Key = B64Key Key
+newtype B64UUID = B64UUID UUID
+newtype B64FilePath = B64FilePath RawFilePath
+
+instance FromHttpApiData B64Key where
+	parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
+		Nothing -> Left "unable to base64 decode key"
+		Just b -> maybe (Left "key parse error") (Right . B64Key)
+			(deserializeKey' b)
+
+instance FromHttpApiData B64UUID where
+	parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
+		Nothing -> Left "unable to base64 decode UUID"
+		Just b -> case toUUID b of
+			u@(UUID _) -> Right (B64UUID u)
+			NoUUID -> Left "empty UUID"
+
+instance FromHttpApiData B64FilePath where
+	parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
+		Nothing -> Left "unable to base64 decode filename"
+		Just b -> Right (B64FilePath b)

doc/design/p2p_protocol_over_http/draft1.mdwn

@@ -2,6 +2,18 @@
 
 Draft 1 of a complete [[P2P_protocol]] over HTTP.
 
+## base64 encoding of keys, uuids, and filenames
+
+A git-annex key can contain text in any encoding. So can a filename,
+and it's even possible, though unlikely, that the UUID of a git-annex
+repository might.
+
+But this protocol requires that UTF-8 be used throughout, except 
+where bodies use `Content-Type: application/octet-stream`.
+
+So, all git-annex keys, uuids, and filenames in this protocol are
+base64 encoded.
+
 ## authentication
 
 A git-annex protocol endpoint can optionally operate in readonly mode without
@@ -227,7 +239,7 @@ Example:
 
     > POST /git-annex/v3/put?key=SHA1--foo&associatedfile=bar&clientuuid=79a5a1f4-07e8-11ef-873d-97f93ca91925&serveruuid=ecf6d4ca-07e8-11ef-8990-9b8c1f696bf6 HTTP/1.1
     > Content-Type: application/octet-stream
-    > X-git-annex-object-size: 3
+    > X-git-annex-data-length: 3
     > 
     > foo
     < {"stored": true}

doc/git-annex-p2phttp.mdwn

@@ -0,0 +1,31 @@
+# NAME
+
+git-annex-p2phttp - HTTP server for git-annex P2P protocol
+
+# SYNOPSIS
+
+git-annex p2phttp [params ...]
+
+# DESCRIPTION
+
+This allows a git-annex repository to be accessed over HTTP.
+It is the git-annex equivilant of git-http-backend(1), for serving
+a repository over HTTP with write access for authenticated users.
+
+# SEE ALSO
+
+[[git-annex]](1)
+
+git-http-backend(1)
+
+[[git-annex-shell]](1)
+
+<https://git-annex.branchable.com/design/p2p_protocol_over_http/>
+
+# AUTHOR
+
+Joey Hess <id@joeyh.name>
+
+<http://git-annex.branchable.com/>
+
+Warning: Automatically converted into a man page by mdwn2man. Edit with care

doc/git-annex.mdwn

@@ -212,6 +212,13 @@ content from the key-value store.
 
   See [[git-annex-webapp]](1) for details.
 
+* `p2phttp`
+
+  Allows a git-annex repository to be accessed over HTTP using git-annex
+  p2p protocol.
+
+  See [[git-annex-p2phttp]](1) for details.
+
 * `remotedaemon`
 
   Persistant communication with remotes.

git-annex.cabal

@@ -173,6 +173,9 @@ Flag MagicMime
 Flag Crypton
   Description: Use the crypton library rather than the no longer maintained cryptonite
 
+Flag Servant
+  Description: Use the servant library, enabling git-annex p2phttp
+
 Flag Benchmark
   Description: Enable benchmarking
   Default: True
@@ -312,6 +315,16 @@ Executable git-annex
   else
     Build-Depends: cryptonite (>= 0.23)
 
+  if flag(Servant)
+    Build-Depends:
+      servant-server,
+      servant-client,
+      servant-websockets,
+      websockets
+    CPP-Options: -DWITH_SERVANT
+    Other-Modules:
+      Command.P2PHttp
+
   if (os(windows))
     Build-Depends:
       Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),

stack.yaml

@@ -10,6 +10,7 @@ flags:
     debuglocks: false
     benchmark: true
     crypton: true
+    servant: true
 packages:
 - '.'
 resolver: lts-22.9