diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,77 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) +and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [0.6.0.0] - 2020-03-07 + +### Added + + - Build logs + - Evaluation log + - Attribute types + - Effects + - State files + - CLI authorization flow + - Endpoint for resolving git urls to projects + +### Changed + + - Adaptations to support servant streaming + +## [0.5.0.0] - 2020-01-30 + +### Changed + +- `hercules-ci-api-core` and `hercules-ci-api-agent` packages have been extracted. + +### Added + +- Account settings +- Project enable/disable +- Some authorization-related fields +- Billing +- Derivation info and events +- Job derivation statistics and improved status reporting +- Derivation and Job restarts +- Job cancellation + +## [0.4.0.0] - 2019-08-30 + +### Fixed + +- Swagger schema was wrong for a Result +- Swagger schema is now written using UTF-8 encoding + +### Changed + +- /jobs endpoint changed to be hierarchical + +### Added + +- Submit number of concurrent tasks to the backend for better scheduling of evaluations (to avoid IFD deadlocks) + +- New endpoint to return evaluation build dependencies for IFD + + +## [0.3.0.0] - 2019-07-05 + +### Added + +- The CachixCache JSON format for configuring binary caches. + +- Endpoints for lifecycle management: hello, hearbeat, goodbye. + +- requiredFeatures support + +## 0.1.0.0 + +Initial release + +[0.6.0.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.4.0.0...hercules-ci-api-0.6.0.0 +[0.5.0.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.4.0.0...hercules-ci-api-0.5.0.0 +[0.4.0.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.3.0.0...hercules-ci-api-0.4.0.0 +[0.3.0.0]: https://github.com/hercules-ci/hercules-ci-agent/compare/hercules-ci-agent-0.1.0.0...hercules-ci-api-0.3.0.0 +[Unreleased]: https://github.com/hercules-ci/hercules-ci-agent/compare/stable...master diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/hercules-ci-api.cabal b/hercules-ci-api.cabal new file mode 100644 --- /dev/null +++ b/hercules-ci-api.cabal @@ -0,0 +1,182 @@ +cabal-version: 1.12 +name: hercules-ci-api +version: 0.6.0.0 +synopsis: Hercules CI API definition with Servant +homepage: https://github.com/hercules-ci/hercules-ci-agent#readme +bug-reports: https://github.com/hercules-ci/hercules-ci-agent/issues +author: Hercules CI contributors +maintainer: info@hercules-ci.com +copyright: 2018-2021 Hercules CI +license: Apache-2.0 +build-type: Simple +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/hercules-ci/hercules-ci + +library + exposed-modules: + Hercules.API + Hercules.API.Accounts + Hercules.API.Accounts.Account + Hercules.API.Accounts.AccountSettings + Hercules.API.Accounts.AccountSettingsPatch + Hercules.API.Accounts.CLIAuthorizationRequest + Hercules.API.Accounts.CLIAuthorizationRequestCreate + Hercules.API.Accounts.CLIAuthorizationRequestCreateResponse + Hercules.API.Accounts.CLIAuthorizationRequestStatus + Hercules.API.Agents + Hercules.API.Agents.AgentInfo + Hercules.API.Agents.AgentSession + Hercules.API.Agents.AgentSessionCreated + Hercules.API.Agents.ClusterJoinToken + Hercules.API.Agents.CreateClusterJoinToken + Hercules.API.Agents.FullClusterJoinToken + Hercules.API.Attribute + Hercules.API.Auth + Hercules.API.BillingStatus + Hercules.API.Build + Hercules.API.Build.AgentRequirements + Hercules.API.Build.DerivationEvent + Hercules.API.Build.DerivationEvent.BuiltOutput + Hercules.API.Build.DerivationInfo + Hercules.API.Build.DerivationInfo.DerivationInput + Hercules.API.Build.DerivationInfo.DerivationOutput + Hercules.API.Build.EvaluationDependency + Hercules.API.Build.EvaluationDetail + Hercules.API.Build.FailureGraph + Hercules.API.Build.Log + Hercules.API.Build.LogLine + Hercules.API.Derivation + Hercules.API.Effects + Hercules.API.Effects.EffectEvent + Hercules.API.Effects.EffectInfo + Hercules.API.Evaluation.AttributeError + Hercules.API.Evaluation.Evaluation + Hercules.API.Health + Hercules.API.Message + Hercules.API.Organizations + Hercules.API.Organizations.BillingInfo + Hercules.API.Organizations.CreateOrganization + Hercules.API.Organizations.Organization + Hercules.API.Organizations.PaymentLink + Hercules.API.Orphans + Hercules.API.Projects + Hercules.API.Projects.CreateProject + Hercules.API.Projects.CreateUserEffectTokenResponse + Hercules.API.Projects.Job + Hercules.API.Projects.PatchProject + Hercules.API.Projects.Project + Hercules.API.Projects.SimpleJob + Hercules.API.Repos + Hercules.API.Repos.Repo + Hercules.API.Repos.RepoKey + Hercules.API.Result + Hercules.API.Servant.Status + Hercules.API.SourceHostingSite.SourceHostingSite + Hercules.API.State + Hercules.API.State.ProjectState + Hercules.API.State.StateFile + Hercules.API.State.StateVersion + Hercules.Frontend + + hs-source-dirs: src + default-extensions: + NoImplicitPrelude + DeriveGeneric + DeriveTraversable + DisambiguateRecordFields + FlexibleContexts + InstanceSigs + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + TupleSections + TypeApplications + TypeOperators + + ghc-options: + -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures + -fwarn-name-shadowing -fwarn-incomplete-patterns + + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , cookie + , exceptions + , hashable + , hercules-ci-api-core + , http-api-data + , http-media + , lens + , lens-aeson + , memory + , network-uri + , profunctors + , servant >=0.14.1 + , servant-auth + , servant-auth-swagger + , servant-swagger + , servant-swagger-ui-core + , string-conv + , swagger2 + , text + , time + , uuid + + default-language: Haskell2010 + +executable hercules-gen-swagger + main-is: Main.hs + hs-source-dirs: hercules-gen-swagger + default-extensions: + NoImplicitPrelude + DeriveGeneric + DeriveTraversable + DisambiguateRecordFields + FlexibleContexts + InstanceSigs + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + TupleSections + TypeApplications + TypeOperators + + ghc-options: + -Wall -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures + -fwarn-name-shadowing -fwarn-incomplete-patterns -threaded -rtsopts + -with-rtsopts=-N + + build-depends: + aeson + , base + , bytestring + , containers + , cookie + , exceptions + , hashable + , hercules-ci-api + , http-api-data + , http-media + , lens + , memory + , network-uri + , profunctors + , servant + , servant-auth + , servant-auth-swagger + , servant-swagger + , servant-swagger-ui-core + , string-conv + , swagger2 + , text + , time + , uuid + + default-language: Haskell2010 diff --git a/hercules-gen-swagger/Main.hs b/hercules-gen-swagger/Main.hs new file mode 100644 --- /dev/null +++ b/hercules-gen-swagger/Main.hs @@ -0,0 +1,12 @@ +module Main + ( main, + ) +where + +import Data.Aeson (encode) +import Data.String.Conv (toS) +import Hercules.API (swagger) +import Prelude + +main :: IO () +main = putStrLn $ toS $ encode swagger diff --git a/src/Hercules/API.hs b/src/Hercules/API.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hercules.API + ( api, + servantApi, + servantClientApi, + swagger, + useApi, + API, + ClientAuth, + HerculesAPI (..), + ClientAPI (..), + HerculesServantAPI, + AddAPIVersion, + Id, + Name, + Result (..), + + -- * Reexports + NoContent (..), + + -- * Utilities + noContent, + ) +where + +import Control.Lens +import Control.Monad +import Data.Proxy (Proxy (..)) +import Data.Swagger hiding (Header) +import Hercules.API.Accounts (AccountsAPI) +import Hercules.API.Agents (AgentsAPI) +import Hercules.API.Build as Client + ( BuildAPI, + ) +import Hercules.API.Effects (EffectsAPI) +import Hercules.API.Health (HealthAPI) +import Hercules.API.Id (Id) +import Hercules.API.Name (Name) +import Hercules.API.Organizations (OrganizationsAPI) +import Hercules.API.Orphans () +import Hercules.API.Projects (ProjectsAPI) +import Hercules.API.Repos (ReposAPI) +import Hercules.API.Result (Result (..)) +import Hercules.API.State (StateAPI) +import Servant.API +import Servant.API.Generic +import Servant.Auth +import Servant.Auth.Swagger () +import Servant.Swagger +import Servant.Swagger.UI.Core (SwaggerSchemaUI) +import Prelude + +-- TODO remove health so we get clientapi +data HerculesAPI auth f = HerculesAPI + { accounts :: f :- ToServantApi (AccountsAPI auth), + repos :: f :- ToServantApi (ReposAPI auth), + projects :: f :- ToServantApi (ProjectsAPI auth), + agents :: f :- ToServantApi (AgentsAPI auth), + build :: f :- ToServantApi (Client.BuildAPI auth), + effects :: f :- ToServantApi (EffectsAPI auth), + health :: f :- ToServantApi (HealthAPI auth), + organizations :: f :- ToServantApi (OrganizationsAPI auth), + state :: f :- ToServantApi (StateAPI auth) + } + deriving (Generic) + +data ClientAPI auth f = ClientAPI + { clientAccounts :: f :- ToServantApi (AccountsAPI auth), + clientRepos :: f :- ToServantApi (ReposAPI auth), + clientProjects :: f :- ToServantApi (ProjectsAPI auth), + clientAgents :: f :- ToServantApi (AgentsAPI auth), + clientBuild :: f :- ToServantApi (Client.BuildAPI auth), + clientEffects :: f :- ToServantApi (EffectsAPI auth), + clientOrganizations :: f :- ToServantApi (OrganizationsAPI auth), + clientState :: f :- ToServantApi (StateAPI auth) + } + deriving (Generic) + +type ClientAuth = Auth '[JWT, Cookie] () + +type HerculesServantAPI auth = AddAPIVersion (ToServantApi (HerculesAPI auth)) + +type ClientServantAPI auth = AddAPIVersion (ToServantApi (ClientAPI auth)) + +type AddAPIVersion api = "api" :> "v1" :> api + +servantApi :: Proxy (HerculesServantAPI auth) +servantApi = Proxy + +servantClientApi :: Proxy (ClientServantAPI auth) +servantClientApi = Proxy + +type API auth = + (HerculesServantAPI auth) + :<|> "api" + :> SwaggerSchemaUI "v1" "swagger.json" + +api :: Proxy (API auth) +api = Proxy + +swagger :: Swagger +swagger = + toSwagger (servantClientApi @(Auth '[JWT] ())) + & info + . title + .~ "Hercules CI API" + & info + . version + .~ "v1" + & info + . description + ?~ "You have reached the Hercules Continuous Integration Application Programming Interface. This user interface provides human friendly access to the various endpoints. To get started with Hercules CI, see hercules-ci.com. Happy building! —the Hercules team" + +-- | Postcomposes 'Servant.API.Generic.fromServant' to an accessor, +-- preserving the mode parameter, because otherwise the mode parameter +-- can not be inferred. +-- +-- Ideally, this functionality would be built into a new combinator. +useApi :: + (GenericServant f mode, GenericServant g mode) => + (f mode -> ToServant g mode) -> + f mode -> + g mode +useApi = (Servant.API.Generic.fromServant .) + +-- | 'Control.Monad.void' specialised to 'NoContent' to soothe the +-- compiler that rightfully warns about throwing away a do notation +-- result. By specialising, we make sure that we still get warnings +-- if the result type changes in the future. (We'll get an error) +noContent :: Functor m => m Servant.API.NoContent -> m () +noContent = void diff --git a/src/Hercules/API/Accounts.hs b/src/Hercules/API/Accounts.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Accounts where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Accounts.AccountSettings (AccountSettings) +import Hercules.API.Accounts.AccountSettingsPatch (AccountSettingsPatch) +import Hercules.API.Accounts.CLIAuthorizationRequest (CLIAuthorizationRequest) +import Hercules.API.Accounts.CLIAuthorizationRequestCreate (CLIAuthorizationRequestCreate) +import Hercules.API.Accounts.CLIAuthorizationRequestCreateResponse (CLIAuthorizationRequestCreateResponse) +import Hercules.API.Accounts.CLIAuthorizationRequestStatus (CLIAuthorizationRequestStatus) +import Hercules.API.Prelude +import Hercules.API.SourceHostingSite.SourceHostingSite + ( SourceHostingSite, + ) +import Servant.API +import Servant.API.Generic +import Servant.Auth () + +data AccountsAPI auth f = AccountsAPI + { myAccount :: + f + :- Summary "The account of the authenticated user." + :> "accounts" + :> "me" + :> auth + :> Get '[JSON] Account, + findAccounts :: + f + :- Summary "Accounts that the authenticated user owns, admins or collaborates with." + :> "accounts" + :> QueryParam "site" (Name SourceHostingSite) + :> QueryParam "name" (Name Account) + :> auth + :> Get '[JSON] [Account], + getAccountSettings :: + f :- Summary "Retrieve the account settings" + :> "accounts" + :> Capture "accountId" (Id Account) + :> "settings" + :> auth + :> Get '[JSON] AccountSettings, + patchAccountSettings :: + f :- Summary "Update the account settings" + :> "accounts" + :> Capture "accountId" (Id Account) + :> "settings" + :> ReqBody '[JSON] AccountSettingsPatch + :> auth + :> Patch '[JSON] AccountSettings, + postCLIAuthorizationRequest :: + f :- Summary "Create a request to authorize the CLI." + :> "auth" + :> "cli" + :> "authorization" + :> "request" + :> ReqBody '[JSON] CLIAuthorizationRequestCreate + :> Post '[JSON] CLIAuthorizationRequestCreateResponse, + getCLIAuthorizationRequestStatus :: + f :- Summary "Check the request status" + :> "auth" + :> "cli" + :> "authorization" + :> "request" + :> "status" + :> Capture "temporaryToken" Text + :> Get '[JSON] CLIAuthorizationRequestStatus, + getCLIAuthorizationRequest :: + f :- Summary "Retrieve the request" + :> "auth" + :> "cli" + :> "authorization" + :> "request" + :> Capture "browserToken" Text + :> auth + :> Get '[JSON] CLIAuthorizationRequest, + confirmCLIAuthorizationRequest :: + f :- Summary "Retrieve the request" + :> "auth" + :> "cli" + :> "authorization" + :> "request" + :> Capture "browserToken" Text + :> "confirm" + :> auth + :> Post '[JSON] NoContent, + postDisableAllProjects :: + f :- Summary "Disable all projects in the account." + :> "accounts" + :> Capture "accountId" (Id Account) + :> "disable-all-projects" + :> auth + :> Post '[JSON] Int + } + deriving (Generic) diff --git a/src/Hercules/API/Accounts/Account.hs b/src/Hercules/API/Accounts/Account.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/Account.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.Account where + +import qualified Hercules.API.Organizations.Organization as Organization +import Hercules.API.Prelude +import Hercules.API.SourceHostingSite.SourceHostingSite (SourceHostingSite) + +data AccountType = User | Organization + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data MembershipRole = Member | Admin + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data Account = Account + { id :: Id Account, + sourceHostingSiteSlug :: Text, + slug :: Text, + typ :: AccountType, + displayName :: Text, + imageURL :: Text, + organization :: Maybe Organization.Organization, + -- | Whether Hercules CI is installed on this account as an App. + -- + -- An account that does not have an installation can not be + -- properly accessed by Hercules, but may be visible nonetheless + -- at times because of OAuth scopes. + -- + -- As an example, non-installed accounts show up when a GitHub + -- user signs in for the first time via OAuth, until they decide + -- to install it on their GitHub user. Another example is GitHub + -- organizations that don't have an installation yet. + isInstalled :: Bool, + -- | Whether the current user has permission in the to installing + -- Hercules CI on this account. + isInstallable :: Bool, + membershipRole :: Maybe MembershipRole, + sourceHostingSites :: Maybe (Map Text SourceHostingSite) + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Accounts/AccountSettings.hs b/src/Hercules/API/Accounts/AccountSettings.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/AccountSettings.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.AccountSettings where + +import Hercules.API.Prelude + +data AccountSettings = AccountSettings + { -- | When a new repo is created/installed, enable building it? + enableNewRepos :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Accounts/AccountSettingsPatch.hs b/src/Hercules/API/Accounts/AccountSettingsPatch.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/AccountSettingsPatch.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.AccountSettingsPatch where + +import Hercules.API.Prelude + +data AccountSettingsPatch = AccountSettingsPatch + { enableNewRepos :: Maybe Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Accounts/CLIAuthorizationRequest.hs b/src/Hercules/API/Accounts/CLIAuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/CLIAuthorizationRequest.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.CLIAuthorizationRequest where + +import Hercules.API.Prelude + +data CLIAuthorizationRequest = CLIAuthorizationRequest + { description :: Text, + creationTime :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Accounts/CLIAuthorizationRequestCreate.hs b/src/Hercules/API/Accounts/CLIAuthorizationRequestCreate.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/CLIAuthorizationRequestCreate.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.CLIAuthorizationRequestCreate where + +import Hercules.API.Prelude + +data CLIAuthorizationRequestCreate = CLIAuthorizationRequestCreate + { description :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Accounts/CLIAuthorizationRequestCreateResponse.hs b/src/Hercules/API/Accounts/CLIAuthorizationRequestCreateResponse.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/CLIAuthorizationRequestCreateResponse.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.CLIAuthorizationRequestCreateResponse where + +import Hercules.API.Prelude + +data CLIAuthorizationRequestCreateResponse = CLIAuthorizationRequestCreateResponse + { temporaryCLIToken :: Text, + browserURL :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Accounts/CLIAuthorizationRequestStatus.hs b/src/Hercules/API/Accounts/CLIAuthorizationRequestStatus.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Accounts/CLIAuthorizationRequestStatus.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Accounts.CLIAuthorizationRequestStatus where + +import Hercules.API.Prelude + +data CLIAuthorization = CLIAuthorization + { token :: Text, + userIdentities :: [Text] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data CLIAuthorizationStatus = Pending () | Granted CLIAuthorization + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data CLIAuthorizationRequestStatus = CLIAuthorizationRequestStatus + { status :: CLIAuthorizationStatus + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Agents.hs b/src/Hercules/API/Agents.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Hercules.API.Agents where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Agents.AgentSession + ( AgentSession, + ) +import Hercules.API.Agents.ClusterJoinToken + ( ClusterJoinToken, + ) +import Hercules.API.Agents.CreateClusterJoinToken + ( CreateClusterJoinToken, + ) +import Hercules.API.Agents.FullClusterJoinToken + ( FullClusterJoinToken, + ) +import Hercules.API.Prelude +import Servant.API +import Servant.API.Generic + +data AgentsAPI auth f = AgentsAPI + { clusterJoinTokensByAccount :: + f + :- Summary "List all cluster join tokens in an account." -- TODO rename + :> "accounts" + :> Capture' '[Required, Strict] "accountId" (Id Account) + :> "clusterJoinTokens" + :> auth + :> Get '[JSON] [ClusterJoinToken], + clusterJoinTokenCreate :: + f + :- Summary "Generate a new cluster join token for agents to be added to this account." + :> "accounts" + :> Capture' '[Required, Strict] "accountId" (Id Account) + :> "clusterJoinTokens" + :> ReqBody '[JSON] CreateClusterJoinToken + :> auth + :> Post '[JSON] FullClusterJoinToken, + clusterJoinTokenDelete :: + f + :- Summary "Delete an cluster join token in the account. No new agents will be able to join this account with the specified token." + :> "accounts" + :> Capture' '[Required, Strict] "accountId" (Id Account) + :> "clusterJoinTokens" + :> Capture' '[Required, Strict] "clusterJoinTokenId" (Id ClusterJoinToken) + :> auth + :> Delete '[JSON] NoContent, + agentSessionsByAccount :: + f + :- Summary "Show the agents sessions owned by the account." + :> "accounts" + :> Capture' '[Required, Strict] "accountId" (Id Account) + :> "agentSessions" + :> auth + :> Get '[JSON] [AgentSession] + } + deriving (Generic) diff --git a/src/Hercules/API/Agents/AgentInfo.hs b/src/Hercules/API/Agents/AgentInfo.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents/AgentInfo.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Agents.AgentInfo where + +import Control.Applicative +import Control.Lens (at, (%~)) +import qualified Data.Aeson as A +import Data.Aeson.Lens (_Object) +import Hercules.API.Prelude + +data AgentInfo = AgentInfo + { hostname :: Text, + agentVersion :: Text, + nixVersion :: Text, + platforms :: [Text], + systemFeatures :: [Text], + cachixPushCaches :: [Text], + substituters :: [Text], + concurrentTasks :: Int + } + deriving (Generic, Show, Eq, NFData, ToJSON, ToSchema) + +instance FromJSON AgentInfo where + parseJSON = A.genericParseJSON A.defaultOptions . fixup + where + fixup :: A.Value -> A.Value + fixup = _Object . at "concurrentTasks" %~ (<|> Just (A.Number 2)) diff --git a/src/Hercules/API/Agents/AgentSession.hs b/src/Hercules/API/Agents/AgentSession.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents/AgentSession.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Agents.AgentSession where + +import Hercules.API.Agents.ClusterJoinToken + ( ClusterJoinToken, + ) +import Hercules.API.Prelude + +data AgentSession = AgentSession + { id :: Id AgentSession, + clusterJoinTokenId :: Id ClusterJoinToken, + description :: Text, + hostname :: Text, + agentVersion :: Text, + nixVersion :: Text, + platforms :: [Text], + systemFeatures :: [Text], + cachixPushCaches :: [Text], + substituters :: [Text], + creation :: UTCTime, + lastSeen :: Maybe UTCTime, + available :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Agents/AgentSessionCreated.hs b/src/Hercules/API/Agents/AgentSessionCreated.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents/AgentSessionCreated.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Agents.AgentSessionCreated where + +import Hercules.API.Agents.AgentSession + ( AgentSession, + ) +import Hercules.API.Agents.ClusterJoinToken + ( ClusterJoinToken, + ) +import Hercules.API.Prelude + +data AgentSessionCreated = AgentSessionCreated + { hostname :: Text, + id :: Id AgentSession, + tokenId :: Id ClusterJoinToken, + description :: Text, + agentVersion :: Text, + nixVersion :: Text, + architectures :: [Text], + creation :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Agents/ClusterJoinToken.hs b/src/Hercules/API/Agents/ClusterJoinToken.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents/ClusterJoinToken.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Agents.ClusterJoinToken where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude + +data ClusterJoinToken = ClusterJoinToken + { id :: Id ClusterJoinToken, + ownerId :: Id Account, + creationTime :: UTCTime, + -- TODO lastAccessTime :: Maybe UTCTime + description :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Agents/CreateClusterJoinToken.hs b/src/Hercules/API/Agents/CreateClusterJoinToken.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents/CreateClusterJoinToken.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Agents.CreateClusterJoinToken where + +import Hercules.API.Prelude + +-- The owner account that the token applies to is in the path. +data CreateClusterJoinToken = CreateClusterJoinToken + { description :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Agents/FullClusterJoinToken.hs b/src/Hercules/API/Agents/FullClusterJoinToken.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Agents/FullClusterJoinToken.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Agents.FullClusterJoinToken where + +import Hercules.API.Agents.ClusterJoinToken + ( ClusterJoinToken, + ) +import Hercules.API.Prelude + +data FullClusterJoinToken = FullClusterJoinToken + { metadata :: ClusterJoinToken, + token :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Attribute.hs b/src/Hercules/API/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Attribute.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Hercules.API.Attribute where + +import Control.Applicative (Alternative ((<|>))) +import Control.Lens (at, (%~)) +import qualified Data.Aeson as A +import Data.Aeson.Lens +import Data.Proxy (Proxy (Proxy)) +import Data.Swagger (ToParamSchema (..)) +import qualified Data.Text as T +import Hercules.API.Prelude +import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) +import Prelude () + +data AttributeType + = Regular + | MustFail + | MayFail + | DependenciesOnly + | Effect + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +-- | An arbitrary ordering +deriving instance Ord AttributeType + +data Attribute a = Attribute + { path :: [Text], + value :: a, + typ :: AttributeType + } + deriving (Generic, Show, Eq, NFData, ToJSON) + +instance FromJSON a => FromJSON (Attribute a) where + parseJSON v = A.parseJSON (fixup v) + where + fixup :: A.Value -> A.Value + fixup = _Object . at "typ" %~ (<|> Just (A.String "Regular")) + +deriving instance ToSchema a => ToSchema (Attribute a) + +deriving instance Functor Attribute + +deriving instance Foldable Attribute + +deriving instance Traversable Attribute + +newtype AttributePath = AttributePath {fromAttributePath :: [Text]} + deriving (Generic, Eq, NFData) + +instance FromHttpApiData AttributePath where + -- TODO parse properly + parseUrlPiece = Right . AttributePath . T.split (== '.') + + parseQueryParam = parseUrlPiece + +instance ToParamSchema AttributePath where + toParamSchema _ = toParamSchema (Proxy :: Proxy Text) + +instance ToHttpApiData AttributePath where + toUrlPiece = toUrlPiece . T.intercalate "." . fromAttributePath diff --git a/src/Hercules/API/Auth.hs b/src/Hercules/API/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Auth.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Auth where + +import Hercules.API.Prelude +import Hercules.API.Servant.Status +import Servant.API +import Servant.API.Generic + +-- | Endpoints for authentication +data AuthAPI f = AuthAPI + { initiateGitHubLogin :: + f + :- "api" + :> "auth" + :> "github" + :> QueryParam' '[Optional, Strict] "redirect" Text + :> Get302 '[PlainText, JSON] '[] + } + deriving (Generic) diff --git a/src/Hercules/API/BillingStatus.hs b/src/Hercules/API/BillingStatus.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/BillingStatus.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.BillingStatus + ( BillingStatus (..), + toText, + fromText, + ) +where + +import Data.Swagger +import Hercules.API.Prelude + +data BillingStatus + = Community -- Free plan + | Trial + | Active + | Cancelled + | External + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +toText :: BillingStatus -> Text +toText Community = "Community" +toText Trial = "Trial" +toText Active = "Active" +toText Cancelled = "Cancelled" +toText External = "External" + +fromText :: Text -> Maybe BillingStatus +fromText "Community" = Just Community +fromText "Cancelled" = Just Cancelled +fromText "Trial" = Just Trial +fromText "Active" = Just Active +fromText "External" = Just External +fromText _ = Nothing diff --git a/src/Hercules/API/Build.hs b/src/Hercules/API/Build.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Build where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Build.DerivationInfo (DerivationInfo) +import Hercules.API.Build.Log (Log) +import Hercules.API.Prelude +import Hercules.API.Projects.Job (Job) +import Servant.API +import Servant.API.Generic + +data BuildAPI auth f = BuildAPI + { restartDerivation :: + f + :- Summary "Restart a failed derivation" + :> "accounts" + :> Capture "accountId" (Id Account) + :> "derivations" + :> Capture "derivationPath" Text + :> "retry" + :> auth + :> Post '[PlainText, JSON] NoContent, + readDerivationLogText :: + f + :- Summary "Read a derivation build log" + :> Description "This interface may change." + :> "accounts" + :> Capture "accountId" (Id Account) + :> "derivations" + :> Capture "derivationPath" Text + :> "log" + :> QueryParam "logId" (Id "log") + :> auth + :> Get '[PlainText, JSON] Text, -- NB: We use JSON only to be able to generate elm api + -- FIXME: bytes? + getLog :: + f :- Summary "Read all recorded log entries" + :> "accounts" + :> Capture "accountId" (Id Account) + :> "derivations" + :> Capture "derivationPath" Text + :> "log" + :> "lines" + :> QueryParam' '[Required] "logId" (Id "log") + :> QueryParam' '[Optional] "iMin" Int + :> auth + :> Get '[JSON] Log, + getDerivationInfo :: + f :- Summary "Get information about a derivation." + :> Description "Optionally, a job id can be specified to provide context." + :> "accounts" + :> Capture "accountId" (Id Account) + :> "derivations" + :> Capture "derivationPath" Text + :> QueryParam' '[Optional, Strict] "via-job" (Id Job) + :> auth + :> Get '[JSON] DerivationInfo + } + deriving (Generic) diff --git a/src/Hercules/API/Build/AgentRequirements.hs b/src/Hercules/API/Build/AgentRequirements.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/AgentRequirements.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.AgentRequirements where + +import Hercules.API.Prelude + +data AgentRequirements = AgentRequirements + { platform :: Text, + requiredSystemFeatures :: [Text] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/DerivationEvent.hs b/src/Hercules/API/Build/DerivationEvent.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/DerivationEvent.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Hercules.API.Build.DerivationEvent where + +import Data.Aeson.Types (FromJSON (..), ToJSON (..), genericParseJSON, genericToEncoding, genericToJSON) +import Hercules.API.Build.DerivationEvent.BuiltOutput +import Hercules.API.Prelude +import Hercules.API.Projects.SimpleJob (SimpleJob) + +data DerivationEvent + = Queued DerivationEventQueued + | DependencyFailed DerivationEventDependencyFailed + | Started DerivationEventStarted + | Reset DerivationEventReset + | Failed DerivationEventFailed + | Succeeded DerivationEventSucceeded + | Cancelled DerivationEventCancelled + | Built DerivationEventBuilt + deriving (Generic, Show, Eq, NFData, ToSchema) + +instance FromJSON DerivationEvent where + parseJSON = genericParseJSON schemaCompatibleOptions + +instance ToJSON DerivationEvent where + toJSON = genericToJSON schemaCompatibleOptions + + toEncoding = genericToEncoding schemaCompatibleOptions + +eventTime :: DerivationEvent -> UTCTime +eventTime (Queued (DerivationEventQueued {time = t})) = t +eventTime (DependencyFailed (DerivationEventDependencyFailed {time = t})) = t +eventTime (Started (DerivationEventStarted {time = t})) = t +eventTime (Reset (DerivationEventReset {time = t})) = t +eventTime (Failed (DerivationEventFailed {time = t})) = t +eventTime (Succeeded (DerivationEventSucceeded {time = t})) = t +eventTime (Cancelled (DerivationEventCancelled {time = t})) = t +eventTime (Built (DerivationEventBuilt {time = t})) = t + +data DerivationEventQueued = DerivationEventQueued + { time :: UTCTime, + requeuedForEvalOfJob :: Maybe SimpleJob, + requeuedForAgent :: Maybe Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventDependencyFailed = DerivationEventDependencyFailed + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventStarted = DerivationEventStarted + { time :: UTCTime, + logId :: Id "log", + agentHostname :: Maybe Text, + streamable :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventReset = DerivationEventReset + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventFailed = DerivationEventFailed + { time :: UTCTime, + technicalError :: Maybe Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventSucceeded = DerivationEventSucceeded + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventCancelled = DerivationEventCancelled + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationEventBuilt = DerivationEventBuilt + { time :: UTCTime, + outputs :: [BuiltOutput] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/DerivationEvent/BuiltOutput.hs b/src/Hercules/API/Build/DerivationEvent/BuiltOutput.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/DerivationEvent/BuiltOutput.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.DerivationEvent.BuiltOutput where + +import Hercules.API.Prelude + +data BuiltOutput = BuiltOutput + { outputName :: Text, + outputPath :: Text, + hash :: Text, + size :: Int64 + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/DerivationInfo.hs b/src/Hercules/API/Build/DerivationInfo.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/DerivationInfo.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.DerivationInfo where + +import Hercules.API.Build.DerivationEvent (DerivationEvent) +import Hercules.API.Build.DerivationInfo.DerivationInput (DerivationInput) +import Hercules.API.Build.DerivationInfo.DerivationOutput (DerivationOutput) +import Hercules.API.Derivation (DerivationStatus) +import Hercules.API.Prelude +import Hercules.API.Projects.Job (Job) +import Hercules.API.Projects.Project (Project) + +data DerivationInfo = DerivationInfo + { status :: DerivationStatus, + viaJob :: Maybe Job, + viaProject :: Maybe Project, + platform :: Text, + requiredSystemFeatures :: [Text], + inputDerivations :: [DerivationInput], + outputs :: [DerivationOutput], + usedInProjects :: [Project], + events :: [[DerivationEvent]], + mayRestart :: Bool, + dummy :: Maybe DerivationEvent -- TODO: remove and update/fix codegen + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/DerivationInfo/DerivationInput.hs b/src/Hercules/API/Build/DerivationInfo/DerivationInput.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/DerivationInfo/DerivationInput.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.DerivationInfo.DerivationInput where + +import Hercules.API.Derivation (DerivationStatus) +import Hercules.API.Prelude + +data DerivationInput = DerivationInput + { derivationStatus :: DerivationStatus, + derivationPath :: Text, + outputName :: Text, + outputPath :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/DerivationInfo/DerivationOutput.hs b/src/Hercules/API/Build/DerivationInfo/DerivationOutput.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/DerivationInfo/DerivationOutput.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.DerivationInfo.DerivationOutput where + +import Hercules.API.Prelude + +data DerivationOutput = DerivationOutput + { outputName :: Text, + outputPath :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/EvaluationDependency.hs b/src/Hercules/API/Build/EvaluationDependency.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/EvaluationDependency.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.EvaluationDependency where + +import Hercules.API.Derivation (Derivation) +import Hercules.API.Prelude + +data EvaluationDependency = EvaluationDependency + { index :: Int, + derivation :: Derivation, + outputName :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/EvaluationDetail.hs b/src/Hercules/API/Build/EvaluationDetail.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/EvaluationDetail.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.EvaluationDetail where + +import Hercules.API.Attribute (Attribute) +import Hercules.API.Build.AgentRequirements (AgentRequirements) +import Hercules.API.Build.EvaluationDependency + ( EvaluationDependency, + ) +import Hercules.API.Derivation (Derivation, DerivationStatus) +import Hercules.API.Evaluation.AttributeError + ( AttributeError, + ) +import Hercules.API.Evaluation.Evaluation + ( Evaluation, + ) +import Hercules.API.Message (Message) +import Hercules.API.Prelude +import Hercules.API.Result (Result) + +data EvaluationDetail = EvaluationDetail + { id :: Id Evaluation, + agentHostname :: Text, + agentVersion :: Text, + messages :: [Message], + attributes :: [Attribute (Result AttributeError Derivation)], + evaluationDependencies :: [EvaluationDependency], + evaluationLog :: Maybe (Id "log"), + -- | A set of (path, derivationstatus) that is relevant to the evaluation + derivations :: Map Text DerivationStatus, + derivationsWaitingCount :: Int, + derivationsBuildingCount :: Int, + derivationsBuildFailureCount :: Int, + derivationsDependencyFailureCount :: Int, + derivationsBuildSuccessCount :: Int, + derivationsCancelledCount :: Int, + unmetAgentRequirements :: [AgentRequirements] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/FailureGraph.hs b/src/Hercules/API/Build/FailureGraph.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/FailureGraph.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.FailureGraph where + +import Hercules.API.Derivation (Derivation) +import Hercules.API.Prelude + +-- | A graph where each node is a failed (directly/indirectly) derivation +-- and edges represent a dependencies on other directly or indirectly failed +-- derivations. +data Graph = Graph + { nodes :: [Node] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +-- | A derivation and any dependencies that caused it to fail, if applicable. +data Node = Node + { derivation :: Derivation, + -- | Dependency paths to failed dependencies that, if present, have caused a + -- DependencyFailure for this derivation. + failedDependencies :: [Text] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/Log.hs b/src/Hercules/API/Build/Log.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/Log.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.Log where + +import Hercules.API.Build.LogLine +import Hercules.API.Prelude + +data Log = Log + { id :: Id "log", + lines :: [LogLine], + done :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Build/LogLine.hs b/src/Hercules/API/Build/LogLine.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Build/LogLine.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Build.LogLine where + +import Data.Word +import Hercules.API.Prelude + +data LogLine = LogLine {i :: !Word64, ms :: !Word64, t :: !Text} + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Derivation.hs b/src/Hercules/API/Derivation.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Derivation.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Derivation where + +import Hercules.API.Prelude hiding (either) + +data DerivationPath = DerivationPath + { drvPath :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data Derivation = Derivation + { status :: DerivationStatus, + derivationPath :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data DerivationStatus + = Waiting + | Building + | BuildFailure + | DependencyFailure + | BuildSuccess + | Cancelled + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Effects.hs b/src/Hercules/API/Effects.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Effects.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Effects where + +import Hercules.API.Attribute +import Hercules.API.Build.Log (Log) +import Hercules.API.Effects.EffectInfo +import Hercules.API.Prelude +import Hercules.API.Projects.Job (Job) +import Servant.API (Capture, Get, JSON, NoContent, Optional, Post, QueryParam', Required, Summary, (:>)) +import Servant.API.Generic (GenericMode ((:-))) + +data EffectsAPI auth f = EffectsAPI + { getEffect :: + f :- Summary "Read effect events" + :> "jobs" + :> Capture "jobId" (Id Job) + :> "effects" + :> Capture "attribute" AttributePath + :> auth + :> Get '[JSON] EffectInfo, + getEffectLog :: + f :- Summary "Read all recorded log entries" + :> "jobs" + :> Capture "jobId" (Id Job) + :> "effects" + :> Capture "attribute" AttributePath + :> "log" + :> "lines" + :> QueryParam' '[Required] "logId" (Id "log") + :> QueryParam' '[Optional] "iMin" Int + :> auth + :> Get '[JSON] Log, + cancelEffect :: + f :- Summary "Cancel the effect. It will cause the Job to have a failed status." + :> "jobs" + :> Capture "jobId" (Id Job) + :> "effects" + :> Capture "attribute" AttributePath + :> "cancel" + :> auth + :> Post '[JSON] NoContent + } + deriving (Generic) diff --git a/src/Hercules/API/Effects/EffectEvent.hs b/src/Hercules/API/Effects/EffectEvent.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Effects/EffectEvent.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Hercules.API.Effects.EffectEvent where + +import Data.Aeson.Types (FromJSON (..), ToJSON (..), genericParseJSON, genericToEncoding, genericToJSON) +import Hercules.API.Prelude + +data EffectEvent + = Queued EffectEventQueued + | DependencyFailed EffectEventDependencyFailed + | Started EffectEventStarted + | Failed EffectEventFailed + | Succeeded EffectEventSucceeded + | Cancelled EffectEventCancelled + deriving (Generic, Show, Eq, NFData, ToSchema) + +instance FromJSON EffectEvent where + parseJSON = genericParseJSON schemaCompatibleOptions + +instance ToJSON EffectEvent where + toJSON = genericToJSON schemaCompatibleOptions + + toEncoding = genericToEncoding schemaCompatibleOptions + +eventTime :: EffectEvent -> UTCTime +eventTime (Queued (EffectEventQueued {time = t})) = t +eventTime (DependencyFailed (EffectEventDependencyFailed {time = t})) = t +eventTime (Started (EffectEventStarted {time = t})) = t +eventTime (Failed (EffectEventFailed {time = t})) = t +eventTime (Succeeded (EffectEventSucceeded {time = t})) = t +eventTime (Cancelled (EffectEventCancelled {time = t})) = t + +data EffectEventQueued = EffectEventQueued + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectEventDependencyFailed = EffectEventDependencyFailed + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectEventStarted = EffectEventStarted + { time :: UTCTime, + logId :: Id "log", + agentHostname :: Text, + agentVersion :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectEventReset = EffectEventReset + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectEventFailed = EffectEventFailed + { time :: UTCTime, + technicalError :: Maybe Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectEventSucceeded = EffectEventSucceeded + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectEventCancelled = EffectEventCancelled + { time :: UTCTime + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Effects/EffectInfo.hs b/src/Hercules/API/Effects/EffectInfo.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Effects/EffectInfo.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Effects.EffectInfo where + +import Hercules.API.Build.DerivationInfo.DerivationInput (DerivationInput) +import Hercules.API.Effects.EffectEvent (EffectEvent) +import Hercules.API.Prelude +import Hercules.API.Projects.Job (Job) +import Hercules.API.Projects.Project (Project) + +data EffectStatus + = Waiting + | Running + | Failed + | DependencyFailed + | Successful + | Cancelled + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data EffectInfo = EffectInfo + { status :: EffectStatus, + jobId :: Id Job, + projectId :: Id Project, + platform :: Text, + requiredSystemFeatures :: [Text], + inputDerivations :: [DerivationInput], + events :: [[EffectEvent]], + mayCancel :: Bool, + dummy :: Maybe EffectEvent -- TODO: remove and update/fix codegen + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Evaluation/AttributeError.hs b/src/Hercules/API/Evaluation/AttributeError.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Evaluation/AttributeError.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Evaluation.AttributeError where + +import Hercules.API.Prelude + +data AttributeError = AttributeError + { errorMessage :: Text, + -- | Not intended to be displayed to the user. This is + -- @Just "BuildException"@ for evaluation time build failures. + errorType :: Maybe Text, + errorDerivation :: Maybe Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Evaluation/Evaluation.hs b/src/Hercules/API/Evaluation/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Evaluation/Evaluation.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Evaluation.Evaluation where + +import Hercules.API.Prelude + +data Evaluation = Evaluation + { id :: Id Evaluation + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Health.hs b/src/Hercules/API/Health.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Health.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Health where + +import Servant.API +import Servant.API.Generic + +data HealthAPI auth f = HealthAPI + { db :: + f + :- Summary "Health check for the database" + :> "health" + :> "db" + :> Get '[JSON] NoContent, + queue :: + f + :- Summary "Health check for the queue" + :> "health" + :> "queue" + :> Get '[JSON] NoContent, + github :: + f + :- Summary "Health check for the github" + :> "health" + :> "github" + :> Get '[JSON] NoContent + } + deriving (Generic) diff --git a/src/Hercules/API/Message.hs b/src/Hercules/API/Message.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Message.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Message where + +import Hercules.API.Prelude + +data Message = Message + { index :: Int, + typ :: Type, + message :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data Type + = -- | Something went wrong, inform user about possible + -- cause. Examples: source could not be fetched, could not + -- find a nix expression file to call. + Error + | -- | The nix expression contained a @builtins.trace@ + -- call. Ideally we should keep track of during which + -- attribute it was encountered. It is not an attribute + -- property because we can not reasonably know which + -- attributes (plural) trigger the evaluation of + -- @trace@. Indeed side effecting evaluation breaks the + -- abstraction. + Trace + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Organizations.hs b/src/Hercules/API/Organizations.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Organizations.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Hercules.API.Organizations + ( OrganizationsAPI (..), + ) +where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Organizations.BillingInfo (BillingInfo) +import Hercules.API.Organizations.CreateOrganization (CreateOrganization) +import Hercules.API.Organizations.Organization (Organization) +import Hercules.API.Organizations.PaymentLink (PaymentLink) +import Hercules.API.Prelude +import Servant.API +import Servant.API.Generic + +data OrganizationsAPI auth f = OrganizationsAPI + { findOrganizations :: + f + :- Summary "Get all organizations user has admin access to" + :> auth + :> "api" + :> "organizations" + :> Get '[JSON] [Organization], + createOrganization :: + f + :- Summary "Create a new organization" + :> auth + :> "api" + :> "organizations" + :> ReqBody '[JSON] CreateOrganization + :> Post '[JSON] Organization, + connectAccountToOrganization :: + f + :- Summary "Connect an account to an organization" + :> auth + :> "api" + :> "organizations" + :> Capture "organizationId" (Id Organization) + :> "accounts" + :> Capture "accountId" (Id Account) + :> Post '[JSON] NoContent, + paymentLinkForOrganization :: + f + :- Summary "Generate payment link for an organization" + :> auth + :> "api" + :> "organizations" + :> Capture "organizationId" (Id Organization) + :> "paymentLink" + :> Post '[JSON] PaymentLink, + getOrganizationActiveUsers :: + f :- Summary "List the active users in an organization's accounts." + :> auth + :> "api" + :> "organizations" + :> Capture "organizationId" (Id Organization) + :> "billing" + :> Get '[JSON] BillingInfo + } + deriving (Generic) diff --git a/src/Hercules/API/Organizations/BillingInfo.hs b/src/Hercules/API/Organizations/BillingInfo.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Organizations/BillingInfo.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Organizations.BillingInfo where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude + +data BillingInfo = BillingInfo + { nextPayment :: Maybe UTCTime, + activeUsers :: [Account] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Organizations/CreateOrganization.hs b/src/Hercules/API/Organizations/CreateOrganization.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Organizations/CreateOrganization.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Organizations.CreateOrganization where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude + +data CreateOrganization = CreateOrganization + { displayName :: Text, + primaryAccountId :: Id Account + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Organizations/Organization.hs b/src/Hercules/API/Organizations/Organization.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Organizations/Organization.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Organizations.Organization where + +import qualified Hercules.API.BillingStatus as BillingStatus +import Hercules.API.Prelude + +data Organization = Organization + { id :: Id Organization, + displayName :: Text, + billingStatus :: BillingStatus.BillingStatus, + trialStartedOn :: Maybe UTCTime, + subscriptionStartedOn :: Maybe UTCTime, + subscriptionCancelledOn :: Maybe UTCTime, + subscriptionCancelUrl :: Maybe Text, + subscriptionUpdateUrl :: Maybe Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Organizations/PaymentLink.hs b/src/Hercules/API/Organizations/PaymentLink.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Organizations/PaymentLink.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Organizations.PaymentLink where + +import Hercules.API.Prelude + +data PaymentLink = PaymentLink + { url :: Text, + productId :: Integer + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Orphans.hs b/src/Hercules/API/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Orphans.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Hercules.API.Orphans where + +import Data.Proxy +import Data.Swagger +import Servant.API + +-- | Ignores Headers. +-- +-- FIXME: don't ignore headers +instance forall a hs. ToSchema a => ToSchema (Headers hs a) where + declareNamedSchema _ = declareNamedSchema (Proxy @a) diff --git a/src/Hercules/API/Projects.hs b/src/Hercules/API/Projects.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Projects where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Build.EvaluationDetail + ( EvaluationDetail, + ) +import qualified Hercules.API.Build.FailureGraph as FailureGraph +import Hercules.API.Build.Log (Log) +import Hercules.API.Prelude +import Hercules.API.Projects.CreateProject + ( CreateProject, + ) +import Hercules.API.Projects.CreateUserEffectTokenResponse (CreateUserEffectTokenResponse) +import Hercules.API.Projects.Job + ( Job, + ProjectAndJobs, + ) +import Hercules.API.Projects.PatchProject + ( PatchProject, + ) +import Hercules.API.Projects.Project (Project) +import Hercules.API.SourceHostingSite.SourceHostingSite + ( SourceHostingSite, + ) +import Servant.API +import Servant.API.Generic + +data ProjectsAPI auth f = ProjectsAPI + { projectsByOwner :: + f + :- Summary "List all projects owned by an account." + :> "accounts" + :> Capture' '[Required, Strict] "accountId" (Id Account) + :> "projects" + :> auth + :> Get '[JSON] [Project], + findProjects :: + f + :- Summary "Find projects" + :> "projects" + :> QueryParam' '[Optional] "site" (Name SourceHostingSite) + :> QueryParam' '[Optional] "account" (Name Account) + :> QueryParam' '[Optional] "project" (Name Project) + :> auth + :> Get '[JSON] [Project], + createProject :: + f + :- Summary "Create a new project." + :> "projects" + :> auth + :> ReqBody '[JSON] CreateProject + :> Post '[JSON] (Id Project), + patchProject :: + f + :- Summary "Modify a project" + :> "projects" + :> Capture' '[Required, Strict] "projectId" (Id Project) + :> ReqBody '[JSON] PatchProject + :> auth + :> Patch '[JSON] Project, + createUserEffectToken :: + f + :- Summary "Create a token for local effect execution" + :> "projects" + :> Capture' '[Required, Strict] "projectId" (Id Project) + :> auth + :> "create-user-effect-token" + :> Post '[JSON] CreateUserEffectTokenResponse, + projectJobs :: + f + :- Summary "List all jobs in a project" + :> Description "A list of a project's revisions and their details and status." + :> "projects" + :> Capture' '[Required, Strict] "project" (Id Project) + :> "jobs" + :> auth + :> Get '[JSON] [Job], + findJobs :: + f + :- Summary "Find jobs" + :> "jobs" + :> QueryParam' '[Optional, Description "Currently only \"github\" or omit entirely"] "site" (Name SourceHostingSite) + :> QueryParam' '[Optional, Description "Account name filter"] "account" (Name Account) + :> QueryParam' '[Optional, Description "Project name filter. Required if you want to retrieve all jobs"] "project" (Name Project) + :> QueryParam' '[Optional, Description "To get a specific job by index"] "index" Int + :> QueryParam' '[Optional, Description "Number of latest jobs to get, when project name is omitted. Range [1..50], default 10."] "latest" Int + :> auth + :> Get '[JSON] [ProjectAndJobs], + projectJobEvaluation :: + f + :- Summary "List all attributes in a job" + :> Description "A list of all attributes that have been produced as part of the evaluation of a job." + :> "jobs" + :> Capture' '[Required, Strict] "jobId" (Id Job) + :> "evaluation" + :> auth + :> Get '[JSON] EvaluationDetail, + jobDerivationFailureGraph :: + f + :- Summary "Find all failures in an evaluation's derivations" + :> Description + "Returns all derivations that have failures in their dependency closures." + :> "jobs" + :> Capture' '[Required, Strict] "jobId" (Id Job) + :> "derivations" + :> "failed" + :> auth + :> Get '[JSON] FailureGraph.Graph, + jobRerun :: + f :- Summary "Create a new job like this job" + :> Description + "The newly created job will be in the same project, have the same inputs but a new evaluation.\ + \ The response has the newly created job." + :> "jobs" + :> Capture' '[Required, Strict] "jobId" (Id Job) + :> "rerun" + :> QueryParam "rebuildFailures" Bool + :> auth + :> Post '[JSON] Job, + jobCancel :: + f :- Summary "Cancel the job and any work that becomes redundant" + :> Description + "Some derivations may keep going, if referenced by active jobs." + :> "jobs" + :> Capture' '[Required, Strict] "jobId" (Id Job) + :> "cancel" + :> auth + :> Post '[JSON] NoContent, + getEvaluationLog :: + f :- Summary "Read all recorded evaluation log entries" + :> "jobs" + :> Capture' '[Required, Strict] "jobId" (Id Job) + :> "evaluation" + :> "log" + :> "lines" + :> QueryParam' '[Required] "logId" (Id "log") + :> QueryParam' '[Optional] "iMin" Int + :> auth + :> Get '[JSON] Log + } + deriving (Generic) diff --git a/src/Hercules/API/Projects/CreateProject.hs b/src/Hercules/API/Projects/CreateProject.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects/CreateProject.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Projects.CreateProject where + +import Hercules.API.Prelude +import Hercules.API.Repos.Repo (Repo) + +data CreateProject = CreateProject + { primaryRepoId :: Id Repo, + enabled :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Projects/CreateUserEffectTokenResponse.hs b/src/Hercules/API/Projects/CreateUserEffectTokenResponse.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects/CreateUserEffectTokenResponse.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Projects.CreateUserEffectTokenResponse where + +import Hercules.API.Prelude + +data CreateUserEffectTokenResponse = CreateUserEffectTokenResponse + { token :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Projects/Job.hs b/src/Hercules/API/Projects/Job.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects/Job.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Projects.Job where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Evaluation.Evaluation + ( Evaluation, + ) +import Hercules.API.Prelude +import Hercules.API.Projects.Project (Project) +import Hercules.API.Repos.Repo (Repo) + +data Job = Job + { id :: Id Job, + projectId :: Id Project, + index :: Int64, + repoId :: Id Repo, + startTime :: UTCTime, + endTime :: Maybe UTCTime, + jobPhase :: JobPhase, + isCancelled :: Bool, + jobStatus :: JobStatus, + evaluationStatus :: JobStatus, + derivationStatus :: JobStatus, + effectsStatus :: JobStatus, + evaluationId :: Id Evaluation, + source :: GitCommitSource, + rerunOf :: Maybe (Id Job), + rerunOfIndex :: Maybe Int, + startedBy :: Maybe (Id Account), + cancelledBy :: Maybe (Id Account), + mayCancel :: Bool, + mayRerun :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data GitCommitSource = GitCommitSource + { revision :: Text, + ref :: Text, + message :: Text, + gitCommitterName :: Text, + committer :: Maybe Account, + link :: Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data JobPhase + = Queued + | Evaluating + | Building + | Effects + | Done + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +data JobStatus + = Pending + | Failure + | Success + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) + +-- | Whichever is "worse": 'Failure' wins out, otherwise 'Pending' wins out, otherwise all are 'Success'. +instance Semigroup JobStatus where + Failure <> _ = Failure + _ <> Failure = Failure + Pending <> _ = Pending + _ <> Pending = Pending + Success <> Success = Success + +-- | @mappend@: Whichever is "worse": 'Failure' wins out, otherwise 'Pending' wins out, otherwise all are 'Success'. +-- +-- @mempty@: 'Success' +instance Monoid JobStatus where + mappend = (<>) + + mempty = Success + +data ProjectAndJobs = ProjectAndJobs + { project :: Project, + jobs :: [Job] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Projects/PatchProject.hs b/src/Hercules/API/Projects/PatchProject.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects/PatchProject.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Projects.PatchProject where + +import Hercules.API.Prelude + +-- | Changes to a Project. 'Nothing' represents no change in a field. +data PatchProject = PatchProject + { enabled :: Maybe Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Projects/Project.hs b/src/Hercules/API/Projects/Project.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects/Project.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Projects.Project where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude +import Hercules.API.Repos.Repo (Repo) +import Hercules.API.SourceHostingSite.SourceHostingSite + ( SourceHostingSite, + ) + +data Project = Project + { id :: Id Project, + ownerId :: Id Account, + repoId :: Id Repo, + enabled :: Bool, + siteSlug :: Name SourceHostingSite, + slug :: Name Project, + displayName :: Text, + imageURL :: Maybe Text, + -- | True if no authorization is required for retrieving basic + -- information about a project, such as its existence, name, + -- job statuses etc. + isPublic :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Projects/SimpleJob.hs b/src/Hercules/API/Projects/SimpleJob.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Projects/SimpleJob.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Projects.SimpleJob where + +import Hercules.API.Prelude +import Hercules.API.Projects.Job (Job) +import Hercules.API.Projects.Project (Project) + +data SimpleJob = SimpleJob + { id :: Id Job, + project :: Project, + index :: Int64 + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Repos.hs b/src/Hercules/API/Repos.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Repos.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.API.Repos where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude +import Hercules.API.Repos.Repo (Repo) +import Hercules.API.Repos.RepoKey (RepoKey) +import Servant.API +import Servant.API.Generic + +data ReposAPI auth f = ReposAPI + { reposByOwner :: + f + :- Summary "Repositories that the account owns or has explicit access to." + :> "accounts" + :> Capture' '[Required, Strict] "accountId" (Id Account) + :> "repos" + :> auth + :> Get '[JSON] [Repo], + parseGitURL :: + 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 + } + deriving (Generic) diff --git a/src/Hercules/API/Repos/Repo.hs b/src/Hercules/API/Repos/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Repos/Repo.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Repos.Repo where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude + +-- | Information about a repository on a connected repository site such as github. +data Repo = Repo + { id :: Id Repo, + ownerId :: Id Account, + siteSlug :: Text, + slug :: Text, + displayName :: Text, + imageURL :: Maybe Text, + isPublic :: Bool, + -- | An installed repo is one that Hercules has permission to. + -- + -- A non-installed repo is one that is only visible because of the + -- authenticated user's credentials. + isInstalled :: Bool, + -- | Whether the authenticated user can grant permission to this + -- repository + isInstallable :: Bool + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Repos/RepoKey.hs b/src/Hercules/API/Repos/RepoKey.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Repos/RepoKey.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.Repos.RepoKey where + +import Hercules.API.Prelude +import Hercules.API.Projects.Project (Project) + +data RepoKey = RepoKey + { siteName :: Text, + ownerName :: Text, + repoName :: Text, + projectId :: Maybe (Id Project) + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/Result.hs b/src/Hercules/API/Result.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Result.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Hercules.API.Result + ( Result (..), + toEither, + fromEither, + either, + ) +where + +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + genericParseJSON, + genericToEncoding, + genericToJSON, + ) +import Data.Profunctor + ( Profunctor, + dimap, + ) +import Hercules.API.Prelude hiding (either) +import Prelude () + +data Result e a + = Ok a + | Error e + deriving (Generic, Show, Read, Eq, Ord, NFData, Functor, Foldable, Traversable) + +deriving instance (ToSchema e, ToSchema a) => ToSchema (Result e a) + +-- many more typeclasses can be implemented +instance (FromJSON e, FromJSON a) => FromJSON (Result e a) where + parseJSON = genericParseJSON schemaCompatibleOptions + +instance (ToJSON e, ToJSON a) => ToJSON (Result e a) where + toJSON = genericToJSON schemaCompatibleOptions + + toEncoding = genericToEncoding schemaCompatibleOptions + +either :: Iso (Result e a) (Result e' a') (Either e a) (Either e' a') +either = iso toEither fromEither + +toEither :: Result e a -> Either e a +toEither (Ok a) = Right a +toEither (Error e) = Left e + +fromEither :: Either e a -> Result e a +fromEither (Right a) = Ok a +fromEither (Left e) = Error e + +-- | See @lens@ package. +type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso sa bt = dimap sa (fmap bt) diff --git a/src/Hercules/API/Servant/Status.hs b/src/Hercules/API/Servant/Status.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/Servant/Status.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Hercules.API.Servant.Status where + +import Data.Text (Text) +import Servant.API + +type Get302 (cts :: [*]) (hs :: [*]) = Verb 'GET 302 cts (Headers (Header "Location" Text ': hs) NoContent) + +type Post302 (cts :: [*]) (hs :: [*]) = Verb 'POST 302 cts (Headers (Header "Location" Text ': hs) NoContent) diff --git a/src/Hercules/API/SourceHostingSite/SourceHostingSite.hs b/src/Hercules/API/SourceHostingSite/SourceHostingSite.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/SourceHostingSite/SourceHostingSite.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.SourceHostingSite.SourceHostingSite where + +import Hercules.API.Prelude + +-- | A source hosting site (example github for github.com) used for +-- source code, permissions, CI statuses, ... +data SourceHostingSite = SourceHostingSite + { id :: Id SourceHostingSite, + slug :: Name SourceHostingSite, + displayName :: Text, + newInstallationURL :: Maybe Text + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/State.hs b/src/Hercules/API/State.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/State.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hercules.API.State where + +import Data.ByteString (ByteString) +import Data.Swagger (NamedSchema (NamedSchema), binarySchema) +import Data.Swagger.Schema (ToSchema (..)) +import Hercules.API.Prelude +import Hercules.API.Projects.Project (Project) +import Hercules.API.State.ProjectState (ProjectState) +import Servant.API +import Servant.API.Generic + +-- | A newtype wrapper for servant-swagger +newtype RawBytes = RawBytes {fromRawBytes :: ByteString} + deriving newtype (MimeUnrender OctetStream, MimeRender OctetStream) + +instance ToSchema RawBytes where + declareNamedSchema _ = pure $ NamedSchema (Just "RawBytes") binarySchema + +type ContentLength = Header "Content-Length" Integer + +type ContentDisposition = Header "Content-Disposition" Text + +data StateAPI auth f = StateAPI + { putProjectStateData :: + f + :- Summary "Upload a state file" + :> "projects" + :> Capture' '[Required, Strict] "projectId" (Id Project) + :> "state" + :> Capture' '[Required, Strict] "stateName" Text + :> "data" + :> StreamBody NoFraming OctetStream (SourceIO RawBytes) + :> auth + :> Put '[JSON] NoContent, + getProjectStates :: + f + :- Summary "List all state files" + :> "projects" + :> Capture' '[Required, Strict] "projectId" (Id Project) + :> "states" + :> auth + :> Get '[JSON] ProjectState, + getProjectStateData :: + f + :- Summary "Download a state file" + :> "projects" + :> Capture' '[Required, Strict] "projectId" (Id Project) + :> "state" + :> Capture' '[Required, Strict] "stateName" Text + :> "data" + :> auth + :> StreamGet NoFraming OctetStream (Headers '[ContentLength, ContentDisposition] (SourceIO RawBytes)) + } + deriving (Generic) diff --git a/src/Hercules/API/State/ProjectState.hs b/src/Hercules/API/State/ProjectState.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/State/ProjectState.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.State.ProjectState where + +import Hercules.API.Prelude +import Hercules.API.Projects.Project (Project) +import Hercules.API.State.StateFile (StateFile) + +data ProjectState = ProjectState + { projectId :: Id Project, + stateFiles :: Map Text StateFile + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/State/StateFile.hs b/src/Hercules/API/State/StateFile.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/State/StateFile.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.State.StateFile where + +import Hercules.API.Prelude +import Hercules.API.Projects.Project (Project) +import Hercules.API.State.StateVersion (StateVersion) + +data StateFile = StateFile + { projectId :: Id Project, + name :: Text, + versions :: [StateVersion] + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/API/State/StateVersion.hs b/src/Hercules/API/State/StateVersion.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/API/State/StateVersion.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Hercules.API.State.StateVersion where + +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude +import Hercules.API.Projects.Job (Job) +import Hercules.API.Projects.Project (Project) + +data StateVersion = StateVersion + { projectId :: Id Project, + name :: Text, + version :: Int, + creationTime :: UTCTime, + -- jobId :: Maybe (Id Job), + job :: Maybe Job, + -- effectEventId :: Maybe (Id "EffectEvent"), + -- agentId :: Maybe (Id AgentSession), + uploader :: Maybe Account, + sha256 :: Maybe Text, + size :: Maybe Int + } + deriving (Generic, Show, Eq, NFData, ToJSON, FromJSON, ToSchema) diff --git a/src/Hercules/Frontend.hs b/src/Hercules/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Hercules/Frontend.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} + +module Hercules.Frontend where + +import qualified Data.Text as T +import Hercules.API.Accounts.Account (Account) +import Hercules.API.Prelude +import Hercules.API.Projects.Project (Project) +import Hercules.API.SourceHostingSite.SourceHostingSite + ( SourceHostingSite, + ) +import Network.URI +import Servant.API +import Servant.API.Generic +import Servant.Links + +-- | URL routes for the web interface. +-- +-- Typically the base URL for this is https://hercules-ci.com +data FrontendRoutes view f = FrontendRoutes + { home :: + f + :- view, + account :: + f + :- Capture' [Required, Strict] "site" (Name SourceHostingSite) + :> Capture' [Required, Strict] "account" (Name Account) + :> view, + cliAuthorize :: + f :- "settings" :> "cli" :> "authorize" + :> QueryParam' [Required, Strict] "token" Text + :> view, + project :: + f + :- Capture' [Required, Strict] "site" (Name SourceHostingSite) + :> Capture' [Required, Strict] "account" (Name Account) + :> Capture' [Required, Strict] "project" (Name Project) + :> view, + job :: + 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 + } + deriving (Generic) + +mkLinks :: URI -> FrontendRoutes Raw (AsLink Text) +mkLinks base = allFieldLinks' $ + \link -> shows2Text $ uriToString id $ linkURI link `relativeTo` base + where + shows2Text :: ShowS -> Text + shows2Text = T.pack . ($ "") + +herculesLinks :: FrontendRoutes Raw (AsLink Text) +herculesLinks = mkLinks base + where + base :: URI + base = + URI + { uriPath = "", + uriQuery = "", + uriFragment = "", + uriScheme = "https:", + uriAuthority = + Just + URIAuth + { uriUserInfo = "", + uriRegName = "hercules-ci.com", + uriPort = "" + } + }