{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hercules.CLI.Lock (commandParser) where

import Control.Monad.IO.Unlift (UnliftIO (UnliftIO), askUnliftIO)
import Control.Retry (RetryPolicyM, RetryStatus, capDelay, fullJitterBackoff, retrying, rsIterNumber)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Has (Has)
import Data.IORef (IORef)
import qualified Data.UUID
import qualified Data.UUID.V4 as UUID4
import Hercules.API (Id, NoContent)
import qualified Hercules.API.Accounts.SimpleAccount as SimpleAccount
import qualified Hercules.API.Forge.SimpleForge as SimpleForge
import Hercules.API.Id (Id (Id), idText)
import Hercules.API.Name (nameText)
import qualified Hercules.API.Projects.SimpleJob as SimpleJob
import qualified Hercules.API.Projects.SimpleProject as SimpleProject
import Hercules.API.State (ProjectStateResourceGroup (acquireLock), StateAPI (deleteLockLease, updateLockLease))
import qualified Hercules.API.State.StateLockAcquireRequest as StateLockAcquireRequest
import Hercules.API.State.StateLockAcquireResponse (StateLockAcquireResponse (Acquired, Blocked))
import qualified Hercules.API.State.StateLockAcquireResponse as StateLockAcquireResponse
import qualified Hercules.API.State.StateLockLease as StateLockLease
import qualified Hercules.API.State.StateLockUpdateRequest as StateLockUpdateRequest
import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, clientErrorSummary, determineDefaultApiBaseUrl, runHerculesClientEither, shouldRetryClientError, shouldRetryResponse, stateClient)
import Hercules.CLI.Common (runAuthenticated)
import Hercules.CLI.Options (mkCommand)
import Hercules.CLI.Project (projectOption)
import Hercules.CLI.State (getProjectAndClient)
import Hercules.Error (escalate)
import Hercules.Frontend (mkLinks)
import qualified Hercules.Frontend
import qualified Network.URI
import Options.Applicative (help, long, metavar, strArgument, strOption, subparser)
import qualified Options.Applicative as Optparse
import Protolude
import RIO (RIO)
import Servant.Auth.Client (Token)
import Servant.Client.Core (ClientError)
import Servant.Client.Internal.HttpClient.Streaming (ClientM)
import qualified System.Environment
import qualified System.Process
import qualified UnliftIO
import UnliftIO.IORef (newIORef, readIORef, writeIORef)

commandParser, acquireCommandParser, releaseCommandParser, updateCommandParser, runCommandParser :: Optparse.Parser (IO ())
commandParser :: Parser (IO ())
commandParser =
  forall a. Mod CommandFields a -> Parser a
subparser
    ( forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
        [Char]
"acquire"
        (forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Acquire a lock")
        Parser (IO ())
acquireCommandParser
        forall a. Semigroup a => a -> a -> a
<> forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          [Char]
"update"
          (forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Refresh a lock timeout and/or description")
          Parser (IO ())
updateCommandParser
        forall a. Semigroup a => a -> a -> a
<> forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          [Char]
"release"
          (forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Release a lock")
          Parser (IO ())
releaseCommandParser
        forall a. Semigroup a => a -> a -> a
<> forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          [Char]
"run"
          (forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Run a command holding a lock")
          Parser (IO ())
runCommandParser
    )
acquireCommandParser :: Parser (IO ())
acquireCommandParser = do
  Maybe ProjectPath
projectMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  Text
name <- Parser Text
nameOption
  Bool
json <- Parser Bool
jsonOption
  Text
description <- forall a. a -> Maybe a -> a
fromMaybe Text
"hci lock acquire" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
descriptionOption
  Bool
exclusive <- Parser Bool
exclusiveOption
  Bool
wait_ <- Parser Bool
waitOption
  pure do
    Maybe (Id "StateLockLease")
parent <- IO (Maybe (Id "StateLockLease"))
getLeaseIdFromEnv
    Id "IdempotencyKey"
idempotencyKey <- forall k (a :: k). UUID -> Id a
Id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID4.nextRandom
    let request :: StateLockAcquireRequest
request =
          StateLockAcquireRequest.StateLockAcquireRequest
            { description :: Text
description = Text
description,
              exclusive :: Bool
exclusive = Bool
exclusive,
              parent :: Maybe (Id "StateLockLease")
parent = Maybe (Id "StateLockLease")
parent,
              idempotencyKey :: Maybe (Id "IdempotencyKey")
idempotencyKey = forall a. a -> Maybe a
Just Id "IdempotencyKey"
idempotencyKey
            }
    forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath
-> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient Maybe ProjectPath
projectMaybe
      let acquireReq :: Token -> ClientM StateLockAcquireResponse
acquireReq = forall auth f.
ProjectStateResourceGroup auth f
-> f
   :- (Summary "Acquire a lock"
       :> ("lock"
           :> (Capture' '[Required, Strict] "lockName" Text
               :> (ReqBody '[JSON] StateLockAcquireRequest
                   :> (auth :> Post '[JSON] StateLockAcquireResponse)))))
acquireLock ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient Text
name StateLockAcquireRequest
request
          onAcquire :: StateLockAcquiredResponse -> m ()
onAcquire StateLockAcquiredResponse
s = do
            forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock acquired"
            if Bool
json
              then forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLByteString (forall a. ToJSON a => a -> ByteString
encodePretty StateLockAcquiredResponse
s)
              else forall (m :: * -> *). MonadIO m => Text -> m ()
putText (forall {k} (a :: k). Id a -> Text
idText forall a b. (a -> b) -> a -> b
$ StateLockAcquiredResponse -> Id "StateLockLease"
StateLockAcquireResponse.leaseId StateLockAcquiredResponse
s)
      if Bool
wait_
        then forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquiredResponse
pollAcquire Token -> ClientM StateLockAcquireResponse
acquireReq forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
MonadIO m =>
StateLockAcquiredResponse -> m ()
onAcquire
        else do
          IORef (Maybe StateLockBlockedResponse)
ref <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Maybe a
Nothing
          forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
IORef (Maybe StateLockBlockedResponse)
-> (Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
tryAcquire IORef (Maybe StateLockBlockedResponse)
ref Token -> ClientM StateLockAcquireResponse
acquireReq forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Acquired StateLockAcquiredResponse
s -> forall {m :: * -> *}.
MonadIO m =>
StateLockAcquiredResponse -> m ()
onAcquire StateLockAcquiredResponse
s
            Blocked StateLockBlockedResponse
s -> do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
json do
                forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLByteString (forall a. ToJSON a => a -> ByteString
encodePretty StateLockBlockedResponse
s)
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure
releaseCommandParser :: Parser (IO ())
releaseCommandParser = do
  Id "StateLockLease"
leaseId <- Parser (Id "StateLockLease")
leaseIdOption
  pure do
    forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      (NoContent
_ :: NoContent) <- forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock release" (forall auth f.
StateAPI auth f
-> f
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (auth :> Delete '[JSON] NoContent)))
deleteLockLease StateAPI ClientAuth (AsClientT ClientM)
stateClient Id "StateLockLease"
leaseId)
      forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock released"
updateCommandParser :: Parser (IO ())
updateCommandParser = do
  Id "StateLockLease"
leaseId <- Parser (Id "StateLockLease")
leaseIdOption
  Maybe Text
descriptionUpdate <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
descriptionOption
  Bool
json <- Parser Bool
jsonOption
  pure do
    forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      let request :: StateLockUpdateRequest
request = StateLockUpdateRequest.StateLockUpdateRequest {description :: Maybe Text
description = Maybe Text
descriptionUpdate}
      StateLockAcquiredResponse
response <- forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock update" (forall auth f.
StateAPI auth f
-> f
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (ReqBody '[JSON] StateLockUpdateRequest
               :> (auth :> Post '[JSON] StateLockAcquiredResponse))))
updateLockLease StateAPI ClientAuth (AsClientT ClientM)
stateClient Id "StateLockLease"
leaseId StateLockUpdateRequest
request)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
json do
        forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLByteString (forall a. ToJSON a => a -> ByteString
encodePretty StateLockAcquiredResponse
response)
runCommandParser :: Parser (IO ())
runCommandParser = do
  Maybe ProjectPath
projectMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  Text
name <- Parser Text
nameOption
  Maybe Text
descriptionMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
descriptionOption
  Bool
exclusive <- Parser Bool
exclusiveOption
  [Char]
exe <- forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"COMMAND")
  [[Char]]
args <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"ARGS"))
  pure do
    Maybe (Id "StateLockLease")
parent <- IO (Maybe (Id "StateLockLease"))
getLeaseIdFromEnv
    Id "IdempotencyKey"
idempotencyKey <- forall k (a :: k). UUID -> Id a
Id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID4.nextRandom
    let request :: StateLockAcquireRequest
request =
          StateLockAcquireRequest.StateLockAcquireRequest
            { description :: Text
description = Text
description,
              exclusive :: Bool
exclusive = Bool
exclusive,
              parent :: Maybe (Id "StateLockLease")
parent = Maybe (Id "StateLockLease")
parent,
              idempotencyKey :: Maybe (Id "IdempotencyKey")
idempotencyKey = forall a. a -> Maybe a
Just Id "IdempotencyKey"
idempotencyKey
            }
        description :: Text
description = forall a. a -> Maybe a -> a
fromMaybe (Text
"hci lock run " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS [Char]
exe) Maybe Text
descriptionMaybe
    forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath
-> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient Maybe ProjectPath
projectMaybe
      StateLockAcquiredResponse
lease0 <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquiredResponse
pollAcquire (forall auth f.
ProjectStateResourceGroup auth f
-> f
   :- (Summary "Acquire a lock"
       :> ("lock"
           :> (Capture' '[Required, Strict] "lockName" Text
               :> (ReqBody '[JSON] StateLockAcquireRequest
                   :> (auth :> Post '[JSON] StateLockAcquireResponse)))))
acquireLock ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient Text
name StateLockAcquireRequest
request)
      forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock acquired"
      let leaseId :: Id "StateLockLease"
leaseId = StateLockAcquiredResponse -> Id "StateLockLease"
StateLockAcquireResponse.leaseId StateLockAcquiredResponse
lease0
      ExitCode
exitCode <-
        ( do
            [([Char], [Char])]
env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [([Char], [Char])]
System.Environment.getEnvironment
            let procSpec :: CreateProcess
procSpec = ([Char] -> [[Char]] -> CreateProcess
System.Process.proc [Char]
exe [[Char]]
args) {env :: Maybe [([Char], [Char])]
System.Process.env = forall a. a -> Maybe a
Just [([Char], [Char])]
env'}
                env' :: [([Char], [Char])]
env' = ([Char]
leaseIdEnvVar, forall a b. ConvertText a b => a -> b
toS (forall {k} (a :: k). Id a -> Text
idText Id "StateLockLease"
leaseId)) forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (\([Char]
k, [Char]
_) -> [Char]
k forall a. Eq a => a -> a -> Bool
/= [Char]
leaseIdEnvVar) [([Char], [Char])]
env
                updateRequest :: StateLockUpdateRequest
updateRequest =
                  StateLockUpdateRequest.StateLockUpdateRequest
                    { -- Not changing anything; just pinging
                      description :: Maybe Text
description = forall a. Maybe a
Nothing
                    }
                updateInterval :: Int
updateInterval = Int
3 forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
                pinger :: RIO (HerculesClientToken, HerculesClientEnv) b
pinger = do
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
updateInterval
                  forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
                    ( do
                        (StateLockAcquiredResponse
_ :: StateLockAcquireResponse.StateLockAcquiredResponse) <-
                          forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock pinger" do
                            forall auth f.
StateAPI auth f
-> f
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (ReqBody '[JSON] StateLockUpdateRequest
               :> (auth :> Post '[JSON] StateLockAcquiredResponse))))
updateLockLease StateAPI ClientAuth (AsClientT ClientM)
stateClient Id "StateLockLease"
leaseId StateLockUpdateRequest
updateRequest
                        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
updateInterval
                      )
            UnliftIO forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
unlift <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
              forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync
                (forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
unlift RIO (HerculesClientToken, HerculesClientEnv) Any
pinger)
                ( \Async Any
_ -> do
                    (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
processHandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
System.Process.createProcess CreateProcess
procSpec
                    ProcessHandle -> IO ExitCode
System.Process.waitForProcess ProcessHandle
processHandle
                )
          )
          forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` do
            (NoContent
_ :: NoContent) <- forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock release" (forall auth f.
StateAPI auth f
-> f
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (auth :> Delete '[JSON] NoContent)))
deleteLockLease StateAPI ClientAuth (AsClientT ClientM)
stateClient Id "StateLockLease"
leaseId)
            forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock released"
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ExitCode -> IO a
exitWith ExitCode
exitCode

simpleRetryPredicate :: Applicative m => (r -> Bool) -> RetryStatus -> r -> m Bool
simpleRetryPredicate :: forall (m :: * -> *) r.
Applicative m =>
(r -> Bool) -> RetryStatus -> r -> m Bool
simpleRetryPredicate r -> Bool
f RetryStatus
_rs r
r = forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> Bool
f r
r)

retryOnFail ::
  (NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
  Text ->
  (Token -> ClientM b) ->
  RIO r b
retryOnFail :: forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
shortDesc Token -> ClientM b
req = forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM a) -> RIO r (Either ClientError a)
retryOnFailEither Text
shortDesc Token -> ClientM b
req

retryOnFailEither ::
  (NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
  Text ->
  (Token -> ClientM a) ->
  RIO r (Either ClientError a)
retryOnFailEither :: forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM a) -> RIO r (Either ClientError a)
retryOnFailEither Text
shortDesc Token -> ClientM a
req =
  forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
    forall (m :: * -> *). MonadIO m => RetryPolicyM m
failureRetryPolicy
    (forall (m :: * -> *) r.
Applicative m =>
(r -> Bool) -> RetryStatus -> r -> m Bool
simpleRetryPredicate forall r. Either ClientError r -> Bool
shouldRetryResponse)
    ( \RetryStatus
rs -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RetryStatus -> Int
rsIterNumber RetryStatus
rs forall a. Eq a => a -> a -> Bool
/= Int
0) do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"hci: " forall a. Semigroup a => a -> a -> a
<> Text
shortDesc forall a. Semigroup a => a -> a -> a
<> Text
" retrying."
        Either ClientError a
r <- forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r (Either ClientError a)
runHerculesClientEither Token -> ClientM a
req
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall l r. Either l r -> Maybe l
leftToMaybe Either ClientError a
r) \ClientError
e -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"hci: " forall a. Semigroup a => a -> a -> a
<> Text
shortDesc forall a. Semigroup a => a -> a -> a
<> Text
" encountered " forall a. Semigroup a => a -> a -> a
<> ClientError -> Text
clientErrorSummary ClientError
e forall a. Semigroup a => a -> a -> a
<> Text
"."
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientError -> Bool
shouldRetryClientError ClientError
e) do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"hci: " forall a. Semigroup a => a -> a -> a
<> Text
shortDesc forall a. Semigroup a => a -> a -> a
<> Text
" will retry."
        pure Either ClientError a
r
    )

-- NB: fullJitterBackoff is broken, https://github.com/Soostone/retry/issues/46
failureRetryPolicy :: MonadIO m => RetryPolicyM m
failureRetryPolicy :: forall (m :: * -> *). MonadIO m => RetryPolicyM m
failureRetryPolicy = forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay (Int
120 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000) (forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
100000)

-- NB: fullJitterBackoff is broken, https://github.com/Soostone/retry/issues/46
waitRetryPolicy :: MonadIO m => RetryPolicyM m
waitRetryPolicy :: forall (m :: * -> *). MonadIO m => RetryPolicyM m
waitRetryPolicy = forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay (Int
10 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000) (forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
500000)

tryAcquire ::
  (Has HerculesClientToken r, Has HerculesClientEnv r) =>
  IORef (Maybe StateLockAcquireResponse.StateLockBlockedResponse) ->
  (Token -> ClientM StateLockAcquireResponse) ->
  RIO r StateLockAcquireResponse
tryAcquire :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
IORef (Maybe StateLockBlockedResponse)
-> (Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
tryAcquire IORef (Maybe StateLockBlockedResponse)
ref Token -> ClientM StateLockAcquireResponse
acquireLockRequest = do
  StateLockAcquireResponse
r <- forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock acquire" Token -> ClientM StateLockAcquireResponse
acquireLockRequest
  case StateLockAcquireResponse
r of
    Blocked StateLockBlockedResponse
s -> forall (m :: * -> *).
MonadIO m =>
IORef (Maybe StateLockBlockedResponse)
-> StateLockBlockedResponse -> m ()
logBlockedMaybe IORef (Maybe StateLockBlockedResponse)
ref StateLockBlockedResponse
s
    Acquired {} -> forall (f :: * -> *). Applicative f => f ()
pass
  pure StateLockAcquireResponse
r

pollAcquire ::
  (Has HerculesClientToken r, Has HerculesClientEnv r) =>
  (Token -> ClientM StateLockAcquireResponse) ->
  RIO r StateLockAcquireResponse.StateLockAcquiredResponse
pollAcquire :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquiredResponse
pollAcquire Token -> ClientM StateLockAcquireResponse
acquireLockRequest = do
  IORef (Maybe StateLockBlockedResponse)
ref <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Maybe a
Nothing
  StateLockAcquireResponse
finalResp <-
    forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
      forall (m :: * -> *). MonadIO m => RetryPolicyM m
waitRetryPolicy
      ( \RetryStatus
_rs StateLockAcquireResponse
s -> case StateLockAcquireResponse
s of
          Blocked {} -> do
            forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: waiting for lock..."
            pure Bool
True
          Acquired {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      )
      (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
IORef (Maybe StateLockBlockedResponse)
-> (Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
tryAcquire IORef (Maybe StateLockBlockedResponse)
ref Token -> ClientM StateLockAcquireResponse
acquireLockRequest)
  case StateLockAcquireResponse
finalResp of
    Blocked {} -> forall a. HasCallStack => Text -> a
panic Text
"Retrying timed out" -- won't happen; policy is indefinite
    Acquired StateLockAcquiredResponse
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StateLockAcquiredResponse
s

logBlockedMaybe ::
  MonadIO m =>
  IORef (Maybe StateLockAcquireResponse.StateLockBlockedResponse) ->
  StateLockAcquireResponse.StateLockBlockedResponse ->
  m ()
logBlockedMaybe :: forall (m :: * -> *).
MonadIO m =>
IORef (Maybe StateLockBlockedResponse)
-> StateLockBlockedResponse -> m ()
logBlockedMaybe IORef (Maybe StateLockBlockedResponse)
ref StateLockBlockedResponse
resp = do
  Maybe StateLockBlockedResponse
old <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe StateLockBlockedResponse)
ref
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe StateLockBlockedResponse
old forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just StateLockBlockedResponse
resp) do
    forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe StateLockBlockedResponse)
ref (forall a. a -> Maybe a
Just StateLockBlockedResponse
resp)
    forall (m :: * -> *). MonadIO m => StateLockBlockedResponse -> m ()
logBlocked StateLockBlockedResponse
resp

logBlocked :: MonadIO m => StateLockAcquireResponse.StateLockBlockedResponse -> m ()
logBlocked :: forall (m :: * -> *). MonadIO m => StateLockBlockedResponse -> m ()
logBlocked StateLockBlockedResponse
s = do
  forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock blocked"
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (StateLockBlockedResponse -> [StateLockLease]
StateLockAcquireResponse.blockedByLeases StateLockBlockedResponse
s) \StateLockLease
lease -> do
    forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"blocked by lease:"
    forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"  description: " forall a. Semigroup a => a -> a -> a
<> StateLockLease -> Text
StateLockLease.description StateLockLease
lease
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (StateLockLease -> Maybe SimpleAccount
StateLockLease.user StateLockLease
lease) \SimpleAccount
user ->
      forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"  user: " forall a. Semigroup a => a -> a -> a
<> SimpleAccount -> Text
SimpleAccount.displayName SimpleAccount
user forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall k (a :: k). Name a -> Text
nameText (SimpleAccount -> Name Account
SimpleAccount.name SimpleAccount
user) forall a. Semigroup a => a -> a -> a
<> Text
")"
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (StateLockLease -> Maybe SimpleJob
StateLockLease.job StateLockLease
lease) \SimpleJob
job -> do
      URI
baseUri <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO URI
getLinksBase
      let links :: FrontendRoutes Raw (AsLink Text)
links = URI -> FrontendRoutes Raw (AsLink Text)
mkLinks URI
baseUri
          project :: SimpleProject
project = SimpleJob -> SimpleProject
SimpleJob.project SimpleJob
job
          jobUrl :: Text
jobUrl =
            forall view f.
FrontendRoutes view f
-> f
   :- (Capture' '[Required, Strict] "site" (Name Forge)
       :> (Capture' '[Required, Strict] "account" (Name Account)
           :> (Capture' '[Required, Strict] "project" (Name Project)
               :> ("jobs"
                   :> (Capture' '[Required, Strict] "jobIndex" Int :> view)))))
Hercules.Frontend.job
              FrontendRoutes Raw (AsLink Text)
links
              (SimpleForge -> Name Forge
SimpleForge.name forall a b. (a -> b) -> a -> b
$ SimpleAccount -> SimpleForge
SimpleAccount.site forall a b. (a -> b) -> a -> b
$ SimpleProject -> SimpleAccount
SimpleProject.owner SimpleProject
project)
              (SimpleAccount -> Name Account
SimpleAccount.name forall a b. (a -> b) -> a -> b
$ SimpleProject -> SimpleAccount
SimpleProject.owner SimpleProject
project)
              (SimpleProject -> Name Project
SimpleProject.name SimpleProject
project)
              (forall a b. (Integral a, Num b) => a -> b
fromIntegral (SimpleJob -> Int64
SimpleJob.index SimpleJob
job))
      forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"  job: " forall a. Semigroup a => a -> a -> a
<> Text
jobUrl

getLinksBase :: IO Network.URI.URI
getLinksBase :: IO URI
getLinksBase = do
  Text
url <- IO Text
determineDefaultApiBaseUrl
  case [Char] -> Maybe URI
Network.URI.parseAbsoluteURI (forall a b. ConvertText a b => a -> b
toS Text
url) of
    Just URI
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
x
    Maybe URI
Nothing -> forall a. HasCallStack => Text -> a
panic Text
"Could not parse API base url"

-- TODO: bytestring
leaseIdEnvVar :: [Char]
leaseIdEnvVar :: [Char]
leaseIdEnvVar = [Char]
"HERCULES_CI_LOCK_LEASE_ID"

getLeaseIdFromEnv :: IO (Maybe (Id "StateLockLease"))
getLeaseIdFromEnv :: IO (Maybe (Id "StateLockLease"))
getLeaseIdFromEnv = do
  Maybe [Char]
strMaybe <- [Char] -> IO (Maybe [Char])
System.Environment.lookupEnv [Char]
leaseIdEnvVar
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe [Char]
strMaybe \[Char]
str -> case [Char] -> Maybe UUID
Data.UUID.fromString [Char]
str of
    Just UUID
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k (a :: k). UUID -> Id a
Id UUID
x)
    Maybe UUID
Nothing -> do
      forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putErrLn ([Char]
leaseIdEnvVar forall a. Semigroup a => a -> a -> a
<> [Char]
" is not a valid UUID")
      forall a. IO a
exitFailure

nameOption :: Optparse.Parser Text
nameOption :: Parser Text
nameOption = forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"name" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"NAME" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Name of the lock"

jsonOption :: Optparse.Parser Bool
jsonOption :: Parser Bool
jsonOption = forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag Bool
False Bool
True (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"json" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Write JSON results on stdout")

descriptionOption :: Optparse.Parser Text
descriptionOption :: Parser Text
descriptionOption = forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"description" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"TEXT" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Describe the lock activity, for better messages"

-- NB: exclusive by default; inversion is contained
exclusiveOption :: Optparse.Parser Bool
exclusiveOption :: Parser Bool
exclusiveOption = forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"non-exclusive" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Acquire a non-exclusive lock aka read lock")

-- NB: wait by default; inversion is contained
waitOption :: Optparse.Parser Bool
waitOption :: Parser Bool
waitOption = forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"no-wait" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Fail immediately when the lock is already taken")

leaseIdOption :: Optparse.Parser (Id "StateLockLease")
leaseIdOption :: Parser (Id "StateLockLease")
leaseIdOption = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (a :: k). UUID -> Id a
Id forall a b. (a -> b) -> a -> b
$ forall a. ReadM a -> Mod OptionFields a -> Parser a
Optparse.option forall a. Read a => ReadM a
Optparse.auto forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"lease-id" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"UUID" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Lease UUID"