drone (empty) → 1.0.1
raw patch · 38 files changed
+1616/−0 lines, 38 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, drone, extensible, formatting, hspec, microlens, req, servant-server, text, warp
Files
- CHANGELOG.md +15/−0
- LICENSE +21/−0
- README.md +39/−0
- Setup.hs +2/−0
- drone.cabal +100/−0
- src/Drone.hs +7/−0
- src/Drone/Client.hs +49/−0
- src/Drone/Client/Path.hs +106/−0
- src/Drone/Endpoints.hs +13/−0
- src/Drone/Endpoints/Build.hs +75/−0
- src/Drone/Endpoints/Cron.hs +45/−0
- src/Drone/Endpoints/Log.hs +24/−0
- src/Drone/Endpoints/Node.hs +42/−0
- src/Drone/Endpoints/Queue.hs +28/−0
- src/Drone/Endpoints/Repo.hs +67/−0
- src/Drone/Endpoints/Secret.hs +58/−0
- src/Drone/Endpoints/Server.hs +52/−0
- src/Drone/Endpoints/User.hs +48/−0
- src/Drone/Endpoints/Yaml.hs +31/−0
- src/Drone/Types.hs +13/−0
- src/Drone/Types/Build.hs +86/−0
- src/Drone/Types/Cron.hs +36/−0
- src/Drone/Types/Log.hs +13/−0
- src/Drone/Types/Node.hs +63/−0
- src/Drone/Types/Registry.hs +16/−0
- src/Drone/Types/Repo.hs +58/−0
- src/Drone/Types/Secret.hs +14/−0
- src/Drone/Types/Server.hs +35/−0
- src/Drone/Types/User.hs +22/−0
- test/Drone/Endpoint/BuildSpec.hs +53/−0
- test/Drone/Endpoint/CronSpec.hs +37/−0
- test/Drone/Endpoint/LogSpec.hs +24/−0
- test/Drone/Endpoint/RepoSpec.hs +49/−0
- test/Drone/Endpoint/UserSpec.hs +40/−0
- test/Drone/Test/Client.hs +21/−0
- test/Drone/Test/Fixture.hs +47/−0
- test/Drone/Test/MockServer.hs +142/−0
- test/Spec.hs +25/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,39 @@+# drone-haskell++[](https://travis-ci.org/matsubara0507/drone-haskell)+[](https://cloud.drone.io/matsubara0507/drone-haskell)+[](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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ drone.cabal view
@@ -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 <https://github.com/matsubara0507/drone-haskell#readme>+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
+ src/Drone.hs view
@@ -0,0 +1,7 @@+module Drone+ ( module X+ ) where++import Drone.Client as X+import Drone.Endpoints as X+import Drone.Types as X
+ src/Drone/Client.hs view
@@ -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)
+ src/Drone/Client/Path.hs view
@@ -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
+ src/Drone/Endpoints.hs view
@@ -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
+ src/Drone/Endpoints/Build.hs view
@@ -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
+ src/Drone/Endpoints/Cron.hs view
@@ -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
+ src/Drone/Endpoints/Log.hs view
@@ -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
+ src/Drone/Endpoints/Node.hs view
@@ -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
+ src/Drone/Endpoints/Queue.hs view
@@ -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
+ src/Drone/Endpoints/Repo.hs view
@@ -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
+ src/Drone/Endpoints/Secret.hs view
@@ -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
+ src/Drone/Endpoints/Server.hs view
@@ -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
+ src/Drone/Endpoints/User.hs view
@@ -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
+ src/Drone/Endpoints/Yaml.hs view
@@ -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
+ src/Drone/Types.hs view
@@ -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
+ src/Drone/Types/Build.hs view
@@ -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+ ]
+ src/Drone/Types/Cron.hs view
@@ -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')
+ src/Drone/Types/Log.hs view
@@ -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+ ]
+ src/Drone/Types/Node.hs view
@@ -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')
+ src/Drone/Types/Registry.hs view
@@ -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+ ]
+ src/Drone/Types/Repo.hs view
@@ -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
+ src/Drone/Types/Secret.hs view
@@ -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+ ]
+ src/Drone/Types/Server.hs view
@@ -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+ ]
+ src/Drone/Types/User.hs view
@@ -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+ ]
+ test/Drone/Endpoint/BuildSpec.hs view
@@ -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` ()
+ test/Drone/Endpoint/CronSpec.hs view
@@ -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` ()
+ test/Drone/Endpoint/LogSpec.hs view
@@ -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` ()
+ test/Drone/Endpoint/RepoSpec.hs view
@@ -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` ()
+ test/Drone/Endpoint/UserSpec.hs view
@@ -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` ()
+ test/Drone/Test/Client.hs view
@@ -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
+ test/Drone/Test/Fixture.hs view
@@ -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
+ test/Drone/Test/MockServer.hs view
@@ -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
+ test/Spec.hs view
@@ -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