{-# 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 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 qualified Hercules.API.SourceHostingSite.SimpleSite as SimpleSite
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 =
  Mod CommandFields (IO ()) -> Parser (IO ())
forall a. Mod CommandFields a -> Parser a
subparser
    ( [Char]
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
        [Char]
"acquire"
        ([Char] -> InfoMod (IO ())
forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Acquire a lock")
        Parser (IO ())
acquireCommandParser
        Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> [Char]
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          [Char]
"update"
          ([Char] -> InfoMod (IO ())
forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Refresh a lock timeout and/or description")
          Parser (IO ())
updateCommandParser
        Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> [Char]
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          [Char]
"release"
          ([Char] -> InfoMod (IO ())
forall a. [Char] -> InfoMod a
Optparse.progDesc [Char]
"Release a lock")
          Parser (IO ())
releaseCommandParser
        Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> [Char]
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. [Char] -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          [Char]
"run"
          ([Char] -> InfoMod (IO ())
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 <- Parser ProjectPath -> Parser (Maybe ProjectPath)
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 <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"hci lock acquire" (Maybe Text -> Text) -> Parser (Maybe Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser (Maybe Text)
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 <- UUID -> Id "IdempotencyKey"
forall k (a :: k). UUID -> Id a
Id (UUID -> Id "IdempotencyKey")
-> IO UUID -> IO (Id "IdempotencyKey")
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID4.nextRandom
    let request :: StateLockAcquireRequest
request =
          StateLockAcquireRequest :: Text
-> Bool
-> Maybe (Id "StateLockLease")
-> Maybe (Id "IdempotencyKey")
-> StateLockAcquireRequest
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 = Id "IdempotencyKey" -> Maybe (Id "IdempotencyKey")
forall a. a -> Maybe a
Just Id "IdempotencyKey"
idempotencyKey
            }
    RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient <- Maybe ProjectPath
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
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 = ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- (Summary "Acquire a lock"
       :> ("lock"
           :> (Capture' '[Required, Strict] "lockName" Text
               :> (ReqBody '[JSON] StateLockAcquireRequest
                   :> (ClientAuth :> Post '[JSON] StateLockAcquireResponse)))))
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
            Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock acquired"
            if Bool
json
              then ByteString -> m ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLByteString (StateLockAcquiredResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty StateLockAcquiredResponse
s)
              else Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText (Id "StateLockLease" -> Text
forall {k} (a :: k). Id a -> Text
idText (Id "StateLockLease" -> Text) -> Id "StateLockLease" -> Text
forall a b. (a -> b) -> a -> b
$ StateLockAcquiredResponse -> Id "StateLockLease"
StateLockAcquireResponse.leaseId StateLockAcquiredResponse
s)
      if Bool
wait_
        then (Token -> ClientM StateLockAcquireResponse)
-> RIO
     (HerculesClientToken, HerculesClientEnv) StateLockAcquiredResponse
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquiredResponse
pollAcquire Token -> ClientM StateLockAcquireResponse
acquireReq RIO
  (HerculesClientToken, HerculesClientEnv) StateLockAcquiredResponse
-> (StateLockAcquiredResponse
    -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateLockAcquiredResponse
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall {m :: * -> *}.
MonadIO m =>
StateLockAcquiredResponse -> m ()
onAcquire
        else do
          IORef (Maybe StateLockBlockedResponse)
ref <- Maybe StateLockBlockedResponse
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (IORef (Maybe StateLockBlockedResponse))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe StateLockBlockedResponse
forall a. Maybe a
Nothing
          IORef (Maybe StateLockBlockedResponse)
-> (Token -> ClientM StateLockAcquireResponse)
-> RIO
     (HerculesClientToken, HerculesClientEnv) StateLockAcquireResponse
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 RIO
  (HerculesClientToken, HerculesClientEnv) StateLockAcquireResponse
-> (StateLockAcquireResponse
    -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Acquired StateLockAcquiredResponse
s -> StateLockAcquiredResponse
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall {m :: * -> *}.
MonadIO m =>
StateLockAcquiredResponse -> m ()
onAcquire StateLockAcquiredResponse
s
            Blocked StateLockBlockedResponse
s -> do
              Bool
-> RIO (HerculesClientToken, HerculesClientEnv) ()
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
json do
                ByteString -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLByteString (StateLockBlockedResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty StateLockBlockedResponse
s)
              IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
exitFailure
releaseCommandParser :: Parser (IO ())
releaseCommandParser = do
  Id "StateLockLease"
leaseId <- Parser (Id "StateLockLease")
leaseIdOption
  pure do
    RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      (NoContent
_ :: NoContent) <- Text
-> (Token -> ClientM NoContent)
-> RIO (HerculesClientToken, HerculesClientEnv) NoContent
forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock release" (StateAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (ClientAuth :> Delete '[JSON] NoContent)))
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)
      Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
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 <- Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
descriptionOption
  Bool
json <- Parser Bool
jsonOption
  pure do
    RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      let request :: StateLockUpdateRequest
request = StateLockUpdateRequest :: Maybe Text -> StateLockUpdateRequest
StateLockUpdateRequest.StateLockUpdateRequest {description :: Maybe Text
description = Maybe Text
descriptionUpdate}
      StateLockAcquiredResponse
response <- Text
-> (Token -> ClientM StateLockAcquiredResponse)
-> RIO
     (HerculesClientToken, HerculesClientEnv) StateLockAcquiredResponse
forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock update" (StateAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (ReqBody '[JSON] StateLockUpdateRequest
               :> (ClientAuth :> Post '[JSON] StateLockAcquiredResponse))))
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)
      Bool
-> RIO (HerculesClientToken, HerculesClientEnv) ()
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
json do
        ByteString -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLByteString (StateLockAcquiredResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty StateLockAcquiredResponse
response)
runCommandParser :: Parser (IO ())
runCommandParser = do
  Maybe ProjectPath
projectMaybe <- Parser ProjectPath -> Parser (Maybe ProjectPath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  Text
name <- Parser Text
nameOption
  Maybe Text
descriptionMaybe <- Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
descriptionOption
  Bool
exclusive <- Parser Bool
exclusiveOption
  [Char]
exe <- Mod ArgumentFields [Char] -> Parser [Char]
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument ([Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"COMMAND")
  [[Char]]
args <- Parser [Char] -> Parser [[Char]]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod ArgumentFields [Char] -> Parser [Char]
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument ([Char] -> Mod ArgumentFields [Char]
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 <- UUID -> Id "IdempotencyKey"
forall k (a :: k). UUID -> Id a
Id (UUID -> Id "IdempotencyKey")
-> IO UUID -> IO (Id "IdempotencyKey")
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID4.nextRandom
    let request :: StateLockAcquireRequest
request =
          StateLockAcquireRequest :: Text
-> Bool
-> Maybe (Id "StateLockLease")
-> Maybe (Id "IdempotencyKey")
-> StateLockAcquireRequest
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 = Id "IdempotencyKey" -> Maybe (Id "IdempotencyKey")
forall a. a -> Maybe a
Just Id "IdempotencyKey"
idempotencyKey
            }
        description :: Text
description = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text
"hci lock run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a b. ConvertText a b => a -> b
toS [Char]
exe) Maybe Text
descriptionMaybe
    RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient <- Maybe ProjectPath
-> RIO
     (HerculesClientToken, HerculesClientEnv)
     (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath
-> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient Maybe ProjectPath
projectMaybe
      StateLockAcquiredResponse
lease0 <- (Token -> ClientM StateLockAcquireResponse)
-> RIO
     (HerculesClientToken, HerculesClientEnv) StateLockAcquiredResponse
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquiredResponse
pollAcquire (ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- (Summary "Acquire a lock"
       :> ("lock"
           :> (Capture' '[Required, Strict] "lockName" Text
               :> (ReqBody '[JSON] StateLockAcquireRequest
                   :> (ClientAuth :> Post '[JSON] StateLockAcquireResponse)))))
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)
      Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
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 <- IO [([Char], [Char])]
-> RIO (HerculesClientToken, HerculesClientEnv) [([Char], [Char])]
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 = [([Char], [Char])] -> Maybe [([Char], [Char])]
forall a. a -> Maybe a
Just [([Char], [Char])]
env'}
                env' :: [([Char], [Char])]
env' = ([Char]
leaseIdEnvVar, Text -> [Char]
forall a b. ConvertText a b => a -> b
toS (Id "StateLockLease" -> Text
forall {k} (a :: k). Id a -> Text
idText Id "StateLockLease"
leaseId)) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Char]
k, [Char]
_) -> [Char]
k [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
leaseIdEnvVar) [([Char], [Char])]
env
                updateRequest :: StateLockUpdateRequest
updateRequest =
                  StateLockUpdateRequest :: Maybe Text -> StateLockUpdateRequest
StateLockUpdateRequest.StateLockUpdateRequest
                    { -- Not changing anything; just pinging
                      description :: Maybe Text
description = Maybe Text
forall a. Maybe a
Nothing
                    }
                updateInterval :: Int
updateInterval = Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
                pinger :: RIO (HerculesClientToken, HerculesClientEnv) b
pinger = do
                  IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
updateInterval
                  RIO (HerculesClientToken, HerculesClientEnv) ()
-> RIO (HerculesClientToken, HerculesClientEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
                    ( do
                        (StateLockAcquiredResponse
_ :: StateLockAcquireResponse.StateLockAcquiredResponse) <-
                          Text
-> (Token -> ClientM StateLockAcquiredResponse)
-> RIO
     (HerculesClientToken, HerculesClientEnv) StateLockAcquiredResponse
forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock pinger" do
                            StateAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (ReqBody '[JSON] StateLockUpdateRequest
               :> (ClientAuth :> Post '[JSON] StateLockAcquiredResponse))))
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
                        IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
updateInterval
                      )
            UnliftIO forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
unlift <- RIO
  (HerculesClientToken, HerculesClientEnv)
  (UnliftIO (RIO (HerculesClientToken, HerculesClientEnv)))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
            IO ExitCode
-> RIO (HerculesClientToken, HerculesClientEnv) ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
              IO Any -> (Async Any -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync
                (RIO (HerculesClientToken, HerculesClientEnv) Any -> IO Any
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
                )
          )
          RIO (HerculesClientToken, HerculesClientEnv) ExitCode
-> RIO (HerculesClientToken, HerculesClientEnv) ()
-> RIO (HerculesClientToken, HerculesClientEnv) ExitCode
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` do
            (NoContent
_ :: NoContent) <- Text
-> (Token -> ClientM NoContent)
-> RIO (HerculesClientToken, HerculesClientEnv) NoContent
forall b r.
(NFData b, Has HerculesClientToken r, Has HerculesClientEnv r) =>
Text -> (Token -> ClientM b) -> RIO r b
retryOnFail Text
"lock release" (StateAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
   :- ("lock-leases"
       :> (Capture'
             '[Required, Strict] "lockLeaseId" (Id "StateLockLease")
           :> (ClientAuth :> Delete '[JSON] NoContent)))
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)
            Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock released"
      IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
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 = Bool -> m Bool
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 = Either ClientError b -> RIO r b
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate (Either ClientError b -> RIO r b)
-> RIO r (Either ClientError b) -> RIO r b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> (Token -> ClientM b) -> RIO r (Either ClientError 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 =
  RetryPolicyM (RIO r)
-> (RetryStatus -> Either ClientError a -> RIO r Bool)
-> (RetryStatus -> RIO r (Either ClientError a))
-> RIO r (Either ClientError a)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
    RetryPolicyM (RIO r)
forall (m :: * -> *). MonadIO m => RetryPolicyM m
failureRetryPolicy
    ((Either ClientError a -> Bool)
-> RetryStatus -> Either ClientError a -> RIO r Bool
forall (m :: * -> *) r.
Applicative m =>
(r -> Bool) -> RetryStatus -> r -> m Bool
simpleRetryPredicate Either ClientError a -> Bool
forall r. Either ClientError r -> Bool
shouldRetryResponse)
    ( \RetryStatus
rs -> do
        Bool -> RIO r () -> RIO r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RetryStatus -> Int
rsIterNumber RetryStatus
rs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) do
          IO () -> RIO r ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO r ()) -> IO () -> RIO r ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shortDesc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" retrying."
        Either ClientError a
r <- (Token -> ClientM a) -> RIO r (Either ClientError a)
forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r (Either ClientError a)
runHerculesClientEither Token -> ClientM a
req
        Maybe ClientError -> (ClientError -> RIO r ()) -> RIO r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Either ClientError a -> Maybe ClientError
forall l r. Either l r -> Maybe l
leftToMaybe Either ClientError a
r) \ClientError
e -> do
          IO () -> RIO r ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO r ()) -> IO () -> RIO r ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shortDesc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" encountered " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ClientError -> Text
clientErrorSummary ClientError
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
          Bool -> RIO r () -> RIO r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientError -> Bool
shouldRetryClientError ClientError
e) do
            IO () -> RIO r ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO r ()) -> IO () -> RIO r ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shortDesc Text -> Text -> Text
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 = Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay (Int
120 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (Int -> RetryPolicyM m
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 = Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (Int -> RetryPolicyM m
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 <- Text
-> (Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
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 -> IORef (Maybe StateLockBlockedResponse)
-> StateLockBlockedResponse -> RIO r ()
forall (m :: * -> *).
MonadIO m =>
IORef (Maybe StateLockBlockedResponse)
-> StateLockBlockedResponse -> m ()
logBlockedMaybe IORef (Maybe StateLockBlockedResponse)
ref StateLockBlockedResponse
s
    Acquired {} -> RIO r ()
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 <- Maybe StateLockBlockedResponse
-> RIO r (IORef (Maybe StateLockBlockedResponse))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe StateLockBlockedResponse
forall a. Maybe a
Nothing
  StateLockAcquireResponse
finalResp <-
    RetryPolicyM (RIO r)
-> (RetryStatus -> StateLockAcquireResponse -> RIO r Bool)
-> (RetryStatus -> RIO r StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
      RetryPolicyM (RIO r)
forall (m :: * -> *). MonadIO m => RetryPolicyM m
waitRetryPolicy
      ( \RetryStatus
_rs StateLockAcquireResponse
s -> case StateLockAcquireResponse
s of
          Blocked {} -> do
            Text -> RIO r ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: waiting for lock..."
            pure Bool
True
          Acquired {} -> Bool -> RIO r Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      )
      (RIO r StateLockAcquireResponse
-> RetryStatus -> RIO r StateLockAcquireResponse
forall a b. a -> b -> a
const (RIO r StateLockAcquireResponse
 -> RetryStatus -> RIO r StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
-> RetryStatus
-> RIO r StateLockAcquireResponse
forall a b. (a -> b) -> a -> b
$ IORef (Maybe StateLockBlockedResponse)
-> (Token -> ClientM StateLockAcquireResponse)
-> RIO r StateLockAcquireResponse
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 {} -> Text -> RIO r StateLockAcquiredResponse
forall a. HasCallStack => Text -> a
panic Text
"Retrying timed out" -- won't happen; policy is indefinite
    Acquired StateLockAcquiredResponse
s -> StateLockAcquiredResponse -> RIO r StateLockAcquiredResponse
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 <- IORef (Maybe StateLockBlockedResponse)
-> m (Maybe StateLockBlockedResponse)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe StateLockBlockedResponse)
ref
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe StateLockBlockedResponse
old Maybe StateLockBlockedResponse
-> Maybe StateLockBlockedResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= StateLockBlockedResponse -> Maybe StateLockBlockedResponse
forall a. a -> Maybe a
Just StateLockBlockedResponse
resp) do
    IORef (Maybe StateLockBlockedResponse)
-> Maybe StateLockBlockedResponse -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe StateLockBlockedResponse)
ref (StateLockBlockedResponse -> Maybe StateLockBlockedResponse
forall a. a -> Maybe a
Just StateLockBlockedResponse
resp)
    StateLockBlockedResponse -> m ()
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
  Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"hci: lock blocked"
  [StateLockLease] -> (StateLockLease -> m ()) -> m ()
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
    Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"blocked by lease:"
    Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"  description: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StateLockLease -> Text
StateLockLease.description StateLockLease
lease
    Maybe SimpleAccount -> (SimpleAccount -> m ()) -> m ()
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 ->
      Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"  user: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SimpleAccount -> Text
SimpleAccount.displayName SimpleAccount
user Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name Account -> Text
forall k (a :: k). Name a -> Text
nameText (SimpleAccount -> Name Account
SimpleAccount.name SimpleAccount
user) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    Maybe SimpleJob -> (SimpleJob -> m ()) -> m ()
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 <- IO URI -> m URI
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 =
            FrontendRoutes Raw (AsLink Text)
-> AsLink Text
   :- (Capture' '[Required, Strict] "site" (Name SourceHostingSite)
       :> (Capture' '[Required, Strict] "account" (Name Account)
           :> (Capture' '[Required, Strict] "project" (Name Project)
               :> ("jobs"
                   :> (Capture' '[Required, Strict] "jobIndex" Int :> Raw)))))
forall view f.
FrontendRoutes view f
-> f
   :- (Capture' '[Required, Strict] "site" (Name SourceHostingSite)
       :> (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
              (SimpleSite -> Name SourceHostingSite
SimpleSite.name (SimpleSite -> Name SourceHostingSite)
-> SimpleSite -> Name SourceHostingSite
forall a b. (a -> b) -> a -> b
$ SimpleAccount -> SimpleSite
SimpleAccount.site (SimpleAccount -> SimpleSite) -> SimpleAccount -> SimpleSite
forall a b. (a -> b) -> a -> b
$ SimpleProject -> SimpleAccount
SimpleProject.owner SimpleProject
project)
              (SimpleAccount -> Name Account
SimpleAccount.name (SimpleAccount -> Name Account) -> SimpleAccount -> Name Account
forall a b. (a -> b) -> a -> b
$ SimpleProject -> SimpleAccount
SimpleProject.owner SimpleProject
project)
              (SimpleProject -> Name Project
SimpleProject.name SimpleProject
project)
              (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SimpleJob -> Int64
SimpleJob.index SimpleJob
job))
      Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"  job: " Text -> Text -> Text
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 (Text -> [Char]
forall a b. ConvertText a b => a -> b
toS Text
url) of
    Just URI
x -> URI -> IO URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
x
    Maybe URI
Nothing -> Text -> IO URI
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
  Maybe [Char]
-> ([Char] -> IO (Id "StateLockLease"))
-> IO (Maybe (Id "StateLockLease"))
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 -> Id "StateLockLease" -> IO (Id "StateLockLease")
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UUID -> Id "StateLockLease"
forall k (a :: k). UUID -> Id a
Id UUID
x)
    Maybe UUID
Nothing -> do
      [Char] -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putErrLn ([Char]
leaseIdEnvVar [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not a valid UUID")
      IO (Id "StateLockLease")
forall a. IO a
exitFailure

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

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

descriptionOption :: Optparse.Parser Text
descriptionOption :: Parser Text
descriptionOption = Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields Text -> Parser Text)
-> Mod OptionFields Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"description" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"TEXT" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields Text
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 = Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag Bool
True Bool
False ([Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"non-exclusive" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields Bool
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 = Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
Optparse.flag Bool
True Bool
False ([Char] -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"no-wait" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields Bool
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 = (UUID -> Id "StateLockLease")
-> Parser UUID -> Parser (Id "StateLockLease")
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UUID -> Id "StateLockLease"
forall k (a :: k). UUID -> Id a
Id (Parser UUID -> Parser (Id "StateLockLease"))
-> Parser UUID -> Parser (Id "StateLockLease")
forall a b. (a -> b) -> a -> b
$ ReadM UUID -> Mod OptionFields UUID -> Parser UUID
forall a. ReadM a -> Mod OptionFields a -> Parser a
Optparse.option ReadM UUID
forall a. Read a => ReadM a
Optparse.auto (Mod OptionFields UUID -> Parser UUID)
-> Mod OptionFields UUID -> Parser UUID
forall a b. (a -> b) -> a -> b
$ [Char] -> Mod OptionFields UUID
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"lease-id" Mod OptionFields UUID
-> Mod OptionFields UUID -> Mod OptionFields UUID
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields UUID
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"UUID" Mod OptionFields UUID
-> Mod OptionFields UUID -> Mod OptionFields UUID
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields UUID
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Lease UUID"