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:
parent
97836aafba
commit
f5624a69e3
3 changed files with 31 additions and 10 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue