{-# LANGUAGE TypeFamilies #-}

module Hercules.CLI.Project where

import qualified Data.Attoparsec.Text as A
import Data.Has (Has)
import qualified Data.UUID
import Hercules.API (ClientAuth, Id, enterApiE)
import Hercules.API.Id (Id (Id))
import Hercules.API.Name (Name (Name))
import Hercules.API.Projects (ProjectResourceGroup, ProjectsAPI (byProjectName), findProjects)
import qualified Hercules.API.Projects as Projects
import Hercules.API.Projects.Project (Project)
import qualified Hercules.API.Projects.Project as Project
import qualified Hercules.API.Repos as Repos
import qualified Hercules.API.Repos.RepoKey as RepoKey
import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, projectsClient, reposClient, runHerculesClient, runHerculesClientEither)
import Hercules.CLI.Common (exitMsg)
import qualified Hercules.CLI.Git as Git
import Hercules.CLI.Options (attoparsecReader, packSome)
import Hercules.Error (escalate, escalateAs)
import Network.HTTP.Types (Status (Status, statusCode))
import Options.Applicative (bashCompleter, completer, help, long, metavar, option, strOption)
import qualified Options.Applicative as Optparse
import Protolude
import RIO (RIO)
import Servant.Client.Core (ClientError (FailureResponse), ResponseF (responseStatusCode))
import Servant.Client.Core.Response (ResponseF (Response))
import Servant.Client.Generic (AsClientT)
import Servant.Client.Streaming (ClientM)
import UnliftIO.Environment (lookupEnv)
import qualified Prelude

data ProjectPath = ProjectPath
  { ProjectPath -> Text
projectPathSite :: Text,
    ProjectPath -> Text
projectPathOwner :: Text,
    ProjectPath -> Text
projectPathProject :: Text
  }

instance Prelude.Show ProjectPath where
  show :: ProjectPath -> FilePath
show = forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPath -> Text
projectPathText

projectPathText :: ProjectPath -> Text
projectPathText :: ProjectPath -> Text
projectPathText = ProjectPath -> Text
projectPathSite forall a. Semigroup a => a -> a -> a
<> forall a b. a -> b -> a
const Text
"/" forall a. Semigroup a => a -> a -> a
<> ProjectPath -> Text
projectPathOwner forall a. Semigroup a => a -> a -> a
<> forall a b. a -> b -> a
const Text
"/" forall a. Semigroup a => a -> a -> a
<> ProjectPath -> Text
projectPathProject

projectOption :: Optparse.Parser ProjectPath
projectOption :: Parser ProjectPath
projectOption =
  forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM ProjectPath
projectPathReadM forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"project" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PROJECT" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Project path, e.g. github/my-org/my-project"

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 => FilePath -> Mod f a
long FilePath
"name" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Name of the state file"

fileOption :: Optparse.Parser FilePath
fileOption :: Parser FilePath
fileOption = forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"file" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FILE" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Local path of the state file or - for stdio" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (FilePath -> Completer
bashCompleter FilePath
"file")

projectPathReadM :: Optparse.ReadM ProjectPath
projectPathReadM :: ReadM ProjectPath
projectPathReadM = forall a. Parser a -> ReadM a
attoparsecReader Parser ProjectPath
parseProjectPath

parseProjectPath :: A.Parser ProjectPath
parseProjectPath :: Parser ProjectPath
parseProjectPath =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Text -> Text -> Text -> ProjectPath
ProjectPath
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char -> Parser Text
packSome ((Char -> Bool) -> Parser Char
A.satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'/'))
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'/'
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char -> Parser Text
packSome ((Char -> Bool) -> Parser Char
A.satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'/'))
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'/'
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char -> Parser Text
packSome ((Char -> Bool) -> Parser Char
A.satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'/'))

parseProjectPathFromText :: Text -> Either [Char] ProjectPath
parseProjectPathFromText :: Text -> Either FilePath ProjectPath
parseProjectPathFromText = forall a. Parser a -> Text -> Either FilePath a
A.parseOnly Parser ProjectPath
parseProjectPath

getProjectPath :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r ProjectPath
getProjectPath :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> RIO r ProjectPath
getProjectPath Maybe ProjectPath
maybeProjectPathParam =
  case Maybe ProjectPath
maybeProjectPathParam of
    Maybe ProjectPath
Nothing -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
RIO r (Maybe (Id Project), ProjectPath)
findProjectContextually
    Just ProjectPath
projectKey -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectPath
projectKey

getProjectIdAndPath :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r (Maybe (Id Project), ProjectPath)
getProjectIdAndPath :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> RIO r (Maybe (Id Project), ProjectPath)
getProjectIdAndPath Maybe ProjectPath
maybeProjectPathParam = do
  case Maybe ProjectPath
maybeProjectPathParam of
    Maybe ProjectPath
Nothing -> forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
RIO r (Maybe (Id Project), ProjectPath)
findProjectContextually
    Just ProjectPath
projectKey -> do
      Maybe Project
project <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
ProjectPath -> RIO r (Maybe Project)
findProjectByKey ProjectPath
projectKey
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project -> Id Project
Project.id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Project
project, ProjectPath
projectKey)

findProjectByKey :: (Has HerculesClientToken r, Has HerculesClientEnv r) => ProjectPath -> RIO r (Maybe Project.Project)
findProjectByKey :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
ProjectPath -> RIO r (Maybe Project)
findProjectByKey ProjectPath
path =
  forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r a
runHerculesClient
    ( forall auth f.
ProjectsAPI auth f
-> f
   :- (Summary "Find projects"
       :> ("projects"
           :> (QueryParam' '[Optional] "site" (Name Forge)
               :> (QueryParam' '[Optional] "account" (Name Account)
                   :> (QueryParam' '[Optional] "project" (Name Project)
                       :> (auth :> Get '[JSON] [Project]))))))
Projects.findProjects
        ProjectsAPI ClientAuth (AsClientT ClientM)
projectsClient
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathSite ProjectPath
path)
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathOwner ProjectPath
path)
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathProject ProjectPath
path)
    )
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head

findProjectContextually :: (Has HerculesClientToken r, Has HerculesClientEnv r) => RIO r (Maybe (Id Project), ProjectPath)
findProjectContextually :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
RIO r (Maybe (Id Project), ProjectPath)
findProjectContextually = do
  Maybe FilePath
projectIdMaybe <- forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"HERCULES_CI_PROJECT_ID"
  Maybe FilePath
projectIdPathMaybe <- forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"HERCULES_CI_PROJECT_PATH"
  case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
projectIdMaybe forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe FilePath
projectIdPathMaybe of
    Maybe (FilePath, FilePath)
Nothing -> forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
RIO r (Maybe (Id Project), ProjectPath)
findProjectByCurrentRepo
    Just (FilePath
id, FilePath
pathText) -> do
      ProjectPath
projectPath <- Text -> Either FilePath ProjectPath
parseProjectPathFromText (forall a b. ConvertText a b => a -> b
toS FilePath
pathText) forall a b. a -> (a -> b) -> b
& forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs (\FilePath
e -> Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"Invalid HERCULES_CI_PROJECT_PATH supplied: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS FilePath
e)
      UUID
uuid <- FilePath -> Maybe UUID
Data.UUID.fromString FilePath
id forall a b. a -> (a -> b) -> b
& forall e a. e -> Maybe a -> Either e a
maybeToEither (Text -> FatalError
FatalError Text
"Invalid UUID in HERCULES_CI_PROJECT_ID") forall a b. a -> (a -> b) -> b
& forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall k (a :: k). UUID -> Id a
Id UUID
uuid), ProjectPath
projectPath)

findProjectByCurrentRepo :: (Has HerculesClientToken r, Has HerculesClientEnv r) => RIO r (Maybe (Id Project), ProjectPath)
findProjectByCurrentRepo :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
RIO r (Maybe (Id Project), ProjectPath)
findProjectByCurrentRepo = do
  Text
url <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
Git.getUpstreamURL
  Either ClientError RepoKey
rs <- forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r (Either ClientError a)
runHerculesClientEither (forall auth f.
ReposAPI auth f
-> f
   :- (Summary
         "Parse a git remote URL into site, owner and repo. Returns 400 if invalid, 404 if the site can not be determined. Does provide any guarantee that the repository exists."
       :> ("parse-git-url"
           :> (QueryParam' '[Required, Strict] "gitURL" Text
               :> (auth :> Get '[JSON] RepoKey))))
Repos.parseGitURL ReposAPI ClientAuth (AsClientT ClientM)
reposClient Text
url)
  case Either ClientError RepoKey
rs of
    Left (FailureResponse RequestF () (BaseUrl, ByteString)
_req Response {responseStatusCode :: forall a. ResponseF a -> Status
responseStatusCode = Status {statusCode :: Status -> Int
statusCode = Int
404}}) -> do
      forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg Text
"Repository not recognized by Hercules CI. Make sure you're in the right repository, and if you're running Hercules CI Enterprise, make sure you're using the right HERCULES_CI_API_BASE_URL. Alternatively, use the --project option."
    Left ClientError
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ClientError
e
    Right RepoKey
r ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( RepoKey -> Maybe (Id Project)
RepoKey.projectId RepoKey
r,
          ProjectPath
            { projectPathSite :: Text
projectPathSite = RepoKey -> Text
RepoKey.siteName RepoKey
r,
              projectPathOwner :: Text
projectPathOwner = RepoKey -> Text
RepoKey.ownerName RepoKey
r,
              projectPathProject :: Text
projectPathProject = RepoKey -> Text
RepoKey.repoName RepoKey
r
            }
        )

findProject :: (Has HerculesClientToken r, Has HerculesClientEnv r) => ProjectPath -> RIO r Project.Project
findProject :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
ProjectPath -> RIO r Project
findProject ProjectPath
project = do
  [Project]
rs <-
    forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r a
runHerculesClient
      ( forall auth f.
ProjectsAPI auth f
-> f
   :- (Summary "Find projects"
       :> ("projects"
           :> (QueryParam' '[Optional] "site" (Name Forge)
               :> (QueryParam' '[Optional] "account" (Name Account)
                   :> (QueryParam' '[Optional] "project" (Name Project)
                       :> (auth :> Get '[JSON] [Project]))))))
findProjects
          ProjectsAPI ClientAuth (AsClientT ClientM)
projectsClient
          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathSite ProjectPath
project)
          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathOwner ProjectPath
project)
          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathProject ProjectPath
project)
      )
  case [Project]
rs of
    [] -> do
      forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg forall a b. (a -> b) -> a -> b
$ Text
"Project not found: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv FilePath b) => a -> b
show ProjectPath
project
    [Project
p] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Project
p
    [Project]
_ -> do
      forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg forall a b. (a -> b) -> a -> b
$ Text
"Project ambiguous: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv FilePath b) => a -> b
show ProjectPath
project

projectResourceClientByPath :: ProjectPath -> ProjectResourceGroup ClientAuth (AsClientT ClientM)
projectResourceClientByPath :: ProjectPath -> ProjectResourceGroup ClientAuth (AsClientT ClientM)
projectResourceClientByPath ProjectPath
projectPath =
  ProjectsAPI ClientAuth (AsClientT ClientM)
projectsClient forall {k} (subapi :: k -> * -> *) (api :: k -> * -> *) mode
       (a :: k).
GenericServant (subapi a) mode =>
api a mode
-> (api a mode -> ToServant (subapi a) mode) -> subapi a mode
`enterApiE` \ProjectsAPI ClientAuth (AsClientT ClientM)
api ->
    forall auth f.
ProjectsAPI auth f
-> f
   :- Substitute
        ("site"
         :> (Capture' '[Required, Strict] "site" (Name Forge)
             :> ("account"
                 :> (Capture' '[Required, Strict] "account" (Name Account)
                     :> ("project"
                         :> (Capture' '[Required, Strict] "project" (Name Project)
                             :> Placeholder))))))
        (ToServantApi (ProjectResourceGroup auth))
byProjectName
      ProjectsAPI ClientAuth (AsClientT ClientM)
api
      (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathSite ProjectPath
projectPath)
      (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathOwner ProjectPath
projectPath)
      (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathProject ProjectPath
projectPath)