git-annex/Command/P2PHttp.hs

241 lines
7.3 KiB
Haskell
Raw Normal View History

{- git-annex command
-
- Copyright 2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
module Command.P2PHttp where
import Command
2024-07-07 16:59:12 +00:00
import P2P.Http
import qualified P2P.Protocol as P2P
import Annex.Url
2024-07-10 03:44:40 +00:00
import Utility.Env
import Utility.ThreadScheduler
import Utility.MonotonicClock
import qualified Network.Wai.Handler.Warp as Warp
2024-07-10 03:44:40 +00:00
import Servant
import Servant.Client.Streaming
import Control.Concurrent
import Control.Concurrent.STM
2024-07-10 03:44:40 +00:00
import Network.Socket (PortNumber)
import qualified Data.Map as M
cmd :: Command
cmd = withAnnexOptions [jobsOption] $ command "p2phttp" SectionPlumbing
"communicate in P2P protocol over http"
2024-07-09 21:30:55 +00:00
paramNothing (seek <$$> optParser)
data Options = Options
2024-07-10 03:44:40 +00:00
{ portOption :: Maybe PortNumber
2024-07-09 21:30:55 +00:00
, authEnvOption :: Bool
, authEnvHttpOption :: Bool
2024-07-10 03:44:40 +00:00
, unauthReadOnlyOption :: Bool
, unauthAppendOnlyOption :: Bool
2024-07-09 21:30:55 +00:00
, wideOpenOption :: Bool
}
2024-07-10 03:44:40 +00:00
optParser :: CmdParamsDesc -> Parser Options
optParser _ = Options
<$> optional (option auto
( long "port" <> metavar paramNumber
<> help "specify port to listen on"
))
<*> switch
( long "authenv"
<> help "authenticate users from environment (https only)"
)
<*> switch
( long "authenv-http"
<> help "authenticate users from environment (including http)"
)
<*> switch
( long "unauth-readonly"
<> help "allow unauthenticated users to read the repository"
)
<*> switch
( long "unauth-appendonly"
<> help "allow unauthenticated users to read and append to the repository"
)
<*> switch
( long "wideopen"
<> help "give unauthenticated users full read+write access"
)
seek :: Options -> CommandSeek
seek o = getAnnexWorkerPool $ \workerpool -> do
-- XXX remove this
when (isNothing (portOption o)) $ do
liftIO $ putStrLn "test begins"
testPutOffset
giveup "TEST DONE"
withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do
2024-07-10 03:44:40 +00:00
authenv <- getAuthEnv
st <- mkP2PHttpServerState acquireconn workerpool $
2024-07-10 03:44:40 +00:00
mkGetServerMode authenv o
Warp.run (fromIntegral port) (p2pHttpApp st)
where
port = fromMaybe 80 (portOption o)
mkGetServerMode :: M.Map Auth P2P.ServerMode -> Options -> GetServerMode
mkGetServerMode _ o _ Nothing
| wideOpenOption o = Just P2P.ServeReadWrite
| unauthAppendOnlyOption o = Just P2P.ServeAppendOnly
| unauthReadOnlyOption o = Just P2P.ServeReadOnly
| otherwise = Nothing
mkGetServerMode authenv o issecure (Just auth) =
case (issecure, authEnvOption o, authEnvHttpOption o) of
(Secure, True, _) -> checkauth
(NotSecure, _, True) -> checkauth
_ -> noauth
where
checkauth = case M.lookup auth authenv of
Just servermode -> Just servermode
Nothing -> noauth
noauth = mkGetServerMode authenv o issecure Nothing
getAuthEnv :: IO (M.Map Auth P2P.ServerMode)
getAuthEnv = do
environ <- getEnvironment
let permmap = M.fromList (mapMaybe parseperms environ)
return $ M.fromList $
map (addperms permmap) $
mapMaybe parseusername environ
where
parseperms (k, v) = case deprefix "GIT_ANNEX_P2PHTTP_PERMISSIONS_" k of
Nothing -> Nothing
Just username -> case v of
"readonly" -> Just
(encodeBS username, P2P.ServeReadOnly)
"appendonly" -> Just
(encodeBS username, P2P.ServeAppendOnly)
_ -> Nothing
parseusername (k, v) = case deprefix "GIT_ANNEX_P2PHTTP_PASSWORD_" k of
Nothing -> Nothing
Just username -> Just $ Auth (encodeBS username) (encodeBS v)
deprefix prefix s
| prefix `isPrefixOf` s = Just (drop (length prefix) s)
| otherwise = Nothing
addperms permmap auth@(Auth user _) =
case M.lookup user permmap of
Nothing -> (auth, P2P.ServeReadWrite)
Just perms -> (auth, perms)
testKeepLocked = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
liftIO $ clientKeepLocked (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64UUID (toUUID ("lck" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("su" :: String)))
2024-07-22 20:56:44 +00:00
[] $ \keeplocked -> do
print "running, press enter to drop lock"
_ <- getLine
atomically $ writeTMVar keeplocked False
testCheckPresent = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- liftIO $ clientCheckPresent (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
[]
2024-07-10 03:44:40 +00:00
Nothing
liftIO $ print res
2024-07-10 13:19:58 +00:00
testGet = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- liftIO $ clientGet (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("SHA256E-s1048576000--e3b67ce72aa2571c799d6419e3e36828461ac1c78f8ef300c7f9c8ae671c517f" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
2024-07-11 15:42:32 +00:00
(B64UUID (toUUID ("cu" :: String)))
[]
Nothing
Nothing
2024-07-22 20:23:08 +00:00
"outfile"
liftIO $ print res
testPut = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- clientPut (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
2024-07-22 16:50:21 +00:00
(B64Key (fromJust $ deserializeKey ("SHA256E-s1048576000--b460ca923520db561d01b99483e9e2fe65ff9dfbdd52c17acba6ac4e874e27d5")))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[]
Nothing
Nothing
(AssociatedFile (Just "foo"))
"emptyfile"
0
(liftIO (print "validity check") >> return False)
liftIO $ print res
testPutOffset = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- liftIO $ clientPutOffset (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("SHA256E-s1048576000--b460ca923520db561d01b99483e9e2fe65ff9dfbdd52c17acba6ac4e874e27d5")))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[]
Nothing
liftIO $ print res
2024-07-10 13:19:58 +00:00
testRemove = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- liftIO $ clientRemove (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720547401--foo" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
[]
Nothing
liftIO $ print res
testRemoveBefore = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
MonotonicTimestamp t <- liftIO currentMonotonicTimestamp
--liftIO $ threadDelaySeconds (Seconds 10)
let ts = MonotonicTimestamp (t + 10)
liftIO $ print ("running with timestamp", ts)
res <- liftIO $ clientRemoveBefore (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
[]
(Timestamp ts)
Nothing
liftIO $ print res
2024-07-10 14:23:10 +00:00
testGetTimestamp = do
mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- liftIO $ clientGetTimestamp (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3)
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
[]
Nothing
liftIO $ print res