From: Joey Hess Date: Tue, 9 Jul 2024 01:11:01 +0000 (-0400) Subject: split module X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~1^2~21^2~228^2~143 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=9a592f946f8588c7cf024083d4098fd463781e78;p=git-annex.git split module --- diff --git a/P2P/Http.hs b/P2P/Http.hs index 41639e083b..c58921435f 100644 --- a/P2P/Http.hs +++ b/P2P/Http.hs @@ -7,39 +7,32 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -module P2P.Http where +module P2P.Http ( + module P2P.Http, + module P2P.Http.Types, + module P2P.Http.State, +) where import Annex.Common +import P2P.Http.Types +import P2P.Http.State import Annex.UUID (genUUID) import qualified P2P.Protocol as P2P -import Utility.Base64 -import Utility.MonotonicClock import Servant import Servant.Client.Streaming import qualified Servant.Types.SourceT as S import Network.HTTP.Client (defaultManagerSettings, newManager) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import qualified Data.ByteString as B import qualified Data.Map as M -import Text.Read (readMaybe) -import Data.Aeson hiding (Key) -import Control.DeepSeq import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM -import GHC.Generics type P2PHttpAPI = "git-annex" :> "v3" :> "key" :> CaptureKey :> GetAPI @@ -528,73 +521,6 @@ testClientLock = do keeplocked -data P2PHttpServerState = P2PHttpServerState - { openLocks :: TMVar (M.Map LockID Locker) - } - -mkP2PHttpServerState :: IO P2PHttpServerState -mkP2PHttpServerState = P2PHttpServerState - <$> newTMVarIO mempty - -type LockID = B64UUID Lock - -data Locker = Locker - { lockerThread :: Async () - , lockerVar :: TMVar Bool - -- ^ Left empty until the thread has taken the lock - -- (or failed to do so), then True while the lock is held, - -- and setting to False causes the lock to be released. - } - -mkLocker :: IO () -> IO () -> IO (Maybe (Locker, LockID)) -mkLocker lock unlock = do - lv <- newEmptyTMVarIO - let setlocked = putTMVar lv - tid <- async $ - tryNonAsync lock >>= \case - Left _ -> do - atomically $ setlocked False - unlock - Right () -> do - atomically $ setlocked True - atomically $ do - v <- takeTMVar lv - if v - then retry - else setlocked False - unlock - locksuccess <- atomically $ readTMVar lv - if locksuccess - then do - lckid <- B64UUID <$> genUUID - return (Just (Locker tid lv, lckid)) - else do - wait tid - return Nothing - -storeLock :: LockID -> Locker -> P2PHttpServerState -> IO () -storeLock lckid locker st = atomically $ do - m <- takeTMVar (openLocks st) - let !m' = M.insert lckid locker m - putTMVar (openLocks st) m' - -dropLock :: LockID -> P2PHttpServerState -> IO () -dropLock lckid st = do - v <- atomically $ do - m <- takeTMVar (openLocks st) - let (mlocker, !m') = - M.updateLookupWithKey (\_ _ -> Nothing) lckid m - putTMVar (openLocks st) m' - case mlocker of - Nothing -> return Nothing - -- Signal to the locker's thread that it can release the lock. - Just locker -> do - _ <- swapTMVar (lockerVar locker) False - return (Just locker) - case v of - Nothing -> return () - Just locker -> wait (lockerThread locker) - type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide) type ServerUUID req = QueryParam' '[req] "serveruuid" (B64UUID ServerSide) @@ -612,258 +538,3 @@ type OffsetParam = QueryParam "offset" Offset type DataLengthHeader = Header "X-git-annex-data-length" Integer type LockIDParam = QueryParam' '[Required] "lockid" LockID - --- Phantom types for B64UIID -data ClientSide -data ServerSide -data Bypass -data Plus -data Lock - --- 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, Ord, Eq, 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 [B64UUID Plus] - deriving (Show) - -newtype GetTimestampResult = GetTimestampResult Timestamp - deriving (Show) - -newtype PutResult = PutResult Bool - deriving (Eq, Show) - -data PutResultPlus = PutResultPlus Bool [B64UUID Plus] - deriving (Show) - -newtype PutOffsetResult = PutOffsetResult Offset - deriving (Show) - -data PutOffsetResultPlus = PutOffsetResultPlus Offset [B64UUID Plus] - deriving (Show, Generic, NFData) - -newtype Offset = Offset P2P.Offset - deriving (Show, Generic, NFData) - -newtype Timestamp = Timestamp MonotonicTimestamp - deriving (Show) - -data LockResult = LockResult Bool (Maybe LockID) - deriving (Show, Generic, NFData) - -newtype UnlockRequest = UnlockRequest Bool - deriving (Show, Generic, NFData) - -newtype ConnectionKeepAlive = ConnectionKeepAlive T.Text - -connectionKeepAlive :: ConnectionKeepAlive -connectionKeepAlive = ConnectionKeepAlive "Keep-Alive" - -newtype KeepAlive = KeepAlive T.Text - -keepAlive :: KeepAlive -keepAlive = KeepAlive "timeout=1200" - -instance ToHttpApiData ConnectionKeepAlive where - toUrlPiece (ConnectionKeepAlive t) = t - -instance FromHttpApiData ConnectionKeepAlive where - parseUrlPiece = Right . ConnectionKeepAlive - -instance ToHttpApiData KeepAlive where - toUrlPiece (KeepAlive t) = t - -instance FromHttpApiData KeepAlive where - parseUrlPiece = Right . KeepAlive - -instance ToHttpApiData B64Key where - toUrlPiece (B64Key k) = TE.decodeUtf8Lenient $ - toB64 (serializeKey' k) - -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 ToHttpApiData (B64UUID t) where - toUrlPiece (B64UUID u) = TE.decodeUtf8Lenient $ - toB64 (fromUUID u) - -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 - u@(UUID _) -> Right (B64UUID u) - NoUUID -> Left "empty UUID" - -instance ToHttpApiData B64FilePath where - toUrlPiece (B64FilePath f) = TE.decodeUtf8Lenient $ toB64 f - -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 ToHttpApiData Offset where - toUrlPiece (Offset (P2P.Offset n)) = T.pack (show n) - -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 ToHttpApiData Timestamp where - toUrlPiece (Timestamp (MonotonicTimestamp n)) = T.pack (show 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 ToHttpApiData DataLength where - toUrlPiece (DataLength n) = T.pack (show 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" .= plusList 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" .= plusList 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" .= plusList us - ] - -instance FromJSON PutOffsetResultPlus where - parseJSON = withObject "PutOffsetResultPlus" $ \v -> - 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 - -instance ToJSON LockResult where - toJSON (LockResult v (Just (B64UUID lck))) = object - [ "locked" .= v - , "lockid" .= TE.decodeUtf8Lenient (toB64 (fromUUID lck)) - ] - toJSON (LockResult v Nothing) = object - [ "locked" .= v - ] - -instance FromJSON LockResult where - parseJSON = withObject "LockResult" $ \v -> LockResult - <$> v .: "locked" - <*> v .:? "lockid" - -instance ToJSON UnlockRequest where - toJSON (UnlockRequest v) = object - ["unlock" .= v] - -instance FromJSON UnlockRequest where - parseJSON = withObject "UnlockRequest" $ \v -> UnlockRequest - <$> v .: "unlock" - -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/Http/State.hs b/P2P/Http/State.hs new file mode 100644 index 0000000000..5c888c1ab8 --- /dev/null +++ b/P2P/Http/State.hs @@ -0,0 +1,85 @@ +{- P2P protocol over HTTP, server state + - + - https://git-annex.branchable.com/design/p2p_protocol_over_http/ + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module P2P.Http.State where + +import Annex.Common +import P2P.Http.Types +import Annex.UUID (genUUID) + +import qualified Data.Map as M +import Control.Concurrent.Async +import Control.Concurrent.STM + +data P2PHttpServerState = P2PHttpServerState + { openLocks :: TMVar (M.Map LockID Locker) + } + +mkP2PHttpServerState :: IO P2PHttpServerState +mkP2PHttpServerState = P2PHttpServerState + <$> newTMVarIO mempty + +data Locker = Locker + { lockerThread :: Async () + , lockerVar :: TMVar Bool + -- ^ Left empty until the thread has taken the lock + -- (or failed to do so), then True while the lock is held, + -- and setting to False causes the lock to be released. + } + +mkLocker :: IO () -> IO () -> IO (Maybe (Locker, LockID)) +mkLocker lock unlock = do + lv <- newEmptyTMVarIO + let setlocked = putTMVar lv + tid <- async $ + tryNonAsync lock >>= \case + Left _ -> do + atomically $ setlocked False + unlock + Right () -> do + atomically $ setlocked True + atomically $ do + v <- takeTMVar lv + if v + then retry + else setlocked False + unlock + locksuccess <- atomically $ readTMVar lv + if locksuccess + then do + lckid <- B64UUID <$> genUUID + return (Just (Locker tid lv, lckid)) + else do + wait tid + return Nothing + +storeLock :: LockID -> Locker -> P2PHttpServerState -> IO () +storeLock lckid locker st = atomically $ do + m <- takeTMVar (openLocks st) + let !m' = M.insert lckid locker m + putTMVar (openLocks st) m' + +dropLock :: LockID -> P2PHttpServerState -> IO () +dropLock lckid st = do + v <- atomically $ do + m <- takeTMVar (openLocks st) + let (mlocker, !m') = + M.updateLookupWithKey (\_ _ -> Nothing) lckid m + putTMVar (openLocks st) m' + case mlocker of + Nothing -> return Nothing + -- Signal to the locker's thread that it can release the lock. + Just locker -> do + _ <- swapTMVar (lockerVar locker) False + return (Just locker) + case v of + Nothing -> return () + Just locker -> wait (lockerThread locker) diff --git a/P2P/Http/Types.hs b/P2P/Http/Types.hs new file mode 100644 index 0000000000..566ad44a90 --- /dev/null +++ b/P2P/Http/Types.hs @@ -0,0 +1,284 @@ +{- P2P protocol over HTTP, + - data types for servant not including the servant API + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module P2P.Http.Types where + +import Annex.Common +import qualified P2P.Protocol as P2P +import Utility.Base64 +import Utility.MonotonicClock + +import Servant +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Read (readMaybe) +import Data.Aeson hiding (Key) +import Control.DeepSeq +import GHC.Generics + +-- Keys, UUIDs, and filenames are base64 encoded since Servant uses +-- Text and so needs UTF-8. +newtype B64Key = B64Key Key + deriving (Show) + +newtype B64FilePath = B64FilePath RawFilePath + deriving (Show) + +newtype B64UUID t = B64UUID UUID + deriving (Show, Ord, Eq, Generic, NFData) + +-- Phantom types for B64UIID +data ClientSide +data ServerSide +data Bypass +data Plus +data Lock + +type LockID = B64UUID Lock + +newtype DataLength = DataLength Integer + deriving (Show) + +newtype CheckPresentResult = CheckPresentResult Bool + deriving (Show) + +newtype RemoveResult = RemoveResult Bool + deriving (Show) + +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 [B64UUID Plus] + deriving (Show) + +newtype PutOffsetResult = PutOffsetResult Offset + deriving (Show) + +data PutOffsetResultPlus = PutOffsetResultPlus Offset [B64UUID Plus] + deriving (Show, Generic, NFData) + +newtype Offset = Offset P2P.Offset + deriving (Show, Generic, NFData) + +newtype Timestamp = Timestamp MonotonicTimestamp + deriving (Show) + +data LockResult = LockResult Bool (Maybe LockID) + deriving (Show, Generic, NFData) + +newtype UnlockRequest = UnlockRequest Bool + deriving (Show, Generic, NFData) + +newtype ConnectionKeepAlive = ConnectionKeepAlive T.Text + +connectionKeepAlive :: ConnectionKeepAlive +connectionKeepAlive = ConnectionKeepAlive "Keep-Alive" + +newtype KeepAlive = KeepAlive T.Text + +keepAlive :: KeepAlive +keepAlive = KeepAlive "timeout=1200" + +instance ToHttpApiData ConnectionKeepAlive where + toUrlPiece (ConnectionKeepAlive t) = t + +instance FromHttpApiData ConnectionKeepAlive where + parseUrlPiece = Right . ConnectionKeepAlive + +instance ToHttpApiData KeepAlive where + toUrlPiece (KeepAlive t) = t + +instance FromHttpApiData KeepAlive where + parseUrlPiece = Right . KeepAlive + +instance ToHttpApiData B64Key where + toUrlPiece (B64Key k) = TE.decodeUtf8Lenient $ + toB64 (serializeKey' k) + +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 ToHttpApiData (B64UUID t) where + toUrlPiece (B64UUID u) = TE.decodeUtf8Lenient $ + toB64 (fromUUID u) + +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 + u@(UUID _) -> Right (B64UUID u) + NoUUID -> Left "empty UUID" + +instance ToHttpApiData B64FilePath where + toUrlPiece (B64FilePath f) = TE.decodeUtf8Lenient $ toB64 f + +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 ToHttpApiData Offset where + toUrlPiece (Offset (P2P.Offset n)) = T.pack (show n) + +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 ToHttpApiData Timestamp where + toUrlPiece (Timestamp (MonotonicTimestamp n)) = T.pack (show 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 ToHttpApiData DataLength where + toUrlPiece (DataLength n) = T.pack (show 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" .= plusList 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" .= plusList 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" .= plusList us + ] + +instance FromJSON PutOffsetResultPlus where + parseJSON = withObject "PutOffsetResultPlus" $ \v -> + 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 + +instance ToJSON LockResult where + toJSON (LockResult v (Just (B64UUID lck))) = object + [ "locked" .= v + , "lockid" .= TE.decodeUtf8Lenient (toB64 (fromUUID lck)) + ] + toJSON (LockResult v Nothing) = object + [ "locked" .= v + ] + +instance FromJSON LockResult where + parseJSON = withObject "LockResult" $ \v -> LockResult + <$> v .: "locked" + <*> v .:? "lockid" + +instance ToJSON UnlockRequest where + toJSON (UnlockRequest v) = object + ["unlock" .= v] + +instance FromJSON UnlockRequest where + parseJSON = withObject "UnlockRequest" $ \v -> UnlockRequest + <$> v .: "unlock" + +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/git-annex.cabal b/git-annex.cabal index f15270d35d..9fe56aa565 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -325,6 +325,8 @@ Executable git-annex Other-Modules: Command.P2PHttp P2P.Http + P2P.Http.State + P2P.Http.Types if (os(windows)) Build-Depends: