diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,15 @@ +# Changelog for drone + +## Unreleased changes + +## 1.0.1 + +- Refactor dependent packages + +## 1.0.0 + +- drone 1.0 + +## 0.1.0 + +- drone 0.8.x diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 MATSUBARA Nobutada + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +# drone-haskell + +[![Build Status](https://travis-ci.org/matsubara0507/drone-haskell.svg?branch=master)](https://travis-ci.org/matsubara0507/drone-haskell) +[![Build Status](https://cloud.drone.io/api/badges/matsubara0507/drone-haskell/status.svg)](https://cloud.drone.io/matsubara0507/drone-haskell) +[![Hackage](https://img.shields.io/hackage/v/drone.svg?style=flat)](https://hackage.haskell.org/package/drone) + +Haskell client for the [Drone](https://github.com/drone/drone) API + +## USAGE + +Add to stack.yml: + +```yaml +extra-deps: +- extensible-0.5 +- github: matsubara0507/drone-haskell + commit: XXX +``` + +e.g. + +``` +$ stack ghci +>> :set -XOverloadedStrings -XOverloadedLabels +>> import Data.Extensible +>> import Network.HTTP.Req +>> token = ... +>> client = HttpClient (#host @= "localhost" <: #port @= Nothing <: #token @= token <: nil) +>> rsp <- runReq defaultHttpConfig $ getSelf client +>> responseBody rsp +``` + +## Reference + +Reference Drone API by [drone-go](https://github.com/drone/drone-go). + +- Types : https://github.com/drone/drone-go/blob/master/drone/types.go +- Paths : https://github.com/drone/drone-go/blob/master/drone/client.go#L29-L65 +- Endpoints : https://github.com/drone/drone-go/blob/master/drone/client.go diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/drone.cabal b/drone.cabal new file mode 100644 --- /dev/null +++ b/drone.cabal @@ -0,0 +1,100 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 6aac0feafa2f45286d481be0c7bdbac46e5c5ae1622b6ccc447d8ddea862602c + +name: drone +version: 1.0.1 +description: Please see the README on GitHub at +homepage: https://github.com/matsubara0507/drone-haskell#readme +bug-reports: https://github.com/matsubara0507/drone-haskell/issues +author: MATSUBARA Nobutada +maintainer: t12307043@gunma-u.ac.jp +copyright: 2018 MATSUBARA Nobutada +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/matsubara0507/drone-haskell + +library + exposed-modules: + Drone + Drone.Client + Drone.Client.Path + Drone.Endpoints + Drone.Endpoints.Build + Drone.Endpoints.Cron + Drone.Endpoints.Log + Drone.Endpoints.Node + Drone.Endpoints.Queue + Drone.Endpoints.Repo + Drone.Endpoints.Secret + Drone.Endpoints.Server + Drone.Endpoints.User + Drone.Endpoints.Yaml + Drone.Types + Drone.Types.Build + Drone.Types.Cron + Drone.Types.Log + Drone.Types.Node + Drone.Types.Registry + Drone.Types.Repo + Drone.Types.Secret + Drone.Types.Server + Drone.Types.User + other-modules: + Paths_drone + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , bytestring + , containers >=0.5.4 + , extensible >=0.4.8 + , formatting >=6.3.0 + , microlens + , req >=1.0.0 + , text + default-language: Haskell2010 + +test-suite drone-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Drone.Endpoint.BuildSpec + Drone.Endpoint.CronSpec + Drone.Endpoint.LogSpec + Drone.Endpoint.RepoSpec + Drone.Endpoint.UserSpec + Drone.Test.Client + Drone.Test.Fixture + Drone.Test.MockServer + Paths_drone + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers >=0.5.4 + , drone + , extensible >=0.4.8 + , formatting >=6.3.0 + , hspec + , microlens + , req >=2.0.0 + , servant-server + , text + , warp + default-language: Haskell2010 diff --git a/src/Drone.hs b/src/Drone.hs new file mode 100644 --- /dev/null +++ b/src/Drone.hs @@ -0,0 +1,7 @@ +module Drone + ( module X + ) where + +import Drone.Client as X +import Drone.Endpoints as X +import Drone.Types as X diff --git a/src/Drone/Client.hs b/src/Drone/Client.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Client.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Client + ( BaseClient + , HttpClient (..) + , HttpsClient (..) + , Client (..) + , mkUrl + , module X + ) where + +import Data.ByteString (ByteString) +import Data.Extensible +import Data.Text (Text) +import Drone.Client.Path as X (Paths, format, paths) +import Lens.Micro ((^.)) +import Network.HTTP.Req + +type BaseClient = Record + '[ "host" >: Text + , "port" >: Maybe Int + , "token" >: ByteString + ] + +newtype HttpClient = HttpClient BaseClient + +newtype HttpsClient = HttpsClient BaseClient + +class Client a where + type ClientScheme a :: Scheme + baseUrl :: a -> Url (ClientScheme a) + mkHeader :: a -> Option scheme + +instance Client HttpClient where + type ClientScheme HttpClient = 'Http + baseUrl (HttpClient c) = http (c ^. #host) + mkHeader (HttpClient c) = header "Authorization" ("Bearer " <> c ^. #token) <> maybe mempty port (c ^. #port) + +instance Client HttpsClient where + type ClientScheme HttpsClient = 'Https + baseUrl (HttpsClient c) = https (c ^. #host) + mkHeader (HttpsClient c) = header "Authorization" ("Bearer " <> c ^. #token) + +mkUrl :: Client c => c -> [Text] -> Url (ClientScheme c) +mkUrl c = foldl (/:) (baseUrl c) diff --git a/src/Drone/Client/Path.hs b/src/Drone/Client/Path.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Client/Path.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + + +module Drone.Client.Path + ( Paths + , XPaths + , paths + , format + , module X + )where + +import Data.Extensible +import Data.Text (Text) +import qualified Data.Text as Strict +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Builder as Builder +import Formatting (Format, int, runFormat, stext, (%)) +import qualified Formatting as X (Format) + +type Path = Format [Text] + +type Paths = XPaths [Text] + +type XPaths r = Record + '[ "pathSelf" >: Format r r + , "pathFeed" >: Format r r + , "pathRepos" >: Format r r + , "pathRepo" >: Format r (Text -> Text -> r) + , "pathRepoMove" >: Format r (Text -> Text -> r) + , "pathChown" >: Format r (Text -> Text -> r) + , "pathRepair" >: Format r (Text -> Text -> r) + , "pathBuilds" >: Format r (Text -> Text -> r) + , "pathBuild" >: Format r (Text -> Text -> Text -> r) + , "pathApprove" >: Format r (Text -> Text -> Int -> Int -> r) + , "pathDecline" >: Format r (Text -> Text -> Int -> Int -> r) + , "pathPromote" >: Format r (Text -> Text -> Int -> r) + , "pathRollback" >: Format r (Text -> Text -> Int -> r) + , "pathJob" >: Format r (Text -> Text -> Int -> Int -> r) + , "pathLog" >: Format r (Text -> Text -> Int -> Int -> Int -> r) + , "pathRepoSecrets" >: Format r (Text -> Text -> r) + , "pathRepoSecret" >: Format r (Text -> Text -> Text -> r) + , "pathRepoRegistries" >: Format r (Text -> Text -> r) + , "pathRepoRegistry" >: Format r (Text -> Text -> Text -> r) + , "pathEncryptSecret" >: Format r (Text -> Text -> r) + , "pathEncryptRegistry" >: Format r (Text -> Text -> r) + , "pathSign" >: Format r (Text -> Text -> r) + , "pathVerify" >: Format r (Text -> Text -> r) + , "pathCrons" >: Format r (Text -> Text -> r) + , "pathCron" >: Format r (Text -> Text -> Text -> r) + , "pathUsers" >: Format r r + , "pathUser" >: Format r (Text -> r) + , "pathQueue" >: Format r r + , "pathServers" >: Format r r + , "pathServer" >: Format r (Text -> r) + , "pathScalerPause" >: Format r r + , "pathScalerResume" >: Format r r + , "pathNodes" >: Format r r + , "pathNode" >: Format r (Text -> r) + , "pathVersion" >: Format r r + ] + +paths :: Paths +paths + = #pathSelf @= "api/user" + <: #pathFeed @= "api/user/feed" + <: #pathRepos @= "api/user/repos" + <: #pathRepo @= "api/repos/" % stext % "/" % stext + <: #pathRepoMove @= "api/repos/" % stext % "/" % stext % "/move" -- "?to=%s" + <: #pathChown @= "api/repos/" % stext % "/" % stext % "/chown" + <: #pathRepair @= "api/repos/" % stext % "/" % stext % "/repair" + <: #pathBuilds @= "api/repos/" % stext % "/" % stext % "/builds" -- "?%s" + <: #pathBuild @= "api/repos/" % stext % "/" % stext % "/builds/" % stext + <: #pathApprove @= "api/repos/" % stext % "/" % stext % "/builds/" % int % "/approve/" % int + <: #pathDecline @= "api/repos/" % stext % "/" % stext % "/builds/" % int % "/decline/" % int + <: #pathPromote @= "api/repos/" % stext % "/" % stext % "/builds/" % int % "/promote" -- "?%s" + <: #pathRollback @= "api/repos/" % stext % "/" % stext % "/builds/" % int % "/rollback" -- "?%s" + <: #pathJob @= "api/repos/" % stext % "/" % stext % "/builds/" % int % "/" % int + <: #pathLog @= "api/repos/" % stext % "/" % stext % "/builds/" % int % "/logs/" % int % "/" % int + <: #pathRepoSecrets @= "api/repos/" % stext % "/" % stext % "/secrets" + <: #pathRepoSecret @= "api/repos/" % stext % "/" % stext % "/secrets/" % stext + <: #pathRepoRegistries @= "api/repos/" % stext % "/" % stext % "/registry" + <: #pathRepoRegistry @= "api/repos/" % stext % "/" % stext % "/registry/" % stext + <: #pathEncryptSecret @= "api/repos/" % stext % "/" % stext % "/encrypt/secret" + <: #pathEncryptRegistry @= "api/repos/" % stext % "/" % stext % "/encrypt/registry" + <: #pathSign @= "api/repos/" % stext % "/" % stext % "/sign" + <: #pathVerify @= "api/repos/" % stext % "/" % stext % "/verify" + <: #pathCrons @= "api/repos/" % stext % "/" % stext % "/cron" + <: #pathCron @= "api/repos/" % stext % "/" % stext % "/cron/" % stext + <: #pathUsers @= "api/users" + <: #pathUser @= "api/users/" % stext + <: #pathQueue @= "api/queue" + <: #pathServers @= "api/servers" + <: #pathServer @= "api/servers/" % stext + <: #pathScalerPause @= "api/pause" + <: #pathScalerResume @= "api/resume" + <: #pathNodes @= "api/nodes" + <: #pathNode @= "api/nodes/" % stext + <: #pathVersion @= "version" + <: nil + +format :: Path a -> a +format = flip runFormat $ + filter (not . Strict.null) . Strict.split (== '/') . Lazy.toStrict . Builder.toLazyText diff --git a/src/Drone/Endpoints.hs b/src/Drone/Endpoints.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints.hs @@ -0,0 +1,13 @@ +module Drone.Endpoints + ( module Endpoints + ) where + +import Drone.Endpoints.Build as Endpoints +import Drone.Endpoints.Cron as Endpoints +import Drone.Endpoints.Log as Endpoints +import Drone.Endpoints.Node as Endpoints +import Drone.Endpoints.Queue as Endpoints +import Drone.Endpoints.Secret as Endpoints +import Drone.Endpoints.Server as Endpoints +import Drone.Endpoints.User as Endpoints +import Drone.Endpoints.Yaml as Endpoints diff --git a/src/Drone/Endpoints/Build.hs b/src/Drone/Endpoints/Build.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Build.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Build where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text, pack) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> m (JsonResponse Build) +getBuild c owner repo num = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathBuild) owner repo (pack $ show num) + opt = mkHeader c + +getBuildLast :: (MonadHttp m, Client c) => + c -> Text -> Text -> Text -> m (JsonResponse Build) +getBuildLast c owner repo branch = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathBuild) owner repo "latest" + opt = mkHeader c <> "branch" =: branch + +getBuilds :: + (MonadHttp m, Client c) => c -> Text -> Text -> Maybe Int -> m (JsonResponse [Build]) +getBuilds c owner repo page = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathBuilds) owner repo + opt = mkHeader c <> maybe mempty ("page" =:) page + +restartBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Map Text Text -> m (JsonResponse Build) +restartBuild c owner repo num params = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathBuild) owner repo (pack $ show num) + opt = mkHeader c <> Map.foldMapWithKey (=:) params + +cancelBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> m IgnoreResponse +cancelBuild c owner repo num = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathBuild) owner repo (pack $ show num) + opt = mkHeader c + +promoteBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Text -> Map Text Text -> m (JsonResponse Build) +promoteBuild c owner repo num target params = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathPromote) owner repo num + opt = mkHeader c <> "target" =: target <> Map.foldMapWithKey (=:) params + +rollbackBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Text -> Map Text Text -> m (JsonResponse Build) +rollbackBuild c owner repo num target params = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRollback) owner repo num + opt = mkHeader c <> "target" =: target <> Map.foldMapWithKey (=:) params + +approveBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Int -> m IgnoreResponse +approveBuild c owner repo num stage = req POST url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathApprove) owner repo num stage + opt = mkHeader c + +declineBuild :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Int -> m IgnoreResponse +declineBuild c owner repo num stage = req POST url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathDecline) owner repo num stage + opt = mkHeader c diff --git a/src/Drone/Endpoints/Cron.hs b/src/Drone/Endpoints/Cron.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Cron.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Cron where + +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getCron :: + (MonadHttp m, Client c) => c -> Text -> Text -> Text -> m (JsonResponse Cron) +getCron c owner name cron = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathCron) owner name cron + opt = mkHeader c + +getCrons :: + (MonadHttp m, Client c) => c -> Text -> Text -> m (JsonResponse [Cron]) +getCrons c owner name = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathCrons) owner name + opt = mkHeader c + +createCron :: + (MonadHttp m, Client c) => c -> Text -> Text -> Cron -> m (JsonResponse Cron) +createCron c owner name cron = req POST url (ReqBodyJson cron) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathCrons) owner name + opt = mkHeader c + +updateCron :: (MonadHttp m, Client c) => + c -> Text -> Text -> Text -> CronPatch -> m (JsonResponse Cron) +updateCron c owner name cron patch = req PATCH url (ReqBodyJson patch) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathCron) owner name cron + opt = mkHeader c + +deleteCron :: + (MonadHttp m, Client c) => c -> Text -> Text -> Text -> m IgnoreResponse +deleteCron c owner name cron = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathCron) owner name cron + opt = mkHeader c diff --git a/src/Drone/Endpoints/Log.hs b/src/Drone/Endpoints/Log.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Log.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Log where + +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getLogs :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Int -> Int -> m (JsonResponse [Line]) +getLogs c owner name build stage step = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathLog) owner name build stage step + opt = mkHeader c + +purgeLogs :: (MonadHttp m, Client c) => + c -> Text -> Text -> Int -> Int -> Int -> m IgnoreResponse +purgeLogs c owner name build stage step = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathLog) owner name build stage step + opt = mkHeader c diff --git a/src/Drone/Endpoints/Node.hs b/src/Drone/Endpoints/Node.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Node.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Node where + +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getNode :: (MonadHttp m, Client c) => c -> Text -> m (JsonResponse Node) +getNode c name = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathNode) name + opt = mkHeader c + +getNodes :: (MonadHttp m, Client c) => c -> m (JsonResponse [Node]) +getNodes c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathNodes) + opt = mkHeader c + +createNode :: (MonadHttp m, Client c) => c -> Node -> m (JsonResponse Node) +createNode c node = req POST url (ReqBodyJson node) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathNodes) + opt = mkHeader c + +deleteNode :: + (MonadHttp m, Client c) => c -> Text -> m IgnoreResponse +deleteNode c name = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathNode) name + opt = mkHeader c + +updateNode :: + (MonadHttp m, Client c) => c -> Text -> NodePatch -> m (JsonResponse Node) +updateNode c name patch = req PATCH url (ReqBodyJson patch) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathNode) name + opt = mkHeader c diff --git a/src/Drone/Endpoints/Queue.hs b/src/Drone/Endpoints/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Queue.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Queue where + +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getQueue :: (MonadHttp m, Client c) => c -> m (JsonResponse [Stage]) +getQueue c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathQueue) + opt = mkHeader c + + +resumeQueue :: (MonadHttp m, Client c) => c -> m IgnoreResponse +resumeQueue c = req POST url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathQueue) + opt = mkHeader c + +pauseQueue :: (MonadHttp m, Client c) => c -> m IgnoreResponse +pauseQueue c = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathQueue) + opt = mkHeader c diff --git a/src/Drone/Endpoints/Repo.hs b/src/Drone/Endpoints/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Repo.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Repo where + +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getRepo :: + (MonadHttp m, Client c) => c -> Text -> Text -> m (JsonResponse Repo) +getRepo c owner name = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepo) owner name + opt = mkHeader c + +getRepos :: + (MonadHttp m, Client c) => c -> m (JsonResponse [Repo]) +getRepos c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepos) + opt = mkHeader c + +syncRepos :: + (MonadHttp m, Client c) => c -> m (JsonResponse [Repo]) +syncRepos c = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepos) + opt = mkHeader c + +enableRepo :: + (MonadHttp m, Client c) => c -> Text -> Text -> m (JsonResponse Repo) +enableRepo c owner name = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepo) owner name + opt = mkHeader c + +disableRepo :: + (MonadHttp m, Client c) => c -> Text -> Text -> m IgnoreResponse +disableRepo c owner name = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepo) owner name + opt = mkHeader c + +updateRepo :: (MonadHttp m, Client c) => + c -> Text -> Text -> RepoPatch -> m (JsonResponse Repo) +updateRepo c owner name patch = + req PATCH url (ReqBodyJson patch) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepo) owner name + opt = mkHeader c + +chownRepo :: + (MonadHttp m, Client c) => c -> Text -> Text -> m (JsonResponse Repo) +chownRepo c owner name = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathChown) owner name + opt = mkHeader c + +repairRepo :: + (MonadHttp m, Client c) => c -> Text -> Text -> m IgnoreResponse +repairRepo c owner name = req POST url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepair) owner name + opt = mkHeader c diff --git a/src/Drone/Endpoints/Secret.hs b/src/Drone/Endpoints/Secret.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Secret.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Endpoints.Secret where + +import Data.Extensible +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +encryptSecret :: + forall m c . (MonadHttp m, Client c) => c -> Text -> Text -> Secret -> m Text +encryptSecret c owner repo secret = do + resp <- req POST url (ReqBodyJson secret) jsonResponse opt :: m (JsonResponse (Record '[ "data" >: Text ])) + pure $ responseBody resp ^. #data + where + url = mkUrl c $ format (paths ^. #pathEncryptSecret) owner repo + opt = mkHeader c + +getSecret :: + (MonadHttp m, Client c) => c -> Text -> Text -> Text -> m (JsonResponse Secret) +getSecret c owner repo name = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepoSecret) owner repo name + opt = mkHeader c + +getSecrets :: + (MonadHttp m, Client c) => c -> Text -> Text -> m (JsonResponse [Secret]) +getSecrets c owner repo = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepoSecrets) owner repo + opt = mkHeader c + +createSecret :: + (MonadHttp m, Client c) => c -> Text -> Text -> Secret -> m (JsonResponse Secret) +createSecret c owner repo secret = req POST url (ReqBodyJson secret) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepoSecrets) owner repo + opt = mkHeader c + +updateSecret :: + (MonadHttp m, Client c) => c -> Text -> Text -> Secret -> m (JsonResponse Secret) +updateSecret c owner repo secret = req PATCH url (ReqBodyJson secret) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepoSecret) owner repo (secret ^. #name) + opt = mkHeader c + +deleteSecret :: + (MonadHttp m, Client c) => c -> Text -> Text -> Text -> m IgnoreResponse +deleteSecret c owner repo name = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathRepoSecret) owner repo name + opt = mkHeader c diff --git a/src/Drone/Endpoints/Server.hs b/src/Drone/Endpoints/Server.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Server.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.Server where + +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getServer :: (MonadHttp m, Client c) => c -> Text -> m (JsonResponse Server) +getServer c name = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathServer) name + opt = mkHeader c + +getServers :: (MonadHttp m, Client c) => c -> m (JsonResponse [Server]) +getServers c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathServers) + opt = mkHeader c + +createServer :: (MonadHttp m, Client c) => c -> m (JsonResponse Server) +createServer c = req POST url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathServers) + opt = mkHeader c + +deleteServer :: (MonadHttp m, Client c) => c -> Text -> m IgnoreResponse +deleteServer c name = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathServer) name + opt = mkHeader c + +pauseAutoscale :: (MonadHttp m, Client c) => c -> m IgnoreResponse +pauseAutoscale c = req POST url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathScalerPause) + opt = mkHeader c + +resumeAutoscale :: (MonadHttp m, Client c) => c -> m IgnoreResponse +resumeAutoscale c = req POST url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathScalerResume) + opt = mkHeader c + +getVersion :: (MonadHttp m, Client c) => c -> m (JsonResponse Version) +getVersion c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathVersion) + opt = mkHeader c diff --git a/src/Drone/Endpoints/User.hs b/src/Drone/Endpoints/User.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/User.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoints.User where + +import Data.Text (Text) +import Drone.Client +import Drone.Types +import Lens.Micro ((^.)) +import Network.HTTP.Req + +getSelf :: (MonadHttp m, Client c) => c -> m (JsonResponse User) +getSelf c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathSelf) + opt = mkHeader c + +getUser :: (MonadHttp m, Client c) => c -> Text -> m (JsonResponse User) +getUser c name = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathUser) name + opt = mkHeader c + +getUsers :: (MonadHttp m, Client c) => c -> m (JsonResponse [User]) +getUsers c = req GET url NoReqBody jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathUsers) + opt = mkHeader c + +createUser :: + (MonadHttp m, Client c) => c -> User -> m (JsonResponse User) +createUser c user = req POST url (ReqBodyJson user) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathUsers) + opt = mkHeader c + +updateUser :: + (MonadHttp m, Client c) => c -> User -> m (JsonResponse User) +updateUser c user = req PATCH url (ReqBodyJson user) jsonResponse opt + where + url = mkUrl c $ format (paths ^. #pathUser) (user ^. #login) + opt = mkHeader c + +deleteUser :: (MonadHttp m, Client c) => c -> Text -> m IgnoreResponse +deleteUser c name = req DELETE url NoReqBody ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathUser) name + opt = mkHeader c diff --git a/src/Drone/Endpoints/Yaml.hs b/src/Drone/Endpoints/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Endpoints/Yaml.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Endpoints.Yaml where + +import Data.Extensible +import Data.Text (Text) +import Drone.Client +import Lens.Micro ((^.)) +import Network.HTTP.Req + +signYaml :: + forall m c . (MonadHttp m, Client c) => c -> Text -> Text -> Text -> m Text +signYaml c owner name file = do + resp <- req POST url (ReqBodyJson body) jsonResponse opt :: m (JsonResponse (Record '[ "data" >: Text ])) + pure $ responseBody resp ^. #data + where + url = mkUrl c $ format (paths ^. #pathSign) owner name + body = #data @= file <: emptyRecord + opt = mkHeader c + +verifyYaml :: + (MonadHttp m, Client c) => c -> Text -> Text -> Text -> m IgnoreResponse +verifyYaml c owner name file = req POST url (ReqBodyJson body) ignoreResponse opt + where + url = mkUrl c $ format (paths ^. #pathVerify) owner name + body = #data @= file <: emptyRecord + opt = mkHeader c diff --git a/src/Drone/Types.hs b/src/Drone/Types.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types.hs @@ -0,0 +1,13 @@ +module Drone.Types + ( module Types + ) where + +import Drone.Types.Build as Types +import Drone.Types.Cron as Types +import Drone.Types.Log as Types +import Drone.Types.Node as Types +import Drone.Types.Registry as Types +import Drone.Types.Repo as Types +import Drone.Types.Secret as Types +import Drone.Types.Server as Types +import Drone.Types.User as Types diff --git a/src/Drone/Types/Build.hs b/src/Drone/Types/Build.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Build.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Build where + +import Data.Extensible +import Data.Map (Map) +import Data.Text (Text) + +type Build = Record + '[ "id" >: Int + , "repo_id" >: Int + , "trigger" >: Text + , "number" >: Int + , "parent" >: Maybe Int + , "status" >: Text + , "error" >: Maybe Text + , "event" >: Text + , "action" >: Text + , "link" >: Text + , "timestamp" >: Int + , "title" >: Maybe Text + , "message" >: Text + , "before" >: Text + , "after" >: Text + , "ref" >: Text + , "source_repo" >: Text + , "source" >: Text + , "target" >: Text + , "author_login" >: Text + , "author_name" >: Text + , "author_email" >: Text + , "author_avatar" >: Text + , "sender" >: Text + , "params" >: Maybe (Map Text Text) + , "deploy_to" >: Maybe Text + , "started" >: Int + , "finished" >: Int + , "created" >: Int + , "updated" >: Int + , "version" >: Int + , "stages" >: Maybe [Stage] + ] + +type Stage = Record + '[ "id" >: Int + , "build_id" >: Int + , "number" >: Int + , "name" >: Text + , "kind" >: Maybe Text + , "type" >: Maybe Text + , "status" >: Text + , "error" >: Maybe Text + , "errignore" >: Bool + , "exit_code" >: Int + , "machine" >: Maybe Text + , "os" >: Text + , "arch" >: Text + , "variant" >: Maybe Text + , "kernel" >: Maybe Text + , "started" >: Int + , "stopped" >: Int + , "created" >: Int + , "updated" >: Int + , "version" >: Int + , "on_success" >: Bool + , "on_failure" >: Bool + , "depends_on" >: Maybe [Text] + , "labels" >: Maybe (Map Text Text) + , "steps" >: Maybe [Step] + ] + +type Step = Record + '[ "id" >: Int + , "step_id" >: Int + , "number" >: Int + , "name" >: Text + , "status" >: Text + , "error" >: Maybe Text + , "errignore" >: Maybe Bool + , "exit_code" >: Int + , "started" >: Maybe Int + , "stopped" >: Maybe Int + , "version" >: Int + ] diff --git a/src/Drone/Types/Cron.hs b/src/Drone/Types/Cron.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Cron.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Cron where + +import Data.Extensible +import Data.Text (Text) + +type Cron = Record + '[ "id" >: Int + , "repo_id" >: Int + , "name" >: Text + , "expr" >: Text + , "next" >: Int + , "prev" >: Int + , "event" >: Text + , "branch" >: Text + -- , "target" >: Text + , "disabled" >: Bool + , "created" >: Int + , "updated" >: Int + ] + +type CronPatch = Nullable (Field Identity) :* CronPatchFields + +type CronPatchFields = + '[ "event" >: Text + , "branch" >: Text + -- , "target" >: Text + , "disabled" >: Bool + ] + +type CronPatch' = Record CronPatchFields + +toCronPatch :: Cron -> CronPatch +toCronPatch repo = wrench (shrink repo :: CronPatch') diff --git a/src/Drone/Types/Log.hs b/src/Drone/Types/Log.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Log.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Log where + +import Data.Extensible +import Data.Text (Text) + +type Line = Record + '[ "pos" >: Int + , "out" >: Text + , "time" >: Int + ] diff --git a/src/Drone/Types/Node.hs b/src/Drone/Types/Node.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Node.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Node where + +import Data.Extensible +import Data.Map (Map) +import Data.Text (Text) + +type Node = Record + '[ "id" >: Int + , "uid" >: Text + , "provider" >: Text + , "state" >: Text + , "name" >: Text + , "image" >: Text + , "region" >: Text + , "size" >: Text + , "os" >: Text + , "arch" >: Text + , "kernel" >: Text + , "variant" >: Text + , "address" >: Text + , "capacity" >: Int + , "filters" >: [Text] + , "labels" >: Map Text Text + , "error" >: Text + , "ca_key" >: Text + , "ca_cert" >: Text + , "tls_key" >: Text + , "tls_cert" >: Text + , "paused" >: Bool + , "protected" >: Bool + , "created" >: Int + , "updated" >: Int + ] + +type NodePatch = Nullable (Field Identity) :* NodePatchFields + +type NodePatchFields = + '[ "uid" >: Text + , "provider" >: Text + , "state" >: Text + , "image" >: Text + , "region" >: Text + , "size" >: Text + , "address" >: Text + , "capacity" >: Int + , "filters" >: [Text] + , "labels" >: Map Text Text + , "error" >: Text + , "ca_key" >: Text + , "ca_cert" >: Text + , "tls_key" >: Text + , "tls_cert" >: Text + , "paused" >: Bool + , "protected" >: Bool + ] + +type NodePatch' = Record NodePatchFields + +toNodePatch :: Node -> NodePatch +toNodePatch repo = wrench (shrink repo :: NodePatch') diff --git a/src/Drone/Types/Registry.hs b/src/Drone/Types/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Registry.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Registry where + +import Data.Extensible +import Data.Text (Text) + +type Registry = Record + '[ "address" >: Text + , "username" >: Text + , "password" >: Maybe Text + , "email" >: Text + , "token" >: Text + , "policy" >: Maybe Text + ] diff --git a/src/Drone/Types/Repo.hs b/src/Drone/Types/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Repo.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Repo + ( Repo + , RepoPatch + , toRepoPatch + )where + +import Data.Extensible +import Data.Text (Text) + +type Repo = Record + '[ "id" >: Int + , "uid" >: Text + , "user_id" >: Int + , "namespace" >: Text + , "name" >: Text + , "slug" >: Text + , "scm" >: Text + , "git_http_url" >: Text + , "git_ssh_url" >: Text + , "link" >: Text + , "default_branch" >: Text + , "private" >: Bool + , "visibility" >: Text + , "active" >: Bool + , "config_path" >: Text + , "trusted" >: Bool + , "protected" >: Bool + , "timeout" >: Int + , "counter" >: Int + , "synced" >: Int + , "created" >: Int + , "updated" >: Int + , "version" >: Int + ] + +type RepoPatch = Nullable (Field Identity) :* RepoPatchFields + +type RepoPatchFields = + '[ "config_path" >: Text + , "protected" >: Bool + , "trusted" >: Bool + , "timeout" >: Int + , "visibility" >: Text + , "counter" >: Int + ] + +type RepoPatch' = Record RepoPatchFields + +toRepoPatch :: Repo -> RepoPatch +toRepoPatch repo = wrench patch + where + patch :: RepoPatch' + patch = shrink repo diff --git a/src/Drone/Types/Secret.hs b/src/Drone/Types/Secret.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Secret.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Secret where + +import Data.Extensible +import Data.Text (Text) + +type Secret = Record + '[ "name" >: Text + , "data" >: Maybe Text + , "pull_request" >: Maybe Bool + , "pull_request_push" >: Maybe Bool + ] diff --git a/src/Drone/Types/Server.hs b/src/Drone/Types/Server.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/Server.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.Server where + +import Data.Extensible +import Data.Text (Text) + +type Server = Record + '[ "id" >: Text + , "provider" >: Text + , "state" >: Text + , "name" >: Text + , "image" >: Text + , "region" >: Text + , "size" >: Text + , "address" >: Text + , "capacity" >: Int + , "secret" >: Text + , "error" >: Text + , "ca_key" >: Text + , "ca_cert" >: Text + , "tls_key" >: Text + , "tls_cert" >: Text + , "created" >: Int + , "updated" >: Int + , "started" >: Int + , "stopped" >: Int + ] + +type Version = Record + '[ "source" >: Text + , "version" >: Text + , "commit" >: Text + ] diff --git a/src/Drone/Types/User.hs b/src/Drone/Types/User.hs new file mode 100644 --- /dev/null +++ b/src/Drone/Types/User.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Types.User where + +import Data.Extensible +import Data.Text (Text) + +type User = Record + '[ "id" >: Int + , "login" >: Text + , "email" >: Text + , "avatar" >: Text + , "active" >: Bool + , "admin" >: Bool + , "machine" >: Bool + , "syncing" >: Bool + , "synced" >: Int + , "created" >: Int + , "updated" >: Int + , "last_login" >: Int + ] diff --git a/test/Drone/Endpoint/BuildSpec.hs b/test/Drone/Endpoint/BuildSpec.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Endpoint/BuildSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoint.BuildSpec + ( spec + ) where + +import qualified Data.Map as Map +import Drone.Endpoints.Build +import qualified Drone.Test.Client as Test +import Drone.Test.Fixture +import Lens.Micro ((^.)) +import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Fixtures -> Spec +spec golden = do + describe "getBuild: endpoint GET /api/repos/%s/%s/builds/%d" $ + it "should return Build as response body" $ do + response <- runReq defaultHttpConfig $ getBuild Test.client "octocat" "hello-world" 1 + (responseBody response) `shouldBe` golden ^. #build + describe "getBuildLast: endpoint GET /api/repos/%s/%s/builds/latest?branch=%s" $ + it "should return Build as response body" $ do + response <- runReq defaultHttpConfig $ getBuildLast Test.client "octocat" "hello-world" "master" + (responseBody response) `shouldBe` golden ^. #build + describe "getBuilds: endpoint GET /api/repos/%s/%s/builds?page=%d" $ + it "should return [Build] as response body" $ do + response <- runReq defaultHttpConfig $ getBuilds Test.client "octocat" "hello-world" Nothing + (responseBody response) `shouldBe` golden ^. #builds + describe "restartBuild: endpoint POST /api/repos/%s/%s/builds/%d" $ + it "should return Build as response body" $ do + response <- runReq defaultHttpConfig $ restartBuild Test.client "octocat" "hello-world" 1 Map.empty + (responseBody response) `shouldBe` golden ^. #build + describe "cancelBuild: endpoint DELETE /api/repos/%s/%s/builds/%d" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ cancelBuild Test.client "octocat" "hello-world" 1 + (responseBody response) `shouldBe` () + describe "promoteBuild: endpoint POST /api/repos/%s/%s/builds/%d/promote?target=%s" $ + it "should return Build as response body" $ do + response <- runReq defaultHttpConfig $ promoteBuild Test.client "octocat" "hello-world" 1 "master" Map.empty + (responseBody response) `shouldBe` golden ^. #build + describe "rollbackBuild: endpoint POST /api/repos/%s/%s/builds/%d/rollback?target=%s" $ + it "should return Build as response body" $ do + response <- runReq defaultHttpConfig $ rollbackBuild Test.client "octocat" "hello-world" 1 "master" Map.empty + (responseBody response) `shouldBe` golden ^. #build + describe "approveBuild: endpoint POST /api/repos/%s/%s/builds/%d/approve/%d" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ approveBuild Test.client "octocat" "hello-world" 1 4 + (responseBody response) `shouldBe` () + describe "declineBuild: endpoint POST /api/repos/%s/%s/builds/%d/decline/%d" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ declineBuild Test.client "octocat" "hello-world" 1 4 + (responseBody response) `shouldBe` () diff --git a/test/Drone/Endpoint/CronSpec.hs b/test/Drone/Endpoint/CronSpec.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Endpoint/CronSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoint.CronSpec + ( spec + ) where + +import Drone.Endpoints.Cron +import qualified Drone.Test.Client as Test +import Drone.Test.Fixture +import Drone.Types.Cron +import Lens.Micro ((^.)) +import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Fixtures -> Spec +spec golden = do + describe "getCron: endpoint GET /api/repos/%s/%s/cron/%s" $ + it "should return Cron as response body" $ do + response <- runReq defaultHttpConfig $ getCron Test.client "octocat" "hello-world" "nightly" + (responseBody response) `shouldBe` golden ^. #cron + describe "getCrons: endpoint GET /api/repos/%s/%s/cron" $ + it "should return [Cron] as response body" $ do + response <- runReq defaultHttpConfig $ getCrons Test.client "octocat" "hello-world" + (responseBody response) `shouldBe` golden ^. #crons + describe "createCron: endpoint GET /api/repos/%s/%s/cron" $ + it "should return Cron as response body" $ do + response <- runReq defaultHttpConfig $ createCron Test.client "octocat" "hello-world" (golden ^. #cron) + (responseBody response) `shouldBe` golden ^. #cron + describe "updateCron: endpoint GET /api/repos/%s/%s/cron/%s" $ + it "should return Cron as response body" $ do + response <- runReq defaultHttpConfig $ updateCron Test.client "octocat" "hello-world" "nightly" (toCronPatch $ golden ^. #cron) + (responseBody response) `shouldBe` golden ^. #cron + describe "deleteCron: endpoint DELETE /api/repos/%s/%s/cron/%s" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ deleteCron Test.client "octocat" "hello-world" "nightly" + (responseBody response) `shouldBe` () diff --git a/test/Drone/Endpoint/LogSpec.hs b/test/Drone/Endpoint/LogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Endpoint/LogSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoint.LogSpec + ( spec + ) where + +import Drone.Endpoints.Log +import qualified Drone.Test.Client as Test +import Drone.Test.Fixture +import Lens.Micro ((^.)) +import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Fixtures -> Spec +spec golden = do + describe "getLogs: endpoint GET /api/repos/%s/%s/builds/%d/logs/%d/%d" $ + it "should return [Line] as response body" $ do + response <- runReq defaultHttpConfig $ getLogs Test.client "octocat" "hello-world" 1 1 1 + (responseBody response) `shouldBe` golden ^. #logs + describe "purgeLogs: endpoint DELETE /api/repos/%s/%s/builds/%d/logs/%d/%d" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ purgeLogs Test.client "octocat" "hello-world" 1 1 1 + (responseBody response) `shouldBe` () diff --git a/test/Drone/Endpoint/RepoSpec.hs b/test/Drone/Endpoint/RepoSpec.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Endpoint/RepoSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoint.RepoSpec + ( spec + ) where + +import Drone.Endpoints.Repo +import qualified Drone.Test.Client as Test +import Drone.Test.Fixture +import Drone.Types.Repo +import Lens.Micro ((^.)) +import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Fixtures -> Spec +spec golden = do + describe "getRepo: endpoint GET /api/repos/%s/%s" $ + it "should return Repo as response body" $ do + response <- runReq defaultHttpConfig $ getRepo Test.client "octocat" "hello-world" + (responseBody response) `shouldBe` golden ^. #repo + describe "getRepos: endpoint GET /api/user/repos" $ + it "should return [Repo] as response body" $ do + response <- runReq defaultHttpConfig $ getRepos Test.client + (responseBody response) `shouldBe` golden ^. #repos + describe "syncRepos: endpoint POST /api/user/repos" $ + it "should return [Repo] as response body" $ do + response <- runReq defaultHttpConfig $ syncRepos Test.client + (responseBody response) `shouldBe` golden ^. #repos + describe "enableRepo: endpoint POST /api/repos/%s/%s" $ + it "should return Repo as response body" $ do + response <- runReq defaultHttpConfig $ enableRepo Test.client "octocat" "hello-world" + (responseBody response) `shouldBe` golden ^. #repo + describe "disableRepo: endpoint DELETE /api/repos/%s/%s" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ disableRepo Test.client "octocat" "hello-world" + (responseBody response) `shouldBe` () + describe "updateRepo: endpoint PATCH /api/repos/%s/%s" $ + it "should return Repo as response body" $ do + response <- runReq defaultHttpConfig $ updateRepo Test.client "octocat" "hello-world" (toRepoPatch $ golden ^. #repo) + (responseBody response) `shouldBe` golden ^. #repo + describe "chownRepo: endpoint POST /api/repos/%s/%s/chown" $ + it "should return Repo as response body" $ do + response <- runReq defaultHttpConfig $ chownRepo Test.client "octocat" "hello-world" + (responseBody response) `shouldBe` golden ^. #repo + describe "repairRepo: endpoint POST /api/repos/%s/%s/repair" $ + it "should return () as response body" $ do + response <- runReq defaultHttpConfig $ repairRepo Test.client "octocat" "hello-world" + (responseBody response) `shouldBe` () diff --git a/test/Drone/Endpoint/UserSpec.hs b/test/Drone/Endpoint/UserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Endpoint/UserSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Drone.Endpoint.UserSpec + ( spec + ) where + +import Drone.Endpoints.User +import qualified Drone.Test.Client as Test +import Drone.Test.Fixture +import Lens.Micro ((^.)) +import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Fixtures -> Spec +spec golden = do + describe "getSelf: endpoint GET /api/user" $ + it "should return User as response body" $ do + response <- runReq defaultHttpConfig $ getSelf Test.client + (responseBody response) `shouldBe` golden ^. #user + describe "getUser: endpoint GET /api/user/%s" $ + it "should return User as response body" $ do + response <- runReq defaultHttpConfig $ getUser Test.client "octocat" + (responseBody response) `shouldBe` golden ^. #user + describe "getUsers: endpoint GET /api/users" $ + it "should return [User] as response body" $ do + response <- runReq defaultHttpConfig $ getUsers Test.client + (responseBody response) `shouldBe` golden ^. #users + describe "createUser: endpoint GET /api/users" $ + it "should return [User] as response body" $ do + response <- runReq defaultHttpConfig $ createUser Test.client (golden ^. #user) + (responseBody response) `shouldBe` golden ^. #user + describe "updateUser: endpoint GET /api/user/%s" $ + it "should return User as response body" $ do + response <- runReq defaultHttpConfig $ updateUser Test.client (golden ^. #user) + (responseBody response) `shouldBe` golden ^. #user + describe "deleteUser: endpoint GET /api/user/%s" $ + it "should return User as response body" $ do + response <- runReq defaultHttpConfig $ deleteUser Test.client "octocat" + (responseBody response) `shouldBe` () diff --git a/test/Drone/Test/Client.hs b/test/Drone/Test/Client.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Test/Client.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Drone.Test.Client + ( TestClient (..) + , client + ) where + +import Drone.Client (BaseClient, Client (..)) +import Network.HTTP.Req (Scheme (Http), http, port) + +newtype TestClient = TestClient BaseClient + +instance Client TestClient where + type ClientScheme TestClient = 'Http + baseUrl = const (http "localhost") + mkHeader = const (port 8080) + +client :: TestClient +client = TestClient undefined diff --git a/test/Drone/Test/Fixture.hs b/test/Drone/Test/Fixture.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Test/Fixture.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeOperators #-} + +module Drone.Test.Fixture where + +import Control.Exception.Base +import Data.Aeson (FromJSON, eitherDecodeFileStrict) +import Data.Extensible +import Drone.Types + +type Fixtures = Record + '[ "user" >: User + , "users" >: [User] + , "repo" >: Repo + , "repos" >: [Repo] + , "cron" >: Cron + , "crons" >: [Cron] + , "build" >: Build + , "builds" >: [Build] + , "logs" >: [Line] + ] + +newtype JSONParseException = + JSONParseException String deriving (Show) + +instance Exception JSONParseException + +readJSON :: FromJSON a => FilePath -> IO a +readJSON path = + eitherDecodeFileStrict path >>= \case + Left e -> throwIO $ JSONParseException ("in " ++ path ++ ": " ++ e) + Right x -> pure x + +readFixtures :: FilePath -> FilePath -> IO Fixtures +readFixtures root suffix = hsequence + $ #user <@=> readJSON (root ++ "user.json" ++ suffix) + <: #users <@=> readJSON (root ++ "users.json" ++ suffix) + <: #repo <@=> readJSON (root ++ "repo.json" ++ suffix) + <: #repos <@=> readJSON (root ++ "repos.json" ++ suffix) + <: #cron <@=> readJSON (root ++ "cron.json" ++ suffix) + <: #crons <@=> readJSON (root ++ "crons.json" ++ suffix) + <: #build <@=> readJSON (root ++ "build.json" ++ suffix) + <: #builds <@=> readJSON (root ++ "builds.json" ++ suffix) + <: #logs <@=> readJSON (root ++ "logs.json" ++ suffix) + <: nil diff --git a/test/Drone/Test/MockServer.hs b/test/Drone/Test/MockServer.hs new file mode 100644 --- /dev/null +++ b/test/Drone/Test/MockServer.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Drone.Test.MockServer + ( mockServer + , runMockServer + ) where + +import Control.Concurrent +import Data.Extensible (type (>:), Record) +import Data.Text (Text) +import Drone.Test.Fixture (Fixtures) +import Drone.Types hiding (Server) +import Lens.Micro ((^.)) +import Network.Wai.Handler.Warp +import Servant + +type RakutenHeader a = a + +type API = "api" :> API' + +type API' = UserAPI :<|> RepoAPI :<|> BuildAPI :<|> LogAPI :<|> CronAPI + +type UserAPI + = "user" :> Get '[JSON] User + :<|> "users" :> Get '[JSON] [User] + :<|> "users" :> Capture "login" Text :> Get '[JSON] User + :<|> "users" :> ReqBody '[JSON] User :> Post '[JSON] User + :<|> "users" :> Capture "login" Text :> ReqBody '[JSON] User :> Patch '[JSON] User + :<|> "users" :> Capture "login" Text :> Delete '[JSON] () + +type RepoAPI + = "repos" :> Capture "owner" Text :> Capture "name" Text :> Get '[JSON] Repo + :<|> "user" :> "repos" :> Get '[JSON] [Repo] + :<|> "user" :> "repos" :> Post '[JSON] [Repo] + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> Post '[JSON] Repo + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> Delete '[JSON] () + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> ReqBody '[JSON] RepoPatch :> Patch '[JSON] Repo + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "chown" :> Post '[JSON] Repo + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "repair" :> Post '[JSON] () + +type BuildAPI + = "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> Get '[JSON] Build + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> "latest" :> Get '[JSON] Build + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Get '[JSON] [Build] + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Text :> Post '[JSON] Build + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Text :> Delete '[JSON] () + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> "promote" :> Post '[JSON] Build + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> "rollback" :> Post '[JSON] Build + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> "approve" :> Capture "stage" Int :> Post '[JSON] () + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> "decline" :> Capture "stage" Int :> Post '[JSON] () + +type LogAPI + = "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> "logs" :> Capture "stage" Int :> Capture "step" Int :> Get '[JSON] [Line] + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "builds" :> Capture "build" Int :> "logs" :> Capture "stage" Int :> Capture "step" Int :> Delete '[JSON] () + +type CronAPI + = "repos" :> Capture "owner" Text :> Capture "name" Text :> "cron" :> Capture "cron" Text :> Get '[JSON] Cron + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "cron" :> Get '[JSON] [Cron] + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "cron" :> ReqBody '[JSON] Cron :> Post '[JSON] Cron + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "cron" :> Capture "cron" Text :> ReqBody '[JSON] CronPatch :> Patch '[JSON] Cron + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "cron" :> Capture "cron" Text :> Delete '[JSON] () + +-- Unuse API in test + +type YamlAPI + = "repos" :> Capture "owner" Text :> Capture "name" Text :> "sign" :> ReqBody '[JSON] (Record '[ "data" >: Text ]) :> Post '[JSON] (Record '[ "data" >: Text ]) + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "verify" :> ReqBody '[JSON] (Record '[ "data" >: Text ]) :> Post '[JSON] () + +type SecretAPI + = "repos" :> Capture "owner" Text :> Capture "name" Text :> "encrypt" :> "secret" :> ReqBody '[JSON] Secret :> Post '[JSON] (Record '[ "data" >: Text ]) + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "secrets" :> Capture "secret" Text :> Get '[JSON] Secret + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "secrets" :> Get '[JSON] [Secret] + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "secrets" :> ReqBody '[JSON] Secret :> Post '[JSON] Secret + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "secrets" :> Capture "secret" Text :> ReqBody '[JSON] Secret :> Patch '[JSON] Secret + :<|> "repos" :> Capture "owner" Text :> Capture "name" Text :> "secrets" :> Capture "secret" Text :> Delete '[JSON] () + +api :: Proxy API +api = Proxy + +server :: Fixtures -> Server API +server fixtures + = (getSelf :<|> getUsers :<|> getUser :<|> createUser :<|> updateUser :<|> deleteUser) + :<|> (getRepo :<|> getRepos :<|> syncRepos :<|> enableRepo :<|> disableRepo :<|> updateRepo :<|> chownRepo :<|> repairRepo) + :<|> (getBuild :<|> getBuildLast :<|> getBuilds :<|> restartBuild :<|> cancelBuild :<|> promoteBuild :<|> rollbackBuild :<|> approveBuild :<|> declineBuild) + :<|> (getLogs :<|> purgeLogs) + :<|> (getCron :<|> getCrons :<|> createCron :<|> updateCron :<|> deleteCron) + -- :<|> (signYaml :<|> verifyYaml) + -- :<|> (encryptSecret :<|> getSecret :<|> getSecrets :<|> updateSecret :<|> deleteSecret) + where + getSelf = pure $ fixtures ^. #user + getUsers = pure $ fixtures ^. #users + getUser = \_ -> pure $ fixtures ^. #user + createUser = \user -> pure user + updateUser = \_ user -> pure user + deleteUser = \_ -> pure () + getRepo = \_ _ -> pure $ fixtures ^. #repo + getRepos = pure $ fixtures ^. #repos + syncRepos = pure $ fixtures ^. #repos + enableRepo = \_ _ -> pure $ fixtures ^. #repo + disableRepo = \_ _ -> pure () + updateRepo = \_ _ _ -> pure $ fixtures ^. #repo + chownRepo = \_ _ -> pure $ fixtures ^. #repo + repairRepo = \_ _ -> pure () + getBuild = \_ _ _ -> pure $ fixtures ^. #build + getBuildLast = \_ _ -> pure $ fixtures ^. #build + getBuilds = \_ _ -> pure $ fixtures ^. #builds + restartBuild = \_ _ _ -> pure $ fixtures ^. #build + cancelBuild = \_ _ _ -> pure () + promoteBuild = \_ _ _ -> pure $ fixtures ^. #build + rollbackBuild = \_ _ _ -> pure $ fixtures ^. #build + approveBuild = \_ _ _ _ -> pure () + declineBuild = \_ _ _ _ -> pure () + getLogs = \_ _ _ _ _ -> pure $ fixtures ^. #logs + purgeLogs = \_ _ _ _ _ -> pure () + getCron = \_ _ _ -> pure $ fixtures ^. #cron + getCrons = \_ _ -> pure $ fixtures ^. #crons + createCron = \_ _ cron -> pure cron + updateCron = \_ _ _ _ -> pure $ fixtures ^. #cron + deleteCron = \_ _ _ -> pure () + -- signYaml = \_ _ yaml -> pure yaml + -- verifyYaml = \_ _ _ -> pure () + -- encryptSecret = \_ _ _ -> pure $ #data @= "" <: nil + -- getSecret = \_ _ _ -> pure $ fixtures ^. #secret + -- getSecrets = \_ _ -> pure $ fixtures ^. #secrets + -- createSecret = \_ _ _ -> pure $ fixtures ^. #secret + -- updateSecret = \_ _ _ _ -> pure $ fixtures ^. #secret + -- deleteSecret = \_ _ _ -> pure () + +mockServer :: Fixtures -> IO () +mockServer = run 8080 . serve api . server + +runMockServer :: Fixtures -> IO () -> IO () +runMockServer fixtures action = do + _ <- forkIO (mockServer fixtures) + action diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,25 @@ +module Main where + +import Test.Hspec + +import qualified Drone.Endpoint.BuildSpec +import qualified Drone.Endpoint.CronSpec +import qualified Drone.Endpoint.LogSpec +import qualified Drone.Endpoint.RepoSpec +import qualified Drone.Endpoint.UserSpec +import Drone.Test.Fixture +import Drone.Test.MockServer (runMockServer) + +main :: IO () +main = do + fixtures <- readFixtures "fixture/drone/testdata/" "" + golden <- readFixtures "fixture/drone/testdata/" ".golden" + hspec $ spec fixtures golden + +spec :: Fixtures -> Fixtures -> Spec +spec fixtures golden = around_ (runMockServer fixtures) $ do + describe "Drone.Endpoints.User" $ Drone.Endpoint.UserSpec.spec golden + describe "Drone.Endpoints.Repo" $ Drone.Endpoint.RepoSpec.spec golden + describe "Drone.Endpoints.Build" $ Drone.Endpoint.BuildSpec.spec golden + describe "Drone.Endpoints.Log" $ Drone.Endpoint.LogSpec.spec golden + describe "Drone.Endpoints.Cron" $ Drone.Endpoint.CronSpec.spec golden