75771772ec
The user doesn't want to see a uuid in the prompt. Also, when a http server is proxying, multiple remotes will have the same base url, and the same password will work for them all.
93 lines
2.5 KiB
Haskell
93 lines
2.5 KiB
Haskell
{- P2P protocol over HTTP, urls
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module P2P.Http.Url where
|
|
|
|
import Types.UUID
|
|
import Utility.FileSystemEncoding
|
|
import Utility.PartialPrelude
|
|
|
|
import Data.List
|
|
import Network.URI
|
|
import System.FilePath.Posix as P
|
|
import qualified Data.UUID as UUID
|
|
#ifdef WITH_SERVANT
|
|
import Servant.Client (BaseUrl(..), Scheme(..))
|
|
import Text.Read
|
|
#endif
|
|
|
|
defaultP2PHttpProtocolPort :: Int
|
|
defaultP2PHttpProtocolPort = 9417 -- Git protocol is 9418
|
|
|
|
isP2PHttpProtocolUrl :: String -> Bool
|
|
isP2PHttpProtocolUrl s =
|
|
"annex+http://" `isPrefixOf` s ||
|
|
"annex+https://" `isPrefixOf` s
|
|
|
|
data P2PHttpUrl = P2PHttpUrl
|
|
{ p2pHttpUrlString :: String
|
|
, p2pHttpUUID :: Maybe UUID
|
|
#ifdef WITH_SERVANT
|
|
, p2pHttpBaseUrl :: BaseUrl
|
|
#endif
|
|
}
|
|
deriving (Show)
|
|
|
|
parseP2PHttpUrl :: String -> Maybe P2PHttpUrl
|
|
parseP2PHttpUrl us
|
|
| isP2PHttpProtocolUrl us = case parseURI (drop prefixlen us) of
|
|
Nothing -> Nothing
|
|
Just u ->
|
|
#ifdef WITH_SERVANT
|
|
case uriScheme u of
|
|
"http:" -> mkbaseurl Http u
|
|
"https:" -> mkbaseurl Https u
|
|
_ -> Nothing
|
|
#else
|
|
Just $ P2PHttpUrl us (extractuuid u)
|
|
#endif
|
|
| otherwise = Nothing
|
|
where
|
|
prefixlen = length "annex+"
|
|
|
|
extractuuid u = do
|
|
p <- lastMaybe $ P.splitDirectories (uriPath u)
|
|
-- While git-annex generally allows a UUID that is not
|
|
-- well formed, here it's important to make sure that the
|
|
-- url a user provided really ends with a UUID, so check
|
|
-- that it's well formed.
|
|
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
|
|
auth <- uriAuthority u
|
|
port <- if null (uriPort auth)
|
|
then Just defaultP2PHttpProtocolPort
|
|
else readMaybe (dropWhile (== ':') (uriPort auth))
|
|
return $ P2PHttpUrl us (extractuuid u) $ BaseUrl
|
|
{ baseUrlScheme = s
|
|
, baseUrlHost = uriRegName auth
|
|
, baseUrlPath = basepath u
|
|
, baseUrlPort = port
|
|
}
|
|
#endif
|
|
|
|
p2pHttpUrlWithoutUUID :: String -> String
|
|
p2pHttpUrlWithoutUUID = reverse . dropWhile (/= '/') . reverse
|