expire lock after 10 minutes initially

Once keeplocked is called, the lock will expire at the end
of that call. But if keeplocked never gets called, this avoids
the lock persisting forever.
This commit is contained in:
Joey Hess 2024-07-24 14:25:40 -04:00
parent 97836aafba
commit f5624a69e3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 31 additions and 10 deletions

View file

@ -428,7 +428,6 @@ serveLockContent st su apiver (B64Key k) cu bypass sec auth = do
net $ sendMessage (LOCKCONTENT k)
checkSuccess
liftIO $ atomically $ putTMVar lockresv lockres
-- TODO timeout
liftIO $ atomically $ takeTMVar unlockv
void $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ do
net $ sendMessage UNLOCKCONTENT
@ -461,6 +460,7 @@ serveKeepLocked
-> Handler LockResult
serveKeepLocked st _su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do
checkAuthActionClass st sec auth WriteAction $ \_ -> do
liftIO $ keepingLocked lckid st
_ <- liftIO $ S.unSourceT unlockrequeststream go
return (LockResult False Nothing)
where

View file

@ -21,9 +21,12 @@ import qualified P2P.IO as P2P
import P2P.IO
import P2P.Annex
import Annex.UUID
import Types.NumCopies
import Types.WorkerPool
import Annex.WorkerPool
import CmdLine.Action (startConcurrency)
import Utility.ThreadScheduler
import Utility.HumanTime
import Servant
import qualified Data.Map as M
@ -281,13 +284,17 @@ data Locker = Locker
-- ^ 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.
, lockerTimeoutDisable :: TMVar ()
-- ^ Until this is filled, the lock will be subject to timeout.
-- Once filled the lock will remain held until explicitly dropped.
}
mkLocker :: IO (Maybe a) -> (a -> IO ()) -> IO (Maybe (Locker, LockID))
mkLocker :: (IO (Maybe a)) -> (a -> IO ()) -> IO (Maybe (Locker, LockID))
mkLocker lock unlock = do
lv <- newEmptyTMVarIO
timeoutdisablev <- newEmptyTMVarIO
let setlocked = putTMVar lv
tid <- async $ lock >>= \case
locktid <- async $ lock >>= \case
Nothing ->
atomically $ setlocked False
Just st -> do
@ -301,10 +308,20 @@ mkLocker lock unlock = do
locksuccess <- atomically $ readTMVar lv
if locksuccess
then do
timeouttid <- async $ do
threadDelaySeconds $ Seconds $ fromIntegral $
durationSeconds p2pDefaultLockContentRetentionDuration
atomically (tryReadTMVar timeoutdisablev) >>= \case
Nothing -> void $ atomically $
writeTMVar lv False
Just () -> noop
tid <- async $ do
wait locktid
cancel timeouttid
lckid <- B64UUID <$> genUUID
return (Just (Locker tid lv, lckid))
return (Just (Locker tid lv timeoutdisablev, lckid))
else do
wait tid
wait locktid
return Nothing
storeLock :: LockID -> Locker -> P2PHttpServerState -> IO ()
@ -313,6 +330,15 @@ storeLock lckid locker st = atomically $ do
let !m' = M.insert lckid locker m
putTMVar (openLocks st) m'
keepingLocked :: LockID -> P2PHttpServerState -> IO ()
keepingLocked lckid st = do
m <- atomically $ readTMVar (openLocks st)
case M.lookup lckid m of
Nothing -> return ()
Just locker ->
atomically $ void $
tryPutTMVar (lockerTimeoutDisable locker) ()
dropLock :: LockID -> P2PHttpServerState -> IO ()
dropLock lckid st = do
v <- atomically $ do

View file

@ -30,11 +30,6 @@ Planned schedule of work:
* Drop needs to check the proof and use timestamps.
* A Locker should expire the lock on its own after 10 minutes,
initially. Once keeplocked is called, the lock will expire at the end
of that call. But if keeplocked never gets called, the lock currently
persists forever.
* Make http server support proxies and clusters.
* Support proxying to git remotes using annex+http urls.