) where
import Types
-import Annex.Url
+import P2P.Http.Types
+import P2P.Protocol hiding (Offset, Bypass, auth, FileSize)
+import Utility.Metered
+import Utility.FileSize
+import Types.NumCopies
#ifdef WITH_SERVANT
import qualified Annex
import Annex.UUID
+import Annex.Url
import Types.Remote
-import Types.NumCopies
import P2P.Http
import P2P.Http.Url
-import P2P.Http.Types
import Annex.Common
-import P2P.Protocol hiding (Offset, Bypass, auth)
import Annex.Concurrent
import Utility.Url (BasicAuth(..))
-import Utility.Metered
import Utility.HumanTime
import qualified Git.Credential as Git
import Network.HTTP.Types.Status
import Network.HTTP.Client
import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as LI
import qualified Data.Map as M
import Data.Time.Clock.POSIX
import Control.Concurrent
import System.IO.Unsafe
#endif
+import qualified Data.ByteString.Lazy as L
type ClientAction a
#ifdef WITH_SERVANT
M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc
Nothing -> noop
#else
-runP2PHttpClient rmt fallback () = fallback
+p2pHttpClient _rmt fallback () = fallback
"This remote uses an annex+http url, but this version of git-annex is not build with support for that."
#endif
-#ifdef WITH_SERVANT
clientGet
:: Key
-> AssociatedFile
-> Maybe FileSize
-- ^ Size of existing file, when resuming.
-> ClientAction Validity
+#ifdef WITH_SERVANT
clientGet k af consumer startsz clientenv (ProtocolVersion ver) su cu bypass auth = liftIO $ do
let offset = fmap (Offset . fromIntegral) startsz
withClientM (cli (B64Key k) cu bypass baf offset auth) clientenv $ \case
baf = associatedFileToB64FilePath af
#else
-clientGet _ _ _ = ()
+clientGet _ _ _ _ = ()
#endif
clientCheckPresent :: Key -> ClientAction Bool
clientCheckPresent _ = ()
#endif
-#ifdef WITH_SERVANT
clientRemove
:: Maybe SafeDropProof
-> Key
-> ClientAction RemoveResultPlus
+#ifdef WITH_SERVANT
clientRemove proof k clientenv (ProtocolVersion ver) su cu bypass auth =
liftIO $ withClientM cli clientenv return
where
clientRemove _ _ = ()
#endif
-#ifdef WITH_SERVANT
clientRemoveBefore
- :: ClientEnv
- -> ProtocolVersion
- -> B64Key
- -> B64UUID ServerSide
- -> B64UUID ClientSide
- -> [B64UUID Bypass]
+ :: Key
-> Timestamp
- -> Maybe Auth
- -> IO RemoveResultPlus
-clientRemoveBefore clientenv (ProtocolVersion ver) key su cu bypass ts auth =
- withClientM (cli su key cu bypass ts auth) clientenv $ \case
- Left err -> throwM err
- Right res -> return res
+ -> ClientAction RemoveResultPlus
+#ifdef WITH_SERVANT
+clientRemoveBefore k ts clientenv (ProtocolVersion ver) su cu bypass auth =
+ liftIO $ withClientM (cli su (B64Key k) cu bypass ts auth) clientenv return
where
cli = case ver of
3 -> flip v3 V3
_ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> _ = client p2pHttpAPI
+#else
+clientRemoveBefore _ _ = ()
#endif
+clientGetTimestamp :: ClientAction GetTimestampResult
#ifdef WITH_SERVANT
-clientGetTimestamp
- :: ClientEnv
- -> ProtocolVersion
- -> B64UUID ServerSide
- -> B64UUID ClientSide
- -> [B64UUID Bypass]
- -> Maybe Auth
- -> IO GetTimestampResult
clientGetTimestamp clientenv (ProtocolVersion ver) su cu bypass auth =
- withClientM (cli su cu bypass auth) clientenv $ \case
- Left err -> throwM err
- Right res -> return res
+ liftIO $ withClientM (cli su cu bypass auth) clientenv return
where
cli = case ver of
3 -> flip v3 V3
_ :<|> _ :<|> _ :<|> _ :<|>
_ :<|>
v3 :<|> _ = client p2pHttpAPI
+#else
+clientGetTimestamp = ()
#endif
-#ifdef WITH_SERVANT
clientPut
:: MeterUpdate
-> Key
-> Annex Bool
-- ^ Called after sending the file to check if it's valid.
-> ClientAction PutResultPlus
+#ifdef WITH_SERVANT
clientPut meterupdate k moffset af contentfile contentfilesize validitycheck clientenv (ProtocolVersion ver) su cu bypass auth = do
checkv <- liftIO newEmptyTMVarIO
checkresultv <- liftIO newEmptyTMVarIO
clientPut _ _ _ _ _ _ _ = ()
#endif
-#ifdef WITH_SERVANT
clientPutOffset
:: Key
-> ClientAction PutOffsetResultPlus
+#ifdef WITH_SERVANT
clientPutOffset k clientenv (ProtocolVersion ver) su cu bypass auth
| ver == 0 = return (Right (PutOffsetResultPlus (Offset 0)))
| otherwise = liftIO $ withClientM cli clientenv return
clientPutOffset _ = ()
#endif
-#ifdef WITH_SERVANT
clientLockContent
:: Key
-> ClientAction LockResult
+#ifdef WITH_SERVANT
clientLockContent k clientenv (ProtocolVersion ver) su cu bypass auth =
liftIO $ withClientM (cli (B64Key k) cu bypass auth) clientenv return
where
clientLockContent _ = ()
#endif
-#ifdef WITH_SERVANT
clientKeepLocked
:: LockID
-> UUID
-- server. The lock will remain held until the callback returns,
-- and then will be dropped.
-> ClientAction a
+#ifdef WITH_SERVANT
clientKeepLocked lckid remoteuuid unablelock callback clientenv (ProtocolVersion ver) su cu bypass auth = do
readyv <- liftIO newEmptyTMVarIO
keeplocked <- liftIO newEmptyTMVarIO
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE CPP #-}
module P2P.Http.Types where
import qualified P2P.Protocol as P2P
import Utility.MonotonicClock
+#ifdef WITH_SERVANT
import Servant
+import Data.Aeson hiding (Key)
+import Text.Read (readMaybe)
+#endif
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as B
import Codec.Binary.Base64Url as B64
import Data.Char
-import Text.Read (readMaybe)
-import Data.Aeson hiding (Key)
import Control.DeepSeq
import GHC.Generics (Generic)
data Auth = Auth B.ByteString B.ByteString
deriving (Show, Generic, NFData, Eq, Ord)
+#ifdef WITH_SERVANT
+
instance ToHttpApiData Auth where
toHeader (Auth u p) = "Basic " <> B64.encode (u <> ":" <> p)
toUrlPiece = TE.decodeUtf8Lenient . toHeader
plus (PutOffsetResult o) = PutOffsetResultPlus o
plus PutOffsetResultAlreadyHave = PutOffsetResultAlreadyHavePlus []
+#endif
case UUID.fromString p of
Nothing -> Nothing
Just _ -> return (UUID (encodeBS p))
-
- -- The servant server uses urls that start with "/git-annex/",
- -- and so the servant client adds that to the base url. So remove
- -- it from the url that the user provided. However, it may not be
- -- present, eg if some other server is speaking the git-annex
- -- protocol. The UUID is also removed from the end of the url.
- basepath u = case drop 1 $ reverse $ P.splitDirectories (uriPath u) of
- ("git-annex":"/":rest) -> P.joinPath (reverse rest)
- rest -> P.joinPath (reverse rest)
#ifdef WITH_SERVANT
mkbaseurl s u = do
, baseUrlPath = basepath u
, baseUrlPort = port
}
+
+ -- The servant server uses urls that start with "/git-annex/",
+ -- and so the servant client adds that to the base url. So remove
+ -- it from the url that the user provided. However, it may not be
+ -- present, eg if some other server is speaking the git-annex
+ -- protocol. The UUID is also removed from the end of the url.
+ basepath u = case drop 1 $ reverse $ P.splitDirectories (uriPath u) of
+ ("git-annex":"/":rest) -> P.joinPath (reverse rest)
+ rest -> P.joinPath (reverse rest)
#endif
p2pHttpUrlWithoutUUID :: String -> String