servant server now compiling

Just need to fill in some undefined
2024-07-07 14:48:20 -04:00 · 2024-07-07 14:48:20 -04:00 · 9a726cedf6
commit 9a726cedf6
parent 1dbb5ec70d
2 changed files with 301 additions and 30 deletions
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@ -9,6 +9,7 @@

 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}

 module P2P.Http where
@ -19,11 +20,18 @@ import Utility.Base64
 import Utility.MonotonicClock

 import Servant
+import qualified Servant.Types.SourceT as S
 import Servant.API.WebSocket
+import qualified Network.WebSockets as Websocket
+import Network.Wai
+import Network.Wai.Handler.Warp
+import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.ByteString as B
+import Text.Read
+import Data.Aeson hiding (Key)

-type P2PAPI
+type P2PHttpAPI
 	= "git-annex" :> "key" :> CaptureKey :> GetAPI '[]
 	:<|> "git-annex" :> "v3" :> "key" :> CaptureKey
 		:> GetAPI '[DataLengthHeader]
@ -62,68 +70,228 @@ type P2PAPI
 	:<|> "git-annex" :> "v1" :> "putoffset"
 		:> PutOffsetAPI PutOffsetResult

+p2pHttpAPI :: Proxy P2PHttpAPI
+p2pHttpAPI = Proxy
+
+p2pHttp :: Application
+p2pHttp = serve p2pHttpAPI serveP2pHttp
+
+serveP2pHttp :: Server P2PHttpAPI
+serveP2pHttp
+	= serveGet0
+	:<|> serveGet
+	:<|> serveGet
+	:<|> serveGet
+	:<|> serveGet0
+	:<|> serveCheckPresent
+	:<|> serveCheckPresent
+	:<|> serveCheckPresent
+	:<|> serveCheckPresent
+	:<|> serveLockContent
+	:<|> serveLockContent
+	:<|> serveLockContent
+	:<|> serveLockContent
+	:<|> serveRemove id
+	:<|> serveRemove id
+	:<|> serveRemove dePlus
+	:<|> serveRemove dePlus
+	:<|> serveRemoveBefore
+	:<|> serveGetTimestamp
+	:<|> servePut id
+	:<|> servePut id
+	:<|> servePut dePlus
+	:<|> servePut0
+	:<|> servePutOffset id
+	:<|> servePutOffset id
+	:<|> servePutOffset dePlus
+
 type GetAPI headers
-	= CommonParams Optional
+	= ClientUUID Optional
+	:> ServerUUID Optional
+	:> BypassUUIDs
 	:> AssociatedFileParam
 	:> OffsetParam
 	:> StreamGet NoFraming OctetStream
 		(Headers headers (SourceIO B.ByteString))

+serveGet
+	:: B64Key
+	-> Maybe (B64UUID ClientSide)
+	-> Maybe (B64UUID ServerSide)
+	-> [B64UUID Bypass]
+	-> Maybe B64FilePath
+	-> Maybe Offset
+	-> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))
+serveGet = undefined
+
+serveGet0
+	:: B64Key
+	-> Maybe (B64UUID ClientSide)
+	-> Maybe (B64UUID ServerSide)
+	-> [B64UUID Bypass]
+	-> Maybe B64FilePath
+	-> Maybe Offset
+	-> Handler (Headers '[] (S.SourceT IO B.ByteString))
+serveGet0 = undefined
+
 type CheckPresentAPI
 	= KeyParam
-	:> CommonParams Required
+	:> ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
 	:> Post '[JSON] CheckPresentResult

+serveCheckPresent
+	:: B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Handler CheckPresentResult
+serveCheckPresent = undefined
+
 type LockContentAPI
 	= KeyParam
-	:> CommonParams Required
+	:> ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
 	:> WebSocket

+serveLockContent
+	:: B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Websocket.Connection
+	-> Handler ()
+serveLockContent = undefined
+
 type RemoveAPI result
 	= KeyParam
-	:> CommonParams Required
+	:> ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
 	:> Post '[JSON] result
 	
+serveRemove
+	:: (RemoveResultPlus -> t)
+	-> B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Handler t
+serveRemove = undefined
+	
 type RemoveBeforeAPI
 	= KeyParam
-	:> CommonParams Required
-	:> QueryParam' '[Required] "timestamp" MonotonicTimestamp
+	:> ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
+	:> QueryParam' '[Required] "timestamp" Timestamp
 	:> Post '[JSON] RemoveResult

+serveRemoveBefore
+	:: B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Timestamp
+	-> Handler RemoveResult
+serveRemoveBefore = undefined
+
 type GetTimestampAPI
-	= CommonParams Required
+	= ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
 	:> Post '[JSON] GetTimestampResult

+serveGetTimestamp
+	:: B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Handler GetTimestampResult
+serveGetTimestamp = undefined
+
 type PutAPI result
 	= KeyParam
-	:> CommonParams Required
+	:> ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
 	:> AssociatedFileParam
 	:> OffsetParam
 	:> Header' '[Required] "X-git-annex-data-length" DataLength
-	:> CommonParams Required
 	:> StreamBody NoFraming OctetStream (SourceIO B.ByteString)
 	:> Post '[JSON] result

+servePut
+	:: (PutResultPlus -> t)
+	-> Maybe Integer
+	-> B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Maybe B64FilePath
+	-> Maybe Offset
+	-> DataLength
+	-> S.SourceT IO B.ByteString
+	-> Handler t
+servePut = undefined
+
+servePut0
+	:: B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Maybe B64FilePath
+	-> Maybe Offset
+	-> DataLength
+	-> S.SourceT IO B.ByteString
+	-> Handler PutResult
+servePut0 = undefined
+
 type PutOffsetAPI result
 	= KeyParam
-	:> CommonParams Required
+	:> ClientUUID Required
+	:> ServerUUID Required
+	:> BypassUUIDs
 	:> Post '[JSON] result

-type CommonParams req
-	= QueryParam' '[req] "clientuuid" B64UUID 
-	:> QueryParam' '[req] "serveruuid" B64UUID
-	:> QueryParams "bypass" B64UUID
+servePutOffset
+	:: (PutOffsetResultPlus -> t)
+	-> B64Key
+	-> B64UUID ClientSide
+	-> B64UUID ServerSide
+	-> [B64UUID Bypass]
+	-> Handler t
+servePutOffset = undefined
+
+type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
+
+data ClientSide
+
+type ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide)
+
+data ServerSide
+
+type BypassUUIDs = QueryParams "bypass" (B64UUID Bypass)
+
+data Bypass

 type CaptureKey = Capture "key" B64Key

-type KeyParam = QueryParam' '[Required] "key"
+type KeyParam = QueryParam' '[Required] "key" B64Key

 type AssociatedFileParam = QueryParam "associatedfile" B64FilePath
 	
-type OffsetParam = QueryParam "offset" P2P.Offset
+type OffsetParam = QueryParam "offset" Offset

 type DataLengthHeader = Header "X-git-annex-data-length" Integer

+-- Keys, UUIDs, and filenames are base64 encoded since Servant uses 
+-- Text and so needs UTF-8.
+newtype B64Key = B64Key Key
+newtype B64UUID t = B64UUID UUID
+newtype B64FilePath = B64FilePath RawFilePath
+
 newtype DataLength = DataLength Integer

 newtype CheckPresentResult = CheckPresentResult Bool
@ -132,21 +300,32 @@ newtype RemoveResult = RemoveResult Bool

 data RemoveResultPlus = RemoveResultPlus Bool [UUID]

-newtype GetTimestampResult = GetTimestmapResult MonotonicTimestamp
+newtype GetTimestampResult = GetTimestampResult Timestamp

 newtype PutResult = PutResult Bool
+	deriving (Eq, Show)

 data PutResultPlus = PutResultPlus Bool [UUID]

-newtype PutOffsetResult = PutOffsetResult P2P.Offset
+newtype PutOffsetResult = PutOffsetResult Offset

-data PutOffsetResultPlus = PutOffsetResultPlus P2P.Offset [UUID]
+data PutOffsetResultPlus = PutOffsetResultPlus Offset [UUID]

-- 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
+newtype Offset = Offset P2P.Offset
+
+newtype Timestamp = Timestamp MonotonicTimestamp
+
+class DePlus plus unplus where
+	dePlus :: plus -> unplus
+
+instance DePlus RemoveResultPlus RemoveResult where
+	dePlus (RemoveResultPlus b _) = RemoveResult b
+
+instance DePlus PutResultPlus PutResult where
+	dePlus (PutResultPlus b _) = PutResult b
+
+instance DePlus PutOffsetResultPlus PutOffsetResult where
+	dePlus (PutOffsetResultPlus o _) = PutOffsetResult o

 instance FromHttpApiData B64Key where
 	parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
@ -154,7 +333,7 @@ instance FromHttpApiData B64Key where
 		Just b -> maybe (Left "key parse error") (Right . B64Key)
 			(deserializeKey' b)

-instance FromHttpApiData B64UUID where
+instance FromHttpApiData (B64UUID t) where
 	parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
 		Nothing -> Left "unable to base64 decode UUID"
 		Just b -> case toUUID b of
@ -165,3 +344,94 @@ instance FromHttpApiData B64FilePath where
 	parseUrlPiece t = case fromB64Maybe (TE.encodeUtf8 t) of
 		Nothing -> Left "unable to base64 decode filename"
 		Just b -> Right (B64FilePath b)
+
+instance FromHttpApiData Offset where
+	parseUrlPiece t = case readMaybe (T.unpack t) of
+		Nothing -> Left "offset parse error"
+		Just n -> Right (Offset (P2P.Offset n))
+
+instance FromHttpApiData Timestamp where
+	parseUrlPiece t = case readMaybe (T.unpack t) of
+		Nothing -> Left "timestamp parse error"
+		Just n -> Right (Timestamp (MonotonicTimestamp n))
+
+instance FromHttpApiData DataLength where
+	parseUrlPiece t = case readMaybe (T.unpack t) of
+		Nothing -> Left "X-git-annex-data-length parse error"
+		Just n -> Right (DataLength n)
+
+instance ToJSON PutResult where
+	toJSON (PutResult b) =
+		object ["stored" .= b]
+
+instance FromJSON PutResult where
+	parseJSON = withObject "PutResult" $ \v -> PutResult
+		<$> v .: "stored"
+
+instance ToJSON PutResultPlus where
+	toJSON (PutResultPlus b us) = object
+		[ "stored" .= b
+		, "plusuuids" .= map (fromUUID :: UUID -> String) us
+		]
+
+instance FromJSON PutResultPlus where
+	parseJSON = withObject "PutResultPlus" $ \v -> PutResultPlus
+		<$> v .: "stored"
+		<*> v .: "plusuuids"
+
+instance ToJSON CheckPresentResult where
+	toJSON (CheckPresentResult b) = object
+		["present" .= b]
+
+instance FromJSON CheckPresentResult where
+	parseJSON = withObject "CheckPresentResult" $ \v -> CheckPresentResult
+		<$> v .: "present"
+
+instance ToJSON RemoveResult where
+	toJSON (RemoveResult b) = object
+		["removed" .= b]
+
+instance FromJSON RemoveResult where
+	parseJSON = withObject "RemoveResult" $ \v -> RemoveResult
+		<$> v .: "removed"
+
+instance ToJSON RemoveResultPlus where
+	toJSON (RemoveResultPlus b us) = object
+		[ "removed" .= b
+		, "plusuuids" .= map (fromUUID :: UUID -> String) us
+		]
+
+instance FromJSON RemoveResultPlus where
+	parseJSON = withObject "RemoveResultPlus" $ \v -> RemoveResultPlus
+		<$> v .: "removed"
+		<*> v .: "plusuuids"
+
+instance ToJSON GetTimestampResult where
+	toJSON (GetTimestampResult (Timestamp (MonotonicTimestamp t))) = object
+		["timestamp" .= t]
+
+instance FromJSON GetTimestampResult where
+	parseJSON = withObject "GetTimestampResult" $ \v ->
+		GetTimestampResult . Timestamp . MonotonicTimestamp
+			<$> v .: "timestamp"
+
+instance ToJSON PutOffsetResult where
+	toJSON (PutOffsetResult (Offset (P2P.Offset o))) = object
+		["offset" .= o]
+
+instance FromJSON PutOffsetResult where
+	parseJSON = withObject "PutOffsetResult" $ \v ->
+		PutOffsetResult
+			<$> (Offset . P2P.Offset <$> v .: "offset")
+
+instance ToJSON PutOffsetResultPlus where
+	toJSON (PutOffsetResultPlus (Offset (P2P.Offset o)) us) = object
+		[ "offset" .= o
+		, "plusuuids" .= map (fromUUID :: UUID -> String) us
+		]
+
+instance FromJSON PutOffsetResultPlus where
+	parseJSON = withObject "PutOffsetResultPlus" $ \v ->
+		PutOffsetResultPlus
+			<$> (Offset . P2P.Offset <$> v .: "offset")
+			<*> v .: "plusuuids"
--- a/git-annex.cabal
+++ b/git-annex.cabal
@ -317,6 +317,7 @@ Executable git-annex

  if flag(Servant)
    Build-Depends:
+      servant,
      servant-server,
      servant-client,
      servant-websockets,