dummy HasClient ClientM WebSocket

Enough to let lockcontent routes be included and servant-client be used.
But not enough to use servant-client with those routes. May need to
implement a separate runner for that part of the protocol?

Also some misc other stuff needed to use servant-client.

And fix exposing of UUID in the JSON types. UUID does actually have
aeson instances, but they're used elsewhere (metadata --batch, although
only included to get it to compile, not actually used in there) and not
suitable for use here since this must work with every possible UUID.

diff --git a/P2P/Http.hs b/P2P/Http.hs
index 6c0f5dfb884bd8e0bae8fb60bf1d82f7e9c7ac89..2e6c291de363952c14e4b82ece1bc38e21f22128 100644 (file)
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@@ -9,6 +9,10 @@
 
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -21,16 +25,21 @@ import Utility.MonotonicClock
 
 import Servant
 import Servant.Client.Streaming
+import Servant.Client.Core.RunClient
 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 Network.HTTP.Client (newManager, defaultManagerSettings)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.ByteString as B
-import Text.Read
+import Text.Read (readMaybe)
 import Data.Aeson hiding (Key)
+import Data.Maybe
+import Control.DeepSeq
+import GHC.Generics
 
 type P2PHttpAPI
        = "git-annex" :> "v3" :> "key" :> CaptureKey
@@ -45,11 +54,6 @@ type P2PHttpAPI
        :<|> "git-annex" :> "v2" :> "checkpresent" :> CheckPresentAPI
        :<|> "git-annex" :> "v1" :> "checkpresent" :> CheckPresentAPI
        :<|> "git-annex" :> "v0" :> "checkpresent" :> CheckPresentAPI
-       -- XXX disabled until I can implement HasClient ClientM WebSocket
-       -- :<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI
-       -- :<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI
-       -- :<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI
-       -- :<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI
        :<|> "git-annex" :> "v3" :> "remove" :> RemoveAPI RemoveResultPlus
        :<|> "git-annex" :> "v2" :> "remove" :> RemoveAPI RemoveResultPlus
        :<|> "git-annex" :> "v1" :> "remove" :> RemoveAPI RemoveResult
@@ -70,6 +74,10 @@ type P2PHttpAPI
                :> PutOffsetAPI PutOffsetResultPlus
        :<|> "git-annex" :> "v1" :> "putoffset"
                :> PutOffsetAPI PutOffsetResult
+       :<|> "git-annex" :> "v3" :> "lockcontent" :> LockContentAPI
+       :<|> "git-annex" :> "v2" :> "lockcontent" :> LockContentAPI
+       :<|> "git-annex" :> "v1" :> "lockcontent" :> LockContentAPI
+       :<|> "git-annex" :> "v0" :> "lockcontent" :> LockContentAPI
        :<|> "git-annex" :> "key" :> CaptureKey :> GetAPI '[]
 
 p2pHttpAPI :: Proxy P2PHttpAPI
@@ -88,10 +96,6 @@ serveP2pHttp
        :<|> serveCheckPresent
        :<|> serveCheckPresent
        :<|> serveCheckPresent
-       -- :<|> serveLockContent
-       -- :<|> serveLockContent
-       -- :<|> serveLockContent
-       -- :<|> serveLockContent
        :<|> serveRemove id
        :<|> serveRemove id
        :<|> serveRemove dePlus
@@ -105,6 +109,10 @@ serveP2pHttp
        :<|> servePutOffset id
        :<|> servePutOffset id
        :<|> servePutOffset dePlus
+       :<|> serveLockContent
+       :<|> serveLockContent
+       :<|> serveLockContent
+       :<|> serveLockContent
        :<|> serveGet0
 
 type GetAPI headers
@@ -186,25 +194,6 @@ clientCheckPresent (P2P.ProtocolVersion ver) = case ver of
        _ :<|> _ :<|> _ :<|> _ :<|>
                v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
 
-type LockContentAPI
-       = KeyParam
-       :> ClientUUID Required
-       :> ServerUUID Required
-       :> BypassUUIDs
-       :> WebSocket
-
-serveLockContent
-       :: B64Key
-       -> B64UUID ClientSide
-       -> B64UUID ServerSide
-       -> [B64UUID Bypass]
-       -> Websocket.Connection
-       -> Handler ()
-serveLockContent = undefined
-
--- TODO
---clientLockContent
-
 type RemoveAPI result
        = KeyParam
        :> ClientUUID Required
@@ -390,18 +379,81 @@ clientPutOffset (P2P.ProtocolVersion ver) = case ver of
                _ :<|> _ :<|> _ :<|> _ :<|>
                v3 :<|> v2 :<|> _ = client p2pHttpAPI
 
+type LockContentAPI
+       = KeyParam
+       :> ClientUUID Required
+       :> ServerUUID Required
+       :> BypassUUIDs
+       :> WebSocket
 
-type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
+serveLockContent
+       :: B64Key
+       -> B64UUID ClientSide
+       -> B64UUID ServerSide
+       -> [B64UUID Bypass]
+       -> Websocket.Connection
+       -> Handler ()
+serveLockContent = undefined
 
-data ClientSide
+data WebSocketClient = WebSocketClient deriving (Eq, Show, Bounded, Enum)
 
-type ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide)
+-- XXX this is enough to let servant-client work, but it's not yet
+-- possible to run a WebSocketClient.
+instance RunClient m => HasClient m WebSocket where
+       type Client m WebSocket = WebSocketClient
+       clientWithRoute _pm Proxy _ = WebSocketClient
+       hoistClientMonad _ _ _ WebSocketClient = WebSocketClient
 
-data ServerSide
+clientLockContent
+       :: B64Key
+       -> B64UUID ClientSide
+       -> B64UUID ServerSide
+       -> [B64UUID Bypass]
+       -> WebSocketClient
+clientLockContent = v3
+  where
+       _ :<|> _ :<|> _ :<|> _ :<|>
+               _ :<|> _ :<|> _ :<|> _ :<|>
+               _ :<|> _ :<|> _ :<|> _ :<|>
+               _ :<|>
+               _ :<|>
+               _ :<|> _ :<|> _ :<|> _ :<|>
+               _ :<|> _ :<|> _ :<|>
+               v3 :<|> _ = client p2pHttpAPI
+       -- XXX add other protocol versions
+
+--XXX test code
+query :: ClientM PutOffsetResultPlus
+query = do
+       clientPutOffset (P2P.ProtocolVersion 3)
+               (B64Key (fromJust $ deserializeKey "WORM--foo"))
+               (B64UUID (toUUID ("client" :: String))) 
+               (B64UUID (toUUID ("server" :: String))) 
+               []
+
+--XXX test code
+query' :: WebSocketClient
+query' = do
+       clientLockContent (B64Key (fromJust $ deserializeKey "WORM--foo"))
+               (B64UUID (toUUID ("client" :: String))) 
+               (B64UUID (toUUID ("server" :: String))) 
+               []
+
+--XXX test code
+run :: IO ()
+run = do
+  manager' <- newManager defaultManagerSettings
+  res <- runClientM query (mkClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
+  case res of
+    Left err -> putStrLn $ "Error: " ++ show err
+    Right res' -> do
+      print res'
 
-type BypassUUIDs = QueryParams "bypass" (B64UUID Bypass)
+type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
 
-data Bypass
+type ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide)
+
+type BypassUUIDs = QueryParams "bypass" (B64UUID Bypass)
 
 type CaptureKey = Capture "key" B64Key
 
@@ -413,50 +465,55 @@ type OffsetParam = QueryParam "offset" Offset
 
 type DataLengthHeader = Header "X-git-annex-data-length" Integer
 
+-- Phantom types for B64UIID
+data ClientSide
+data ServerSide
+data Bypass
+data Plus
+
 -- Keys, UUIDs, and filenames are base64 encoded since Servant uses 
 -- Text and so needs UTF-8.
 newtype B64Key = B64Key Key
+       deriving (Show)
+
 newtype B64UUID t = B64UUID UUID
+       deriving (Show, Generic, NFData)
+
 newtype B64FilePath = B64FilePath RawFilePath
+       deriving (Show)
 
 newtype DataLength = DataLength Integer
+       deriving (Show)
 
 newtype CheckPresentResult = CheckPresentResult Bool
+       deriving (Show)
 
 newtype RemoveResult = RemoveResult Bool
+       deriving (Show)
 
-data RemoveResultPlus = RemoveResultPlus Bool [UUID]
+data RemoveResultPlus = RemoveResultPlus Bool [B64UUID Plus]
+       deriving (Show)
 
 newtype GetTimestampResult = GetTimestampResult Timestamp
+       deriving (Show)
 
 newtype PutResult = PutResult Bool
        deriving (Eq, Show)
 
-data PutResultPlus = PutResultPlus Bool [UUID]
+data PutResultPlus = PutResultPlus Bool [B64UUID Plus]
+       deriving (Show)
 
 newtype PutOffsetResult = PutOffsetResult Offset
+       deriving (Show)
 
-data PutOffsetResultPlus = PutOffsetResultPlus Offset [UUID]
+data PutOffsetResultPlus = PutOffsetResultPlus Offset [B64UUID Plus]
+       deriving (Show, Generic, NFData)
 
 newtype Offset = Offset P2P.Offset
+       deriving (Show, Generic, NFData)
 
 newtype Timestamp = Timestamp MonotonicTimestamp
-
-class Plus plus unplus where
-       dePlus :: plus -> unplus
-       plus :: unplus -> plus
-
-instance Plus RemoveResultPlus RemoveResult where
-       dePlus (RemoveResultPlus b _) = RemoveResult b
-       plus (RemoveResult b) = RemoveResultPlus b mempty
-
-instance Plus PutResultPlus PutResult where
-       dePlus (PutResultPlus b _) = PutResult b
-       plus (PutResult b) = PutResultPlus b mempty
-
-instance Plus PutOffsetResultPlus PutOffsetResult where
-       dePlus (PutOffsetResultPlus o _) = PutOffsetResult o
-       plus (PutOffsetResult o) = PutOffsetResultPlus o mempty
+       deriving (Show)
 
 instance ToHttpApiData B64Key where
        toUrlPiece (B64Key k) = TE.decodeUtf8Lenient $
@@ -522,7 +579,7 @@ instance FromJSON PutResult where
 instance ToJSON PutResultPlus where
        toJSON (PutResultPlus b us) = object
                [ "stored" .= b
-               , "plusuuids" .= map (fromUUID :: UUID -> String) us
+               , "plusuuids" .= plusList us
                ]
 
 instance FromJSON PutResultPlus where
@@ -549,7 +606,7 @@ instance FromJSON RemoveResult where
 instance ToJSON RemoveResultPlus where
        toJSON (RemoveResultPlus b us) = object
                [ "removed" .= b
-               , "plusuuids" .= map (fromUUID :: UUID -> String) us
+               , "plusuuids" .= plusList us
                ]
 
 instance FromJSON RemoveResultPlus where
@@ -578,7 +635,7 @@ instance FromJSON PutOffsetResult where
 instance ToJSON PutOffsetResultPlus where
        toJSON (PutOffsetResultPlus (Offset (P2P.Offset o)) us) = object
                [ "offset" .= o
-               , "plusuuids" .= map (fromUUID :: UUID -> String) us
+               , "plusuuids" .= plusList us
                ]
 
 instance FromJSON PutOffsetResultPlus where
@@ -586,3 +643,28 @@ instance FromJSON PutOffsetResultPlus where
                PutOffsetResultPlus
                        <$> (Offset . P2P.Offset <$> v .: "offset")
                        <*> v .: "plusuuids"
+
+instance FromJSON (B64UUID t) where
+       parseJSON (String t) = case fromB64Maybe (TE.encodeUtf8 t) of
+               Just s -> pure (B64UUID (toUUID s))
+               _ -> mempty
+       parseJSON _ = mempty
+
+plusList :: [B64UUID Plus] -> [String]
+plusList = map (\(B64UUID u) -> fromUUID u)
+
+class PlusClass plus unplus where
+       dePlus :: plus -> unplus
+       plus :: unplus -> plus
+
+instance PlusClass RemoveResultPlus RemoveResult where
+       dePlus (RemoveResultPlus b _) = RemoveResult b
+       plus (RemoveResult b) = RemoveResultPlus b mempty
+
+instance PlusClass PutResultPlus PutResult where
+       dePlus (PutResultPlus b _) = PutResult b
+       plus (PutResult b) = PutResultPlus b mempty
+
+instance PlusClass PutOffsetResultPlus PutOffsetResult where
+       dePlus (PutOffsetResultPlus o _) = PutOffsetResult o
+       plus (PutOffsetResult o) = PutOffsetResultPlus o mempty

diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 3f3d4a4dbd480a33c2554d38a18192c5731c5ea1..9ec1451b1d5df89c07fa473b24e238ad74ef8b97 100644 (file)
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -44,10 +44,11 @@ import qualified Data.Set as S
 import Data.Char
 import Data.Time.Clock.POSIX
 import Control.Applicative
+import Control.DeepSeq
 import Prelude
 
 newtype Offset = Offset Integer
-       deriving (Show)
+       deriving (Show, NFData)
 
 newtype Len = Len Integer
        deriving (Show)

diff --git a/Types/UUID.hs b/Types/UUID.hs
index d7e49ff93784ad0c930c651f9f9647314c209fc2..5d25d57aaf87111f388cfe5bbb9c14c0ecdf1c5e 100644 (file)
--- a/Types/UUID.hs
+++ b/Types/UUID.hs
@@ -16,6 +16,7 @@ import qualified Data.UUID as U
 import Data.Maybe
 import Data.String
 import Data.ByteString.Builder
+import Control.DeepSeq
 import qualified Data.Semigroup as Sem
 
 import Git.Types (ConfigValue(..))
@@ -28,6 +29,10 @@ import qualified Utility.SimpleProtocol as Proto
 data UUID = NoUUID | UUID B.ByteString
        deriving (Eq, Ord, Show, Read)
 
+instance NFData UUID where
+       rnf NoUUID = ()
+       rnf (UUID b) = rnf b
+
 class FromUUID a where
        fromUUID :: UUID -> a
 

diff --git a/git-annex.cabal b/git-annex.cabal
index 46d3f6701d68885a698f32301e2605a5c705d5d7..d6476680620d65fb26c7828278dc7b4cc0f76e84 100644 (file)
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -320,6 +320,7 @@ Executable git-annex
       servant,
       servant-server,
       servant-client,
+      servant-client-core,
       servant-websockets,
       websockets
     CPP-Options: -DWITH_SERVANT