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.

diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs
index 626e87465ccabe0c19cc2140f1e2b757468c9ebf..bc19ced1dac2cb7af4e5b80ad69ff7a0f2a772e2 100644 (file)
--- a/P2P/Http/Server.hs
+++ b/P2P/Http/Server.hs
@@ -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

diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs
index f0d1b8e8bca12063badc1c053aeb76f13886f7d8..067b86bfbbfb15f06cc17f5718a47b9c97aad825 100644 (file)
--- a/P2P/Http/State.hs
+++ b/P2P/Http/State.hs
@@ -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

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index 905fe2c4313f88cf74786f18f506c5a4ba96971d..2efee45a75db21cbf095bbcf0a83eec508fa72ba 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/doc/todo/git-annex_proxies.mdwn
@@ -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.