p2phttp is almost working for checkpresent

The server is fully running annex actions, only the P2PConnection is
wrong, currently using stdio.

P2P/Http/State.hs

@@ -13,29 +13,134 @@ module P2P.Http.State where
 
 import Annex.Common
 import P2P.Http.Types
-import Annex.UUID (genUUID)
 import qualified P2P.Protocol as P2P
+import P2P.IO
+import P2P.Annex
+import Annex.UUID
+import Annex.Concurrent
 
+import Servant
 import qualified Data.Map as M
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 
 data P2PHttpServerState = P2PHttpServerState
-	{ openLocks :: TMVar (M.Map LockID Locker)
+	{ acquireP2PConnection :: AcquireP2PConnection
+	, openLocks :: TMVar (M.Map LockID Locker)
 	}
 
-mkP2PHttpServerState :: IO P2PHttpServerState
-mkP2PHttpServerState = P2PHttpServerState
-	<$> newTMVarIO mempty
+mkP2PHttpServerState :: AcquireP2PConnection -> IO P2PHttpServerState
+mkP2PHttpServerState acquireconn = P2PHttpServerState
+	<$> pure acquireconn
+	<*> newTMVarIO mempty
 
-inP2PConnection
-	:: P2PHttpServerState
+withP2PConnection
+	:: APIVersion v
+	=> v
+	-> P2PHttpServerState
 	-> B64UUID ClientSide
 	-> B64UUID ServerSide
 	-> [B64UUID Bypass]
-	-> P2P.Proto a
-	-> IO (Either String a)
-inP2PConnection st cu su bypass a = undefined
+	-> (RunState -> P2PConnection -> Handler a)
+	-> Handler a
+withP2PConnection apiver st cu su bypass connaction = do
+	liftIO (acquireP2PConnection st cp) >>= \case
+		Left (ConnectionFailed err) -> 
+			throwError err502 { errBody = encodeBL err }
+		Left TooManyConnections ->
+			throwError err503
+		Right (runst, conn, releaseconn) ->
+			connaction runst conn
+				`finally` liftIO releaseconn
+  where
+	cp = ConnectionParams
+		{ connectionProtocolVersion = protocolVersion apiver
+		, connectionServerUUID = fromB64UUID su
+		, connectionClientUUID = fromB64UUID cu
+		, connectionBypass = map fromB64UUID bypass
+		, connectionServerMode = P2P.ServeReadWrite -- XXX auth
+		}
+
+data ConnectionParams = ConnectionParams
+	{ connectionProtocolVersion :: P2P.ProtocolVersion
+	, connectionServerUUID :: UUID
+	, connectionClientUUID :: UUID
+	, connectionBypass :: [UUID]
+	, connectionServerMode :: P2P.ServerMode
+	}
+	deriving (Show, Eq, Ord)
+
+data ConnectionProblem
+	= ConnectionFailed String
+	| TooManyConnections
+	deriving (Show, Eq)
+
+type AcquireP2PConnection = 
+	ConnectionParams -> IO
+		( Either ConnectionProblem
+			( RunState
+			, P2PConnection
+			, IO () -- ^ release connection
+			)
+		)
+
+{- Runs P2P actions in the local repository only. -}
+-- TODO need worker pool, this can only service a single request at
+-- a time.
+-- TODO proxies
+-- TODO clusters
+withLocalP2PConnections :: (AcquireP2PConnection -> Annex a) -> Annex a
+withLocalP2PConnections a = do
+	reqv <- liftIO newEmptyTMVarIO
+	relv <- liftIO newEmptyTMVarIO
+	asyncservicer <- liftIO . async =<< forkState (servicer reqv relv)
+	a (acquireconn reqv) `finally` join (liftIO (wait asyncservicer))
+  where
+	acquireconn reqv connparams = do
+		respvar <- newEmptyTMVarIO
+		liftIO $ atomically $ putTMVar reqv (connparams, respvar)
+		liftIO $ atomically $ takeTMVar respvar
+
+	servicer reqv relv = do
+		reqrel <- liftIO $
+			atomically $ 
+				(Right <$> takeTMVar reqv)
+					`orElse` 
+				(Left <$> takeTMVar relv)
+		case reqrel of
+			Right (connparams, respvar) ->
+				servicereq relv connparams respvar
+			Left releaseconn -> releaseconn
+		servicer reqv relv
+	
+	servicereq relv connparams respvar = do
+		myuuid <- getUUID
+		resp <- if connectionServerUUID connparams /= myuuid
+			then return $ Left $ ConnectionFailed "unknown uuid"
+			else do
+				runst <- liftIO $ mkrunst connparams
+				-- TODO not this, need one with MVars.
+				let conn = stdioP2PConnection Nothing
+				-- TODO is this right? It needs to exit
+				-- when the client stops sending messages.
+				let server = P2P.serveAuthed
+					(connectionServerMode connparams)
+					(connectionServerUUID connparams)
+				let protorunner = void $
+					runFullProto runst conn server
+				asyncworker <- liftIO . async 
+					=<< forkState protorunner
+				let releaseconn = atomically $ putTMVar relv $
+					join (liftIO (wait asyncworker))
+				return $ Right (runst, conn, releaseconn)
+		liftIO $ atomically $ putTMVar respvar resp
+
+	mkrunst connparams = do
+		prototvar <- newTVarIO $ connectionProtocolVersion connparams
+		mkRunState $ const $ Serving 
+			(connectionClientUUID connparams)
+			Nothing
+			prototvar
 
 data Locker = Locker
 	{ lockerThread :: Async ()