implemented serveLockContent (untested)
This commit is contained in:
parent
d5eaf0f567
commit
f5dd7a8bc0
3 changed files with 48 additions and 19 deletions
32
P2P/Http.hs
32
P2P/Http.hs
|
@ -798,6 +798,8 @@ type LockContentAPI
|
||||||
= KeyParam
|
= KeyParam
|
||||||
:> CU Required
|
:> CU Required
|
||||||
:> BypassUUIDs
|
:> BypassUUIDs
|
||||||
|
:> IsSecure
|
||||||
|
:> AuthHeader
|
||||||
:> Post '[JSON] LockResult
|
:> Post '[JSON] LockResult
|
||||||
|
|
||||||
serveLockContent
|
serveLockContent
|
||||||
|
@ -808,8 +810,35 @@ serveLockContent
|
||||||
-> B64Key
|
-> B64Key
|
||||||
-> B64UUID ClientSide
|
-> B64UUID ClientSide
|
||||||
-> [B64UUID Bypass]
|
-> [B64UUID Bypass]
|
||||||
|
-> IsSecure
|
||||||
|
-> Maybe Auth
|
||||||
-> Handler LockResult
|
-> Handler LockResult
|
||||||
serveLockContent = undefined -- TODO
|
serveLockContent st su apiver (B64Key k) cu bypass sec auth = do
|
||||||
|
conn <- getP2PConnection apiver st cu su bypass sec auth WriteAction id
|
||||||
|
let lock = do
|
||||||
|
lockresv <- newEmptyTMVarIO
|
||||||
|
unlockv <- newEmptyTMVarIO
|
||||||
|
annexworker <- async $ inAnnexWorker st $ do
|
||||||
|
lockres <- runFullProto (clientRunState conn) (clientP2PConnection conn) $ 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
|
||||||
|
atomically (takeTMVar lockresv) >>= \case
|
||||||
|
Right True -> return (Just (annexworker, unlockv))
|
||||||
|
_ -> return Nothing
|
||||||
|
let unlock (annexworker, unlockv) = do
|
||||||
|
atomically $ putTMVar unlockv ()
|
||||||
|
wait annexworker
|
||||||
|
releaseP2PConnection conn
|
||||||
|
liftIO $ mkLocker lock unlock >>= \case
|
||||||
|
Just (locker, lockid) -> do
|
||||||
|
liftIO $ storeLock lockid locker st
|
||||||
|
return $ LockResult True (Just lockid)
|
||||||
|
Nothing -> return $ LockResult False Nothing
|
||||||
|
|
||||||
clientLockContent
|
clientLockContent
|
||||||
:: B64UUID ServerSide
|
:: B64UUID ServerSide
|
||||||
|
@ -817,6 +846,7 @@ clientLockContent
|
||||||
-> B64Key
|
-> B64Key
|
||||||
-> B64UUID ClientSide
|
-> B64UUID ClientSide
|
||||||
-> [B64UUID Bypass]
|
-> [B64UUID Bypass]
|
||||||
|
-> Maybe Auth
|
||||||
-> ClientM LockResult
|
-> ClientM LockResult
|
||||||
clientLockContent su (ProtocolVersion ver) = case ver of
|
clientLockContent su (ProtocolVersion ver) = case ver of
|
||||||
3 -> v3 su V3
|
3 -> v3 su V3
|
||||||
|
|
|
@ -264,23 +264,21 @@ data Locker = Locker
|
||||||
-- and setting to False causes the lock to be released.
|
-- and setting to False causes the lock to be released.
|
||||||
}
|
}
|
||||||
|
|
||||||
mkLocker :: IO () -> IO () -> IO (Maybe (Locker, LockID))
|
mkLocker :: IO (Maybe a) -> (a -> IO ()) -> IO (Maybe (Locker, LockID))
|
||||||
mkLocker lock unlock = do
|
mkLocker lock unlock = do
|
||||||
lv <- newEmptyTMVarIO
|
lv <- newEmptyTMVarIO
|
||||||
let setlocked = putTMVar lv
|
let setlocked = putTMVar lv
|
||||||
tid <- async $
|
tid <- async $ lock >>= \case
|
||||||
tryNonAsync lock >>= \case
|
Nothing ->
|
||||||
Left _ -> do
|
atomically $ setlocked False
|
||||||
atomically $ setlocked False
|
Just st -> do
|
||||||
unlock
|
atomically $ setlocked True
|
||||||
Right () -> do
|
atomically $ do
|
||||||
atomically $ setlocked True
|
v <- takeTMVar lv
|
||||||
atomically $ do
|
if v
|
||||||
v <- takeTMVar lv
|
then retry
|
||||||
if v
|
else setlocked False
|
||||||
then retry
|
unlock st
|
||||||
else setlocked False
|
|
||||||
unlock
|
|
||||||
locksuccess <- atomically $ readTMVar lv
|
locksuccess <- atomically $ readTMVar lv
|
||||||
if locksuccess
|
if locksuccess
|
||||||
then do
|
then do
|
||||||
|
@ -305,7 +303,8 @@ dropLock lckid st = do
|
||||||
putTMVar (openLocks st) m'
|
putTMVar (openLocks st) m'
|
||||||
case mlocker of
|
case mlocker of
|
||||||
Nothing -> return Nothing
|
Nothing -> return Nothing
|
||||||
-- Signal to the locker's thread that it can release the lock.
|
-- Signal to the locker's thread that it can
|
||||||
|
-- release the lock.
|
||||||
Just locker -> do
|
Just locker -> do
|
||||||
_ <- swapTMVar (lockerVar locker) False
|
_ <- swapTMVar (lockerVar locker) False
|
||||||
return (Just locker)
|
return (Just locker)
|
||||||
|
|
|
@ -28,12 +28,12 @@ Planned schedule of work:
|
||||||
|
|
||||||
## work notes
|
## work notes
|
||||||
|
|
||||||
* Implement serveLockContent
|
* Test serveLockContent
|
||||||
|
|
||||||
* A Locker should expire the lock on its own after 10 minutes initially.
|
* A Locker should expire the lock on its own after 10 minutes initially.
|
||||||
|
|
||||||
* Since each held lock needs a connection to a proxy, the Locker
|
* serveKeepLocked should check auth just to be safe, although added
|
||||||
could reference count, and avoid holding more than one lock per key.
|
security is probably minimal.
|
||||||
|
|
||||||
* Make Remote.Git use http client when remote.name.annex-url is configured.
|
* Make Remote.Git use http client when remote.name.annex-url is configured.
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue