├── bin └── .gitkeep ├── static ├── .gitkeep └── index.js ├── elm-src ├── Generated │ └── .gitkeep ├── Pages │ ├── Player.elm │ ├── Team.elm │ ├── Board.elm │ └── Graph.elm ├── Score.elm └── Main.elm ├── .dockerignore ├── Setup.hs ├── image └── scoreboard.png ├── ngrok └── config.yml ├── .gitmodules ├── .gitignore ├── src ├── Git │ ├── Plantation.hs │ ├── Plantation │ │ ├── Cmd │ │ │ ├── Arg.hs │ │ │ ├── Env.hs │ │ │ ├── Arg │ │ │ │ ├── Problem.hs │ │ │ │ ├── Internal.hs │ │ │ │ └── Team.hs │ │ │ ├── Problem.hs │ │ │ ├── Org.hs │ │ │ ├── Member.hs │ │ │ └── Repo.hs │ │ ├── Data.hs │ │ ├── Data │ │ │ ├── User.hs │ │ │ ├── Repo.hs │ │ │ ├── Slack │ │ │ │ └── Verification.hs │ │ │ ├── Problem.hs │ │ │ ├── Team.hs │ │ │ ├── Slack.hs │ │ │ └── Job.hs │ │ ├── Job │ │ │ ├── Store.hs │ │ │ ├── Docker.hs │ │ │ ├── Protocol.hs │ │ │ ├── Worker.hs │ │ │ ├── Client.hs │ │ │ └── Server.hs │ │ ├── Cmd.hs │ │ ├── Auth │ │ │ └── GitHub.hs │ │ ├── Config.hs │ │ ├── API │ │ │ ├── CRUD.hs │ │ │ ├── GitHub.hs │ │ │ ├── Job.hs │ │ │ └── Slack.hs │ │ ├── Score.hs │ │ ├── Env.hs │ │ └── API.hs │ └── Cmd.hs └── Orphans.hs ├── config ├── .env.template ├── .git-plantation.yaml └── docker-compose.yml ├── test ├── spec │ ├── Spec.hs │ ├── Fixture.hs │ └── Spec │ │ └── Git │ │ └── Plantation │ │ └── Score.hs └── GenerateElm.hs ├── Makefile ├── Dockerfile ├── exec ├── tool │ ├── SubCmd │ │ ├── Org.hs │ │ ├── Problem.hs │ │ ├── Config.hs │ │ ├── Member.hs │ │ └── Repo.hs │ ├── SubCmd.hs │ ├── Main.hs │ └── Options.hs ├── jobrunner │ └── Main.hs ├── jobserver │ └── Main.hs └── app │ └── Main.hs ├── LICENSE ├── elm.json ├── stack.yaml ├── README.md ├── .github └── workflows │ └── build.yml ├── package.yaml ├── CHANGELOG.md ├── stack.yaml.lock └── git-plantation.cabal /bin/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /static/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /elm-src/Generated/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | elm-stuff 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /image/scoreboard.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsubara0507/git-plantation/HEAD/image/scoreboard.png -------------------------------------------------------------------------------- /ngrok/config.yml: -------------------------------------------------------------------------------- 1 | tunnels: 2 | app: 3 | proto: http 4 | addr: 8080 5 | drone: 6 | proto: http 7 | addr: 8000 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "elm-lib/line-charts"] 2 | path = elm-lib/line-charts 3 | url = https://github.com/matsubara0507/line-charts 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .temp/ 4 | .env 5 | *.sqlite 6 | 7 | .elm 8 | *.js 9 | !index.js 10 | elm-stuff 11 | 12 | bin/ 13 | -------------------------------------------------------------------------------- /static/index.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | var json = JSON.parse( 4 | document.getElementById('config').textContent 5 | ); 6 | 7 | Elm.Main.init( 8 | { node: document.getElementById('main') 9 | , flags: { config: json } 10 | } 11 | ); 12 | -------------------------------------------------------------------------------- /src/Git/Plantation.hs: -------------------------------------------------------------------------------- 1 | module Git.Plantation 2 | ( module X 3 | ) where 4 | 5 | import Git.Plantation.Config as X 6 | import Git.Plantation.Data as X 7 | import Git.Plantation.Env as X 8 | import Git.Plantation.Score as X 9 | -------------------------------------------------------------------------------- /config/.env.template: -------------------------------------------------------------------------------- 1 | GH_TOKEN= 2 | GH_SECRET= 3 | 4 | SLACK_SIGNING_SECRET= 5 | SLACK_VERIFY_TOKEN= 6 | SLACK_SLASH_TEAM_ID= 7 | SLACK_SLASH_CHANNEL_IDS= 8 | SLACK_API_TOKEN= 9 | SLACK_NOTIFY_CHANNEL= 10 | SLACK_SLASH_WEBHOOK= 11 | SLACK_PUSH_NOTIFY_WEBHOOK= 12 | 13 | AUTHN_CLIENT_ID= 14 | AUTHN_CLIENT_SECRET= 15 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Arg.hs: -------------------------------------------------------------------------------- 1 | module Git.Plantation.Cmd.Arg 2 | ( module X 3 | ) where 4 | 5 | import Git.Plantation.Cmd.Arg.Internal as X (ArgInfo, IdArg (..), 6 | findByIdWith) 7 | import Git.Plantation.Cmd.Arg.Problem as X () 8 | import Git.Plantation.Cmd.Arg.Team as X 9 | -------------------------------------------------------------------------------- /test/spec/Spec.hs: -------------------------------------------------------------------------------- 1 | import RIO 2 | 3 | import qualified Spec.Git.Plantation.Score 4 | import Test.Tasty 5 | import Test.Tasty.Hspec 6 | 7 | main :: IO () 8 | main = defaultMain =<< spec 9 | 10 | spec :: IO TestTree 11 | spec = testGroup "Git.Plantation" <$> sequence 12 | [ testSpec "Git.Plantation.Score" Spec.Git.Plantation.Score.spec 13 | ] 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: elm-src image 3 | elm-src: 4 | stack test --skip spec 5 | elm-format --yes elm-src/Generated 6 | 7 | app: 8 | stack --docker --local-bin-path=./bin install 9 | 10 | image: 11 | stack --docker build --test --skip spec --copy-bins --local-bin-path=./bin 12 | elm-format --yes elm-src/Generated 13 | docker build -t ${tag} . --build-arg local_bin_path=./bin 14 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM codesimple/elm:0.19 as build-elm 2 | WORKDIR /work 3 | COPY . /work 4 | RUN elm make elm-src/Main.elm --output=static/main.js --optimize 5 | 6 | FROM ghcr.io/matsubara0507/ubuntu-for-haskell:docker 7 | ARG local_bin_path 8 | WORKDIR /work 9 | COPY ${local_bin_path} /usr/local/bin 10 | COPY --from=build-elm /work/static /work/static 11 | 12 | CMD ["git-plantation-app"] 13 | -------------------------------------------------------------------------------- /test/spec/Fixture.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Fixture 4 | ( config 5 | ) where 6 | 7 | import Data.Yaml.TH (decodeFile) 8 | import Git.Plantation.Config (Config) 9 | import Instances.TH.Lift () 10 | import Language.Haskell.TH (Code (..)) 11 | 12 | config :: Config 13 | config = $$(Code (decodeFile "config/.git-plantation.yaml")) 14 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data.hs: -------------------------------------------------------------------------------- 1 | module Git.Plantation.Data 2 | ( module X 3 | ) where 4 | 5 | import Git.Plantation.Data.Job as X hiding (Config, Id, findById) 6 | import Git.Plantation.Data.Problem as X hiding (Id, Name) 7 | import Git.Plantation.Data.Repo as X hiding (Name) 8 | import Git.Plantation.Data.Team as X hiding (Id, Name) 9 | import Git.Plantation.Data.User as X hiding (Name) 10 | -------------------------------------------------------------------------------- /exec/tool/SubCmd/Org.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module SubCmd.Org 6 | ( OrgCmd (..) 7 | ) where 8 | 9 | import RIO 10 | 11 | import Data.Extensible 12 | import Git.Plantation.Cmd 13 | 14 | newtype OrgCmd = OrgCmd (Variant CmdField) 15 | 16 | type CmdField = 17 | '[ "create_team" >: OrgCmdArg 18 | ] 19 | 20 | instance Run ("create_team" >: OrgCmdArg) where 21 | run' _ args = 22 | actForGitHubTeam createGitHubTeam args `catchAny` (logError . displayShow) 23 | -------------------------------------------------------------------------------- /exec/tool/SubCmd/Problem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module SubCmd.Problem 6 | ( ProblemCmd (..) 7 | ) where 8 | 9 | import RIO 10 | 11 | import Data.Extensible 12 | import Git.Plantation.Cmd 13 | 14 | newtype ProblemCmd = ProblemCmd (Variant CmdField) 15 | 16 | type CmdField = 17 | '[ "show" >: ProblemCmdArg 18 | ] 19 | 20 | instance Run ("show" >: ProblemCmdArg) where 21 | run' _ args = 22 | actForProblem showProblem args `catchAny` (logError . displayShow) 23 | -------------------------------------------------------------------------------- /exec/tool/SubCmd/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module SubCmd.Config 7 | ( ConfigCmd (..) 8 | ) where 9 | 10 | import RIO 11 | 12 | import Data.Extensible 13 | import Git.Plantation.Cmd 14 | import Git.Plantation.Config as Config 15 | 16 | newtype ConfigCmd = ConfigCmd (Variant CmdFields) 17 | 18 | type CmdFields = 19 | '[ "verify" >: () 20 | ] 21 | 22 | instance Run ("verify" >: ()) where 23 | run' _ _ = do 24 | conf <- askConfig 25 | case Config.verify conf of 26 | Left err -> logError $ "invalid config: " <> display err 27 | Right _ -> logInfo "valid config" 28 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Git.Plantation.Cmd.Env where 7 | 8 | import RIO 9 | 10 | import Data.Extensible 11 | import Git.Plantation.Config 12 | import qualified Mix.Plugin.Config as MixConfig 13 | import qualified Mix.Plugin.GitHub as MixGitHub 14 | import qualified Mix.Plugin.Shell as MixShell 15 | 16 | class HasGitHubUser env where 17 | ghUserL :: Lens' env Text 18 | 19 | instance Lookup xs "gh_user" Text => HasGitHubUser (Record xs) where 20 | ghUserL = lens (view #gh_user) (\x y -> x & #gh_user `set` y) 21 | 22 | type CmdEnv env = (MixConfig.HasConfig Config env, MixGitHub.HasGitHubToken env, MixShell.HasWorkDir env, HasLogFunc env, HasGitHubUser env) 23 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Arg/Problem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Git.Plantation.Cmd.Arg.Problem where 9 | 10 | import RIO 11 | import qualified RIO.List as L 12 | 13 | import Data.Coerce (coerce) 14 | import Data.Extensible 15 | import Git.Plantation.Cmd.Arg.Internal 16 | import Git.Plantation.Data.Problem 17 | import qualified Git.Plantation.Data.Problem as Problem 18 | 19 | instance IdArg Problem.Id Problem where 20 | findById idx = L.find (\p -> p ^. #id == coerce idx) 21 | toArgInfo idx 22 | = #type @= "Problem" 23 | <: #id @= tshow (coerce idx :: Int) 24 | <: nil 25 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Arg/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Git.Plantation.Cmd.Arg.Internal where 8 | 9 | import RIO 10 | 11 | import Data.Extensible 12 | import Git.Plantation.Config 13 | import Mix.Plugin.Config (HasConfig (..)) 14 | 15 | class IdArg id a | id -> a where 16 | findById :: id -> [a] -> Maybe a 17 | toArgInfo :: id -> ArgInfo 18 | 19 | type ArgInfo = Record 20 | '[ "type" >: Text 21 | , "id" >: Text 22 | ] 23 | 24 | asksConfig :: (HasConfig Config env, MonadReader env m) => m Config 25 | asksConfig = view configL 26 | 27 | findByIdWith :: (IdArg id a, HasConfig Config env, MonadReader env m) 28 | => (Config -> [a]) -> id -> m (Maybe a) 29 | findByIdWith f idx = findById idx . f <$> asksConfig 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 MATSUBARA Nobutada 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /test/GenerateElm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Main where 6 | 7 | import RIO 8 | 9 | import Elm.Mapping 10 | import Git.Plantation (Config, Link, Problem, Repo, Score, 11 | ScoreBoardConfig, Status, Team, User) 12 | import Git.Plantation.API.CRUD (GetAPI) 13 | import Servant ((:>)) 14 | import Servant.Elm.Mapping (defElmImports, defElmOptions, 15 | generateElmModuleWith) 16 | 17 | main :: IO () 18 | main = 19 | generateElmModuleWith 20 | defElmOptions 21 | ["Generated", "API"] 22 | defElmImports 23 | "elm-src" 24 | [ DefineElm (Proxy @Team) 25 | , DefineElm (Proxy @User) 26 | , DefineElm (Proxy @Repo) 27 | , DefineElm (Proxy @Problem) 28 | , DefineElm (Proxy @Config) 29 | , DefineElm (Proxy @ScoreBoardConfig) 30 | , DefineElm (Proxy @Score) 31 | , DefineElm (Proxy @Status) 32 | , DefineElm (Proxy @Link) 33 | ] 34 | (Proxy @("api" :> GetAPI)) 35 | -------------------------------------------------------------------------------- /exec/tool/SubCmd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module SubCmd 6 | ( module X 7 | , SubCmd 8 | ) where 9 | 10 | import SubCmd.Config as X (ConfigCmd (..)) 11 | import SubCmd.Member as X (MemberCmd (..)) 12 | import SubCmd.Org as X (OrgCmd (..)) 13 | import SubCmd.Problem as X (ProblemCmd (..)) 14 | import SubCmd.Repo as X (RepoCmd (..)) 15 | 16 | import Data.Extensible 17 | import Git.Plantation.Cmd 18 | 19 | 20 | type SubCmd = Variant 21 | '[ "config" >: ConfigCmd 22 | , "repo" >: RepoCmd 23 | , "member" >: MemberCmd 24 | , "problem" >: ProblemCmd 25 | , "org" >: OrgCmd 26 | ] 27 | 28 | instance Run ("config" >: ConfigCmd) where 29 | run' _ (ConfigCmd cmd) = run cmd 30 | 31 | instance Run ("repo" >: RepoCmd) where 32 | run' _ (RepoCmd cmd) = run cmd 33 | 34 | instance Run ("member" >: MemberCmd) where 35 | run' _ (MemberCmd cmd) = run cmd 36 | 37 | instance Run ("problem" >: ProblemCmd) where 38 | run' _ (ProblemCmd cmd) = run cmd 39 | 40 | instance Run ("org" >: OrgCmd) where 41 | run' _ (OrgCmd cmd) = run cmd 42 | -------------------------------------------------------------------------------- /src/Git/Cmd.hs: -------------------------------------------------------------------------------- 1 | module Git.Cmd where 2 | 3 | import RIO 4 | import qualified RIO.Text as Text 5 | 6 | import Shelly hiding (FilePath, unlessM) 7 | 8 | clone :: [Text] -> Sh () 9 | clone = command1_ "git" [] "clone" 10 | 11 | fetch :: [Text] -> Sh () 12 | fetch = command1_ "git" [] "fetch" 13 | 14 | pull :: [Text] -> Sh () 15 | pull = command1_ "git" [] "pull" 16 | 17 | remote :: [Text] -> Sh () 18 | remote = command1_ "git" [] "remote" 19 | 20 | push :: [Text] -> Sh () 21 | push = command1_ "git" [] "push" 22 | 23 | checkout :: [Text] -> Sh () 24 | checkout = command1_ "git" [] "checkout" 25 | 26 | commit :: [Text] -> Sh () 27 | commit = command1_ "git" [] "commit" 28 | 29 | add :: [Text] -> Sh () 30 | add = command1_ "git" [] "add" 31 | 32 | branch :: [Text] -> Sh () 33 | branch = command1_ "git" [] "branch" 34 | 35 | cloneOrFetch :: Text -> Text -> Sh () 36 | cloneOrFetch repoUrl repoName = do 37 | dir <- pwd 38 | let repoDir = dir repoName 39 | unlessM (test_d repoDir) $ clone [repoUrl, repoName] 40 | chdir repoDir $ fetch ["origin"] 41 | 42 | existBranch :: Text -> Sh Bool 43 | existBranch branchName = do 44 | branches <- Text.lines <$> command1 "git" [] "branch" [] 45 | pure $ any (Text.isSuffixOf branchName) branches 46 | -------------------------------------------------------------------------------- /elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "elm-src", 5 | "elm-lib/line-charts/src" 6 | ], 7 | "elm-version": "0.19.1", 8 | "dependencies": { 9 | "direct": { 10 | "bartavelle/json-helpers": "2.0.2", 11 | "debois/elm-dom": "1.3.0", 12 | "elm/browser": "1.0.1", 13 | "elm/core": "1.0.2", 14 | "elm/html": "1.0.0", 15 | "elm/http": "2.0.0", 16 | "elm/json": "1.1.3", 17 | "elm/svg": "1.0.1", 18 | "elm/time": "1.0.0", 19 | "elm/url": "1.0.0", 20 | "elm-community/list-extra": "8.2.2", 21 | "justinmimbs/time-extra": "1.1.0", 22 | "justinmimbs/timezone-data": "2.1.4", 23 | "myrho/elm-round": "1.0.4", 24 | "ryannhg/date-format": "2.3.0", 25 | "tesk9/palette": "2.0.0" 26 | }, 27 | "indirect": { 28 | "elm/bytes": "1.0.8", 29 | "elm/file": "1.0.5", 30 | "elm/parser": "1.1.0", 31 | "elm/virtual-dom": "1.0.0", 32 | "justinmimbs/date": "3.2.0" 33 | } 34 | }, 35 | "test-dependencies": { 36 | "direct": {}, 37 | "indirect": {} 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /exec/tool/SubCmd/Member.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module SubCmd.Member 8 | ( MemberCmd (..) 9 | ) where 10 | 11 | import RIO 12 | 13 | import Data.Extensible 14 | import Git.Plantation.Cmd 15 | 16 | newtype MemberCmd = MemberCmd (Variant CmdFields) 17 | 18 | type CmdFields = 19 | '[ "invite" >: MemberCmdArg 20 | , "kick" >: MemberCmdArg 21 | ] 22 | 23 | instance Run ("invite" >: MemberCmdArg) where 24 | run' _ args = handleAny (logError . displayShow) $ if 25 | | isJust (args ^. #gh_team) -> actForMemberWithGitHubTeam inviteUserToGitHubOrgTeam args 26 | | args ^. #org -> actForMemberWithOrg inviteUserToGitHubOrg args 27 | | otherwise -> actForMember inviteUserToRepo args 28 | 29 | instance Run ("kick" >: MemberCmdArg) where 30 | run' _ args = handleAny (logError . displayShow) $ if 31 | | isJust (args ^. #gh_team) -> actForMemberWithGitHubTeam kickUserFromGitHubOrgTeam args 32 | | args ^. #org -> actForMemberWithOrg kickUserFromGitHubOrg args 33 | | otherwise -> actForMember kickUserFromRepo args 34 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Git.Plantation.Data.User where 8 | 9 | import RIO 10 | 11 | import Data.Aeson (FromJSON, ToJSON) 12 | import Data.Binary (Binary) 13 | import Data.Extensible 14 | import Data.Extensible.Elm.Mapping 15 | import Elm.Mapping 16 | import Language.Haskell.TH.Syntax (Lift) 17 | import Web.HttpApiData (FromHttpApiData) 18 | 19 | newtype Name = Name Text 20 | deriving newtype (Show, Eq, Ord, IsString, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 21 | deriving (Lift) 22 | 23 | newtype GitHubId = GitHubId Text 24 | deriving newtype (Show, Eq, Ord, IsString, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 25 | deriving (Lift) 26 | 27 | type User = Record 28 | '[ "name" >: Name 29 | , "github" >: GitHubId 30 | ] 31 | 32 | instance IsElmType User where 33 | compileElmType = compileElmRecordTypeWith "User" 34 | 35 | instance IsElmDefinition User where 36 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "User" 37 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Git.Plantation.Data.Repo where 8 | 9 | import RIO 10 | 11 | import Data.Aeson (FromJSON, ToJSON) 12 | import Data.Binary (Binary) 13 | import Data.Extensible 14 | import Data.Extensible.Elm.Mapping 15 | import Elm.Mapping 16 | import qualified Git.Plantation.Data.Problem as Problem 17 | import Language.Haskell.TH.Syntax (Lift) 18 | import Web.HttpApiData (FromHttpApiData) 19 | 20 | newtype Name = Name Text 21 | deriving newtype (Show, Eq, Ord, IsString, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 22 | deriving (Lift) 23 | 24 | type Repo = Record 25 | '[ "name" >: Name 26 | , "owner" >: Maybe Text 27 | , "org" >: Maybe Text 28 | , "problem" >: Problem.Id 29 | , "private" >: Bool 30 | , "only" >: Maybe Text -- GitHub Org Team 31 | ] 32 | 33 | instance IsElmType Repo where 34 | compileElmType = compileElmRecordTypeWith "Repo" 35 | 36 | instance IsElmDefinition Repo where 37 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Repo" 38 | -------------------------------------------------------------------------------- /src/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Orphans () where 9 | 10 | import RIO 11 | 12 | import Control.Monad.Error.Class (throwError) 13 | import Data.Aeson (FromJSON, ToJSON) 14 | import Data.Extensible 15 | import Elm.Mapping 16 | import qualified Servant.Auth.Server as Auth 17 | import Servant.Server (runHandler) 18 | import Web.FormUrlEncoded 19 | import Web.HttpApiData 20 | 21 | instance Forall (KeyTargetAre KnownSymbol FromHttpApiData) xs => FromForm (Record xs) where 22 | fromForm form = 23 | hgenerateFor (Proxy @(KeyTargetAre KnownSymbol FromHttpApiData)) $ \m -> 24 | Field <$> parseUnique (stringKeyOf m) form 25 | 26 | instance IsElmType Int64 where 27 | compileElmType _ = toElmType (Proxy @Int) 28 | 29 | instance ToJSON (xs :& Field h) => Auth.ToJWT (xs :& Field h) 30 | instance FromJSON (xs :& Field h) => Auth.FromJWT (xs :& Field h) 31 | 32 | instance Auth.ThrowAll (RIO env a) where 33 | throwAll err = liftIO (runHandler $ throwError err) >>= \case 34 | Right a -> pure a 35 | Left e -> throwIO e 36 | -------------------------------------------------------------------------------- /elm-src/Pages/Player.elm: -------------------------------------------------------------------------------- 1 | module Pages.Player exposing (Model, Msg, init, update, view) 2 | 3 | import Generated.API as API exposing (..) 4 | import Html exposing (Html) 5 | import Pages.Board as Board 6 | import Pages.Graph as Graph 7 | import Pages.Team as Team 8 | import Score exposing (Score) 9 | 10 | 11 | type alias Model = 12 | { id : String, teamID : String, graph : Graph.Model } 13 | 14 | 15 | type alias Global a = 16 | { a 17 | | config : API.ScoreBoardConfig 18 | , problems : List API.Problem 19 | , scores : List Score 20 | } 21 | 22 | 23 | type alias Msg = 24 | Graph.Msg 25 | 26 | 27 | init : Global a -> String -> String -> Model 28 | init global teamID id = 29 | { id = id, teamID = teamID, graph = Graph.init global } 30 | 31 | 32 | update : Msg -> Model -> ( Model, Cmd Msg ) 33 | update msg model = 34 | let 35 | ( graph, newMsg ) = 36 | Graph.update msg model.graph 37 | in 38 | ( { model | graph = graph }, newMsg ) 39 | 40 | 41 | view : Global a -> Model -> Html Msg 42 | view global model = 43 | let 44 | filtered = 45 | { global | scores = Score.filterByPlayerID model.id global.scores } 46 | in 47 | Html.div [] 48 | [ Board.view filtered 49 | , Team.viewFilters filtered { id = model.teamID, graph = model.graph } 50 | , Graph.view filtered model.graph 51 | ] 52 | -------------------------------------------------------------------------------- /src/Git/Plantation/Job/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 8 | 9 | module Git.Plantation.Job.Store where 10 | 11 | import RIO 12 | import qualified RIO.Map as Map 13 | 14 | import Data.Extensible 15 | import Git.Plantation.Data.Job (Job) 16 | import qualified Git.Plantation.Data.Job as Job 17 | 18 | type Store = TVar (Map Job.Id Job) 19 | 20 | class HasStore env where 21 | storeL :: Lens' env Store 22 | 23 | instance Lookup xs "store" Store => HasStore (Record xs) where 24 | storeL = lens (view #store) (\x y -> x & #store `set` y) 25 | 26 | askStore :: HasStore env => RIO env Store 27 | askStore = view storeL 28 | 29 | newStore :: MonadIO m => m Store 30 | newStore = newTVarIO mempty 31 | 32 | initializeStore :: HasStore env => [Job] -> RIO env () 33 | initializeStore jobs = do 34 | store <- askStore 35 | atomically $ writeTVar store (Map.fromList $ fmap (\job -> (job ^. #id, job)) jobs) 36 | 37 | withStore :: HasStore env => RIO env Job -> RIO env Job 38 | withStore m = do 39 | job <- m 40 | store <- askStore 41 | atomically $ modifyTVar' store (Map.insert (job ^. #id) job) 42 | pure job 43 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Git.Plantation.Cmd 7 | ( module X 8 | , Env 9 | , Run (..) 10 | , run 11 | , showNotImpl 12 | ) where 13 | 14 | import RIO 15 | 16 | import Data.Extensible 17 | import Git.Plantation.Cmd.Arg as X 18 | import Git.Plantation.Cmd.Env as X 19 | import Git.Plantation.Cmd.Member as X 20 | import Git.Plantation.Cmd.Org as X 21 | import Git.Plantation.Cmd.Problem as X 22 | import Git.Plantation.Cmd.Repo as X 23 | import Git.Plantation.Config (Config) 24 | import Git.Plantation.Env (WebhookConfig) 25 | import qualified Mix.Plugin.GitHub as GitHub 26 | 27 | 28 | type Env = Record 29 | '[ "config" >: Config 30 | , "github" >: GitHub.Token 31 | , "gh_user" >: Text 32 | , "work" >: FilePath 33 | , "webhook" >: WebhookConfig 34 | , "logger" >: LogFunc 35 | ] 36 | 37 | class Run kv where 38 | run' :: proxy kv -> TargetOf kv -> RIO Env () 39 | 40 | run :: Forall Run xs => Variant xs -> RIO Env () 41 | run = matchField (htabulateFor (Proxy @Run) $ \m -> Field (Match $ run' m . runIdentity)) 42 | 43 | showNotImpl :: MonadIO m => m () 44 | showNotImpl = hPutBuilder stdout "not yet implement command." 45 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2023-06-16 2 | packages: 3 | - . 4 | extra-deps: 5 | - binary-instances-1.0.4 6 | - extensible-0.9 7 | # - github: fumieval/extensible 8 | # commit: 4a1edb50c90d377085fcc3bad4c9f6e9d296b00e 9 | - fallible-0.1.0 10 | - incremental-0.3.1 11 | - membership-0.0.1 12 | - github: tsani/servant-github-webhook 13 | commit: f8cb8bc10d3e9d275fa995b0d01ba2d1eeaa700b 14 | 15 | # - servant-auth-0.4.1.0 16 | # - servant-auth-server-0.4.7.0 17 | # - servant-foreign-0.15.4 18 | - github: haskell-servant/servant 19 | commit: a082794a48546ffd681f4206436c59b9c1f901e1 20 | subdirs: 21 | - servant 22 | - servant-auth/servant-auth # for lens-5.2 23 | - servant-auth/servant-auth-server # for jose-0.10, NOTE unsuport monad-time-0.4.0.0 24 | - servant-foreign # for lens-5.2 25 | - servant-elm-0.7.3 26 | 27 | # - github-0.28.0.1 28 | - github: matsubara0507/github 29 | commit: 521ee92de8811cad022b5924e3be5c668d5b7b73 # myext branch 30 | 31 | - github: matsubara0507/elmap.hs 32 | commit: 3cd415ba620aeb588c5f7217d96a8d6f05cb45f1 33 | subdirs: 34 | - elmap 35 | - servant-elmap 36 | - extensible-elmap 37 | - github: matsubara0507/mix.hs 38 | commit: da914f3c0ec152e5814ed5495c9c3aef2ceec4ed 39 | subdirs: 40 | - mix 41 | - mix-json-logger 42 | - mix-plugin-github 43 | - mix-plugin-persistent-sqlite 44 | - mix-plugin-shell 45 | - helper/rio-logger-ext 46 | 47 | allow-newer: true 48 | 49 | docker: 50 | repo: ghcr.io/matsubara0507/stack-build:22.04 51 | enable: false 52 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/Slack/Verification.hs: -------------------------------------------------------------------------------- 1 | -- | ref: https://api.slack.com/authentication/verifying-requests-from-slack 2 | 3 | module Git.Plantation.Data.Slack.Verification 4 | ( SigningSecret 5 | , RequestTimestamp 6 | , SignatureHeader 7 | , encodeSignature 8 | , convertSignatureHeader 9 | ) where 10 | 11 | import RIO 12 | import qualified RIO.ByteString as B 13 | import qualified RIO.Text as Text 14 | import qualified RIO.Text.Partial as Text 15 | 16 | import Crypto.Hash (Digest, SHA256, digestFromByteString) 17 | import Crypto.MAC.HMAC (HMAC (..), hmac) 18 | import Data.ByteArray.Encoding (Base (..), convertFromBase) 19 | 20 | newtype SigningSecret = SigningSecret Text deriving (IsString) 21 | 22 | type RequestTimestamp = Text 23 | 24 | type SignatureHeader = Text 25 | 26 | encodeSignature :: SigningSecret -> RequestTimestamp -> ByteString -> Digest SHA256 27 | encodeSignature (SigningSecret secret) ts body = 28 | hmacGetDigest $ hmac (Text.encodeUtf8 secret) basestr 29 | where 30 | basestr = B.intercalate ":" [Text.encodeUtf8 version, Text.encodeUtf8 ts, body] 31 | 32 | convertSignatureHeader :: SignatureHeader -> Maybe (Digest SHA256) 33 | convertSignatureHeader sign = either (const Nothing) digestFromByteString bs 34 | where 35 | (_, sign') = Text.breakOnEnd (version <> "=") sign 36 | bs = convertFromBase Base16 (Text.encodeUtf8 sign') :: Either String ByteString 37 | 38 | version :: Text 39 | version = "v0" 40 | -------------------------------------------------------------------------------- /config/.git-plantation.yaml: -------------------------------------------------------------------------------- 1 | scoreboard: 2 | interval: 60000 3 | 4 | owners: [] 5 | 6 | image: "ubuntu:bionic" 7 | 8 | problems: 9 | - id: 1 10 | name: tutorial 11 | repo: matsubara0507/git-challenge-tutorial 12 | difficulty: 1 13 | challenge_branches: 14 | - readme 15 | - master 16 | - task-1 17 | - task-2 18 | answer_branch: master 19 | ci_branch: ci 20 | default_branch: readme 21 | 22 | - id: 2 23 | name: is-order-an-adding 24 | repo: matsubara0507/git-challenge-is-order-an-adding 25 | difficulty: 1 26 | challenge_branches: 27 | - readme 28 | - master 29 | answer_branch: master 30 | ci_branch: ci 31 | default_branch: readme 32 | 33 | - id: 3 34 | name: minesweeper 35 | repo: matsubara0507/git-challenge-minesweeper 36 | difficulty: 1 37 | challenge_branches: 38 | - readme 39 | - master 40 | - checker 41 | answer_branch: master 42 | ci_branch: ci 43 | default_branch: readme 44 | 45 | teams: 46 | - name: sample 47 | id: alpha 48 | org: sample-hige 49 | gh_teams: 50 | - alpha-tutorial 51 | - alpha 52 | member: 53 | - name: MATSUBARA Nobutada 54 | github: matsubara0507 55 | repos: 56 | - name: git-challenge-tutorial 57 | org: sample-hige 58 | problem: 1 59 | private: false 60 | only: alpha-tutorial 61 | - name: git-challenge-is-order-an-adding 62 | org: sample-hige 63 | problem: 2 64 | private: false 65 | only: alpha 66 | - name: git-challenge-minesweeper 67 | org: sample-hige 68 | problem: 3 69 | private: false 70 | only: alpha 71 | -------------------------------------------------------------------------------- /src/Git/Plantation/Auth/GitHub.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Git.Plantation.Auth.GitHub where 6 | 7 | import RIO 8 | 9 | import Data.Extensible 10 | import Git.Plantation.Env 11 | import qualified GitHub 12 | import Network.HTTP.Req 13 | 14 | authorizeUrl :: OAuthSettings -> String -> String 15 | authorizeUrl config stat = mconcat 16 | [ "https://github.com/login/oauth/authorize" 17 | , "?client_id=", config ^. #client_id 18 | , "&state=", stat 19 | ] 20 | 21 | fetchUser :: MonadIO m => ByteString -> m (Either GitHub.Error GitHub.User) 22 | fetchUser token = 23 | liftIO $ GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR 24 | 25 | fetchToken :: MonadIO m => OAuthSettings -> String -> m ByteString 26 | fetchToken config code = 27 | runReq defaultHttpConfig $ 28 | toToken . responseBody <$> postTokenRequest (shrink $ #code @= code <: config) 29 | 30 | postTokenRequest :: MonadHttp m => TokenParams -> m (JsonResponse TokenInfo) 31 | postTokenRequest params = 32 | req POST url (ReqBodyJson params) jsonResponse mempty 33 | where 34 | url = https "github.com" /: "login" /: "oauth" /: "access_token" 35 | 36 | toToken :: TokenInfo -> ByteString 37 | toToken info = fromString $ info ^. #access_token 38 | 39 | type TokenInfo = Record '[ "access_token" >: String ] 40 | 41 | type TokenParams = Record 42 | '[ "client_id" >: String 43 | , "client_secret" >: String 44 | , "code" >: String 45 | ] 46 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/Problem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Git.Plantation.Data.Problem where 8 | 9 | import RIO 10 | 11 | import Data.Aeson (FromJSON, ToJSON) 12 | import Data.Binary (Binary) 13 | import Data.Extensible 14 | import Data.Extensible.Elm.Mapping 15 | import Elm.Mapping 16 | import Language.Haskell.TH.Syntax (Lift) 17 | import Web.HttpApiData (FromHttpApiData) 18 | 19 | newtype Id = Id Int 20 | deriving newtype (Show, Read, Eq, Ord, Num, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 21 | deriving (Lift) 22 | 23 | newtype Name = Name Text 24 | deriving newtype (Show, Eq, Ord, IsString, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 25 | deriving (Lift) 26 | 27 | type Problem = Record 28 | '[ "id" >: Id 29 | , "name" >: Name 30 | , "repo" >: Text 31 | , "difficulty" >: Int 32 | , "challenge_branches" >: [Branch] 33 | , "answer_branch" >: Branch 34 | , "ci_branch" >: Branch 35 | , "default_branch" >: Branch 36 | ] 37 | 38 | instance IsElmType Problem where 39 | compileElmType = compileElmRecordTypeWith "Problem" 40 | 41 | instance IsElmDefinition Problem where 42 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Problem" 43 | 44 | type Branch = Text 45 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # git-plantation 2 | 3 | ![](./image/scoreboard.png) 4 | 5 | ## Usage 6 | 7 | config 以下で docker-compose を使う 8 | 9 | ### 1. git-plantation の設定を記述 10 | 11 | ref. `config/.git-plantation.yaml` 12 | 13 | ### 2. 環境変数を設定する 14 | 15 | 16 | `config/docker-compose.yml` の `app` の `environment` を参照 17 | 18 | ``` 19 | # スコアボードにログインするための GitHub OAuth のクライアントIDとシークレット 20 | AUTHN_CLIENT_ID 21 | AUTHN_CLIENT_SECRET 22 | 23 | # スコアサーバーが GitHub Webhook を受けたときにリクエストを検証するためのシークレット 24 | # 同様の値を回答リポジトリに設定している（リポジトリ作成は自作 CLI ツール） 25 | GH_SECRET 26 | 27 | # 回答リポジトリの push を受け取ったことを Slack へ通知するための Incomming Webhook 28 | # 管理者側で誰がいつ push したのかを観測するために利用する（基本、参加者には見えないようにする） 29 | SLACK_PUSH_NOTIFY_WEBHOOK 30 | 31 | # ジョブサーバーから採点の結果をスニペットで通知するための Slack API トークン 32 | SLACK_API_TOKEN 33 | 34 | # 以下は Slack のスラッシュコマンドで回答リポジトリのリセットを受けるための秘匿情報 35 | SLACK_SIGNING_SECRET # Slack からのリクエストを検証するのに使う 36 | SLACK_VERIFY_TOKEN # 同上 37 | SLACK_SLASH_WEBHOOK # スラッシュコマンドの受け付けメッセージを送るための Incomming Webhook 38 | 39 | # 以下は回答リポジトリのリセットをする際に使う 40 | GH_TOKEN # GitHub API を実行したり、リポジトリを操作するための API トークン 41 | GH_USER # トークンのアカウント（リポジトリの操作で必要） 42 | ``` 43 | 44 | git-plantation-tool が利用する環境変数は下記の通り(用途は同じ): 45 | 46 | - `GH_TOKEN` 47 | - `GH_USER` 48 | - `GH_SECRET` 49 | - `APP_SERVER` は git-plantation-app が動作してる URL (例: `https://example.com`) で GitHub Webhook に設定する 50 | 51 | ### 3. Create team's repository in team 52 | 53 | using `git-plantation-tool`: 54 | 55 | ``` 56 | $ git-plantation-tool -c .git-plantation.yaml --work .temp repo new sample 57 | ``` 58 | 59 | ### 4. Run app 60 | 61 | ``` 62 | $ docker-compose up app store 63 | ``` 64 | 65 | ## Build with Docker 66 | 67 | ``` 68 | $ make image tag=matsubara0507/git-plantation:dev 69 | ``` 70 | -------------------------------------------------------------------------------- /config/docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '2' 2 | 3 | services: 4 | app: 5 | image: ghcr.io/matsubara0507/git-plantation:dev 6 | command: git-plantation-app --verbose -p 8080 --work=.temp config.yaml 7 | restart: always 8 | ports: 9 | - 8080:8080 10 | volumes: 11 | - ./.git-plantation.yaml:/work/config.yaml 12 | depends_on: 13 | - jobserver 14 | environment: 15 | - GH_TOKEN=${GH_TOKEN} 16 | - GH_SECRET=${GH_SECRET} 17 | - SLACK_SIGNING_SECRET=${SLACK_SIGNING_SECRET} 18 | - SLACK_VERIFY_TOKEN=${SLACK_VERIFY_TOKEN} 19 | - SLACK_SLASH_TEAM_ID=${SLACK_SLASH_TEAM_ID} 20 | - SLACK_SLASH_CHANNEL_IDS=${SLACK_SLASH_CHANNEL_IDS} 21 | - SLACK_SLASH_RESET_REPO_CMD=/reset-repo 22 | - SLACK_SLASH_WEBHOOK=${SLACK_SLASH_WEBHOOK} 23 | - SLACK_PUSH_NOTIFY_WEBHOOK=${SLACK_PUSH_NOTIFY_WEBHOOK} 24 | - JOBSERVER_HOST=http://jobserver 25 | - AUTHN_CLIENT_ID=${AUTHN_CLIENT_ID} 26 | - AUTHN_CLIENT_SECRET=${AUTHN_CLIENT_SECRET} 27 | 28 | jobserver: 29 | image: ghcr.io/matsubara0507/git-plantation:dev 30 | command: git-plantation-job-server --verbose -p 80 config.yaml 31 | restart: always 32 | ports: 33 | - 8090:80 34 | volumes: 35 | - ./.git-plantation.yaml:/work/config.yaml 36 | - ./temp.sqlite:/work/temp.sqlite 37 | environment: 38 | - SQLITE_PATH=./temp.sqlite 39 | - SLACK_API_TOKEN=${SLACK_API_TOKEN} 40 | - SLACK_NOTIFY_CHANNEL=${SLACK_NOTIFY_CHANNEL} 41 | 42 | jobrunner: 43 | image: ghcr.io/matsubara0507/git-plantation:dev 44 | command: git-plantation-job-runner --verbose jobserver:80 45 | restart: always 46 | deploy: 47 | replicas: 3 48 | depends_on: 49 | - jobserver 50 | volumes: 51 | - /var/run/docker.sock:/var/run/docker.sock 52 | -------------------------------------------------------------------------------- /elm-src/Pages/Team.elm: -------------------------------------------------------------------------------- 1 | module Pages.Team exposing (Model, Msg, init, update, view, viewFilters) 2 | 3 | import Generated.API as API exposing (..) 4 | import Html exposing (Html, a, div, text) 5 | import Html.Attributes exposing (class, href) 6 | import Pages.Board as Board 7 | import Pages.Graph as Graph 8 | import Score exposing (Score) 9 | 10 | 11 | type alias Model = 12 | { id : String, graph : Graph.Model } 13 | 14 | 15 | type alias Global a = 16 | { a 17 | | config : API.ScoreBoardConfig 18 | , problems : List API.Problem 19 | , scores : List Score 20 | } 21 | 22 | 23 | type alias Msg = 24 | Graph.Msg 25 | 26 | 27 | init : Global a -> String -> Model 28 | init global id = 29 | { id = id, graph = Graph.init global } 30 | 31 | 32 | update : Msg -> Model -> ( Model, Cmd Msg ) 33 | update msg model = 34 | let 35 | ( graph, newMsg ) = 36 | Graph.update msg model.graph 37 | in 38 | ( { model | graph = graph }, newMsg ) 39 | 40 | 41 | view : Global a -> Model -> Html Msg 42 | view global model = 43 | let 44 | filtered = 45 | { global | scores = Score.filterByTeamIDs [ model.id ] global.scores } 46 | in 47 | Html.div [] 48 | [ Board.view filtered 49 | , viewFilters filtered model 50 | , Graph.view filtered model.graph 51 | ] 52 | 53 | 54 | viewFilters : Global a -> Model -> Html msg 55 | viewFilters global model = 56 | let 57 | toTag sec idx = 58 | a [ href ("/" ++ sec ++ "/" ++ idx), class "branch-name" ] 59 | [ text (sec ++ ":" ++ idx) ] 60 | 61 | members = 62 | global.scores 63 | |> List.concatMap (\s -> s.team.member) 64 | |> List.map (\player -> toTag ("teams/" ++ model.id) player.github) 65 | in 66 | div [ class "m-3" ] (List.concat [ members ]) 67 | -------------------------------------------------------------------------------- /exec/tool/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Main where 5 | 6 | import Options 7 | import qualified Paths_git_plantation as Meta 8 | import RIO 9 | 10 | import Configuration.Dotenv (defaultConfig, loadFile) 11 | import Data.Extensible 12 | import Git.Plantation.Cmd as Cmd 13 | import Git.Plantation.Config (readConfig) 14 | import Git.Plantation.Env (mkWebhookConf) 15 | import Options.Applicative 16 | import System.Environment (getEnv) 17 | 18 | import qualified Mix 19 | import qualified Mix.Plugin.GitHub as MixGitHub 20 | import qualified Mix.Plugin.Logger as MixLogger 21 | import qualified Mix.Plugin.Shell as MixShell 22 | 23 | main :: IO () 24 | main = execParser parser >>= \opts -> do 25 | _ <- tryIO $ loadFile defaultConfig 26 | config <- readConfig (opts ^. #config) 27 | token <- liftIO $ fromString <$> getEnv "GH_TOKEN" 28 | ghUser <- liftIO $ fromString <$> getEnv "GH_USER" 29 | secret <- liftIO $ fromString <$> getEnv "GH_SECRET" 30 | appUrl <- liftIO $ fromString <$> getEnv "APP_SERVER" 31 | let logConf = #handle @= stdout <: #verbose @= (opts ^. #verbose) <: nil 32 | plugin = hsequence 33 | $ #config <@=> pure config 34 | <: #github <@=> MixGitHub.buildPlugin token 35 | <: #gh_user <@=> pure ghUser 36 | <: #work <@=> MixShell.buildPlugin (opts ^. #work) 37 | <: #webhook <@=> pure (mkWebhookConf (appUrl <> "/hook") secret) 38 | <: #logger <@=> MixLogger.buildPlugin logConf 39 | <: nil 40 | Mix.run plugin $ Cmd.run (opts ^. #subcmd) 41 | where 42 | parser = info (options <**> version Meta.version <**> helper) 43 | $ fullDesc 44 | <> header "git-plantation-tool - operate repository for git-plantation" 45 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Problem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Git.Plantation.Cmd.Problem 7 | ( ProblemCmdArg 8 | , ProblemArg 9 | , actForProblem 10 | , showProblem 11 | ) where 12 | 13 | import RIO 14 | 15 | import Data.Coerce (coerce) 16 | import Data.Extensible 17 | import Git.Plantation.Cmd.Arg 18 | import Git.Plantation.Cmd.Env (CmdEnv) 19 | import qualified Git.Plantation.Config as Config 20 | import Git.Plantation.Data.Problem 21 | import qualified Git.Plantation.Data.Problem as Problem 22 | import qualified Mix.Plugin.Logger.JSON as Mix 23 | 24 | type ProblemCmdArg = Record 25 | '[ "problems" >: [Problem.Id] 26 | ] 27 | 28 | type ProblemArg = Record 29 | '[ "problem" >: Problem 30 | ] 31 | 32 | actForProblem :: CmdEnv env => (ProblemArg -> RIO env ()) -> ProblemCmdArg -> RIO env () 33 | actForProblem act args = do 34 | problems <- findProblems $ args ^. #problems 35 | mapM_ act $ hsequence $ #problem <@=> problems <: nil 36 | 37 | findProblems :: CmdEnv env => [Problem.Id] -> RIO env [Problem] 38 | findProblems [] = do 39 | config <- Config.askConfig 40 | pure $ config ^. #problems 41 | findProblems ids = fmap catMaybes . forM ids $ \idx -> 42 | findByIdWith (view #problems) idx >>= \case 43 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo idx) >> pure Nothing 44 | Just r -> pure (Just r) 45 | 46 | showProblem :: CmdEnv env => ProblemArg -> RIO env () 47 | showProblem args = logInfo $ display $ mconcat 48 | [ "- ", tshow $ args ^. #problem ^. #id, ": " 49 | , coerce $ args ^. #problem ^. #name 50 | , "(⭐️ x", tshow $ args ^. #problem ^. #difficulty, ") at " 51 | , "https://github.com/", args ^. #problem ^. #repo 52 | ] 53 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Arg/Team.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Git.Plantation.Cmd.Arg.Team where 9 | 10 | import RIO 11 | import qualified RIO.List as L 12 | 13 | import Data.Aeson (ToJSON) 14 | import Data.Coerce (coerce) 15 | import Data.Extensible 16 | import Git.Plantation.Cmd.Arg.Internal 17 | import qualified Git.Plantation.Data.Problem as Problem 18 | import Git.Plantation.Data.Repo (Repo) 19 | import Git.Plantation.Data.Team (Team) 20 | import qualified Git.Plantation.Data.Team as Team 21 | import Git.Plantation.Data.User (User) 22 | import qualified Git.Plantation.Data.User as User 23 | 24 | instance IdArg Team.Id Team where 25 | findById idx = L.find (\t -> t ^. #id == coerce idx) 26 | toArgInfo idx 27 | = #type @= "Team" 28 | <: #id @= coerce idx 29 | <: nil 30 | 31 | newtype RepoId = RepoId Problem.Id 32 | deriving (Show, Read, Num, ToJSON) via Problem.Id 33 | 34 | instance IdArg RepoId Repo where 35 | findById idx = L.find (\r -> r ^. #problem == coerce idx) 36 | toArgInfo idx 37 | = #type @= "Repo" 38 | <: #id @= tshow idx 39 | <: nil 40 | 41 | instance IdArg User.GitHubId User where 42 | findById idx = L.find (\u -> u ^. #github == coerce idx) 43 | toArgInfo idx 44 | = #type @= "User" 45 | <: #id @= coerce idx 46 | <: nil 47 | 48 | newtype GitHubTeamName = GitHubTeamName Text 49 | deriving (IsString, ToJSON) via Text 50 | 51 | instance IdArg GitHubTeamName Text where 52 | findById idx = L.find (== coerce idx) 53 | toArgInfo idx 54 | = #type @= "GitHub Team" 55 | <: #id @= coerce idx 56 | <: nil 57 | -------------------------------------------------------------------------------- /src/Git/Plantation/Job/Docker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | 4 | module Git.Plantation.Job.Docker where 5 | 6 | import RIO 7 | import qualified RIO.Map as Map 8 | import RIO.Process 9 | import qualified RIO.Text as Text 10 | 11 | import Data.Coerce (coerce) 12 | import Git.Plantation.Data (Problem, Team) 13 | import qualified Git.Plantation.Data.Job as Job 14 | import qualified Git.Plantation.Data.Problem 15 | import qualified Git.Plantation.Data.Team 16 | import qualified Git.Plantation.Data.Team as Team 17 | 18 | run :: 19 | (HasProcessContext env, HasLogFunc env, MonadReader env m, MonadIO m, HasCallStack) 20 | => Job.Config 21 | -> [Text] 22 | -> m (ExitCode, LByteString, LByteString) 23 | run config cmd = do 24 | logDebug $ fromString ("docker " ++ unwords args) 25 | proc "docker" args readProcess 26 | where 27 | args = ["run", "--rm", "-e", "REPOSITORY", "-e", "PROBLEM", Text.unpack $ config ^. #image] ++ map Text.unpack cmd 28 | 29 | echo :: 30 | (HasProcessContext env, HasLogFunc env, MonadReader env m, MonadIO m, HasCallStack) 31 | => Job.Config 32 | -> Problem 33 | -> Team 34 | -> m (ExitCode, LByteString, LByteString) 35 | echo config problem team = run config ["/bin/bash", "-c", cmd] 36 | where 37 | cmd = "echo " <> coerce (team ^. #name) <> "/" <> coerce (problem ^. #name) 38 | 39 | testScript :: (HasProcessContext env, HasLogFunc env, MonadReader env m, MonadIO m, HasCallStack) 40 | => Job.Config 41 | -> Problem 42 | -> Team 43 | -> m (ExitCode, LByteString, LByteString) 44 | testScript config problem team = 45 | case Team.repoGithubPath =<< Team.lookupRepo problem team of 46 | Nothing -> 47 | pure (ExitFailure 1, "", "team repository is not found in config.") 48 | Just repo -> 49 | withModifyEnvVars (Map.insert "REPOSITORY" repo . Map.insert "PROBLEM" (coerce $ problem ^. #name)) $ run config [] 50 | -------------------------------------------------------------------------------- /src/Git/Plantation/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Git.Plantation.Config where 7 | 8 | import RIO 9 | 10 | import Data.Extensible 11 | import Data.Extensible.Elm.Mapping 12 | import qualified Data.Yaml as Y 13 | import Elm.Mapping 14 | import Git.Plantation.Data (GitHubId, Problem, Team, User) 15 | import qualified Mix.Plugin.Config as MixConfig 16 | import Orphans () 17 | 18 | type Config = Record 19 | '[ "scoreboard" >: ScoreBoardConfig 20 | , "problems" >: [Problem] 21 | , "teams" >: [Team] 22 | , "owners" >: [User] 23 | , "image" >: Text -- ToDo 24 | ] 25 | 26 | type ScoreBoardConfig = Record 27 | '[ "interval" >: Float 28 | , "start_time" >: Maybe Int64 -- unix time 29 | , "end_time" >: Maybe Int64 -- unix time 30 | , "zone" >: Maybe Text 31 | , "scoring" >: Maybe Bool 32 | ] 33 | 34 | askConfig :: MixConfig.HasConfig Config env => RIO env Config 35 | askConfig = MixConfig.askConfig 36 | 37 | readConfig :: MonadIO m => FilePath -> m Config 38 | readConfig = Y.decodeFileThrow 39 | 40 | mkAuthnWhitelist :: Config -> [GitHubId] 41 | mkAuthnWhitelist config = map (view #github) (config ^. #owners <> players) 42 | where 43 | players = concatMap (view #member) $ config ^. #teams 44 | 45 | instance IsElmType Config where 46 | compileElmType = compileElmRecordTypeWith "Config" 47 | 48 | instance IsElmDefinition Config where 49 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Config" 50 | 51 | instance IsElmType ScoreBoardConfig where 52 | compileElmType = compileElmRecordTypeWith "ScoreBoardConfig" 53 | 54 | instance IsElmDefinition ScoreBoardConfig where 55 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "ScoreBoardConfig" 56 | 57 | verify :: Config -> Either Text Config 58 | verify = pure 59 | -------------------------------------------------------------------------------- /exec/tool/SubCmd/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module SubCmd.Repo 7 | ( RepoCmd (..) 8 | ) where 9 | 10 | import RIO 11 | 12 | import Data.Extensible 13 | import Git.Plantation.Cmd 14 | 15 | newtype RepoCmd = RepoCmd (Variant CmdFields) 16 | 17 | type CmdFields = 18 | '[ "new" >: (RepoCmdArg, NewRepoFlags) 19 | , "new_github" >: RepoCmdArg 20 | , "init_github" >: RepoCmdArg 21 | , "setup_default_branch" >: RepoCmdArg 22 | , "setup_webhook" >: RepoCmdArg 23 | , "init_ci" >: RepoCmdArg 24 | , "reset" >: RepoCmdArg 25 | , "delete" >: RepoCmdArg 26 | , "add_gh_team" >: RepoCmdArg 27 | ] 28 | 29 | instance Run ("new" >: (RepoCmdArg, NewRepoFlags)) where 30 | run' _ (args, flags) = 31 | actForRepo (createRepo flags) args `catchAny` (logError . displayShow) 32 | 33 | instance Run ("new_github" >: RepoCmdArg) where 34 | run' _ args = 35 | actForRepo createRepoInGitHub args `catchAny` (logError . displayShow) 36 | 37 | instance Run ("init_github" >: RepoCmdArg) where 38 | run' _ args = 39 | actForRepo initRepoInGitHub args `catchAny` (logError . displayShow) 40 | 41 | instance Run ("setup_default_branch" >: RepoCmdArg) where 42 | run' _ args = 43 | actForRepo setupDefaultBranch args `catchAny` (logError . displayShow) 44 | 45 | instance Run ("setup_webhook" >: RepoCmdArg) where 46 | run' _ args = 47 | actForRepo setupWebhook args `catchAny` (logError . displayShow) 48 | 49 | instance Run ("init_ci" >: RepoCmdArg) where 50 | run' _ args = 51 | actForRepo initProblemCI args `catchAny` (logError . displayShow) 52 | 53 | instance Run ("reset" >: RepoCmdArg) where 54 | run' _ args = 55 | actForRepo resetRepo args `catchAny` (logError . displayShow) 56 | 57 | instance Run ("delete" >: RepoCmdArg) where 58 | run' _ args = 59 | actForRepo deleteRepo args `catchAny` (logError . displayShow) 60 | 61 | instance Run ("add_gh_team" >: RepoCmdArg) where 62 | run' _ args = 63 | actForRepo addGitHubTeam args `catchAny` (logError . displayShow) 64 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: 4 | pull_request: null 5 | push: 6 | branches: 7 | - master 8 | tags: 9 | - v* 10 | 11 | jobs: 12 | build: 13 | runs-on: ubuntu-22.04 14 | strategy: 15 | matrix: 16 | ghc: ["9.4.4"] 17 | 18 | steps: 19 | - uses: actions/checkout@v2 20 | with: 21 | submodules: recursive 22 | 23 | - name: Cache .stack 24 | id: cache-stack 25 | uses: actions/cache@v3 26 | with: 27 | path: ~/.stack 28 | key: "\ 29 | ${{ runner.os }}-stack\ 30 | -${{ hashFiles('**/stack.yaml.lock') }}\ 31 | -${{ hashFiles('**/package.yaml') }}\ 32 | " 33 | restore-keys: | 34 | ${{ runner.os }}-stack- 35 | - uses: haskell/actions/setup@v2 36 | name: Setup Haskell 37 | with: 38 | ghc-version: ${{ matrix.ghc }} 39 | enable-stack: true 40 | stack-version: 'latest' 41 | 42 | - name: Install dependencies 43 | run: stack --system-ghc test --only-dependencies 44 | 45 | - name: Build and Test 46 | run: stack --system-ghc test --local-bin-path=./bin 47 | 48 | # Build and Push Docker Image 49 | - name: Prepare 50 | id: prep 51 | run: | 52 | DOCKER_IMAGE=ghcr.io/matsubara0507/git-plantation 53 | TAGS="${DOCKER_IMAGE}:latest" 54 | if [[ $GITHUB_REF == refs/tags/* ]]; then 55 | TAGS="$TAGS,${DOCKER_IMAGE}:${GITHUB_REF#refs/tags/}" 56 | fi 57 | echo ::set-output name=tags::${TAGS} 58 | - name: Setup QEMU 59 | uses: docker/setup-qemu-action@v2 60 | - name: Setup Docker Buildx 61 | id: buildx 62 | uses: docker/setup-buildx-action@v2 63 | 64 | - name: Login to GitHub Container Registry 65 | uses: docker/login-action@v2 66 | with: 67 | registry: ghcr.io 68 | username: matsubara0507 69 | password: ${{ secrets.GITHUB_TOKEN }} 70 | 71 | - name: Build and push 72 | uses: docker/build-push-action@v4 73 | with: 74 | context: . 75 | builder: ${{ steps.buildx.outputs.name }} 76 | tags: ${{ steps.prep.outputs.tags }} 77 | push: ${{ github.event_name != 'pull_request' }} 78 | build-args: local_bin_path=./bin 79 | -------------------------------------------------------------------------------- /exec/jobrunner/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Main where 9 | 10 | import Paths_git_plantation (version) 11 | import RIO 12 | import qualified RIO.ByteString as B 13 | import RIO.Process (mkDefaultProcessContext) 14 | 15 | import Configuration.Dotenv (defaultConfig, loadFile) 16 | import Data.Extensible 17 | import Data.Extensible.GetOpt 18 | import Data.Version (Version) 19 | import qualified Data.Version as Version 20 | import Development.GitRev 21 | import Git.Plantation.Data.Job as Job 22 | import Git.Plantation.Job.Client as Client 23 | import qualified Mix 24 | import qualified Mix.Plugin.Logger as MixLogger 25 | 26 | import Orphans () 27 | 28 | 29 | main :: IO () 30 | main = withGetOpt "[options] DESTINATION" opts $ \r args -> do 31 | _ <- tryIO $ loadFile defaultConfig 32 | case (r ^. #version, listToMaybe args) of 33 | (True, _) -> B.putStr $ fromString (showVersion version) <> "\n" 34 | (_, Nothing) -> error "please input DESTINATION" 35 | (_, Just dest) -> runClient r dest 36 | where 37 | opts = #verbose @= verboseOpt 38 | <: #version @= versionOpt 39 | <: nil 40 | 41 | type Options = Record 42 | '[ "verbose" >: Bool 43 | , "version" >: Bool 44 | ] 45 | 46 | verboseOpt :: OptDescr' Bool 47 | verboseOpt = optFlag ['v'] ["verbose"] "Enable verbose mode: verbosity level \"debug\"" 48 | 49 | versionOpt :: OptDescr' Bool 50 | versionOpt = optFlag [] ["version"] "Show version" 51 | 52 | runClient :: Options -> String -> IO () 53 | runClient opts dest = 54 | let logConf = #handle @= stdout <: #verbose @= (opts ^. #verbose) <: nil 55 | plugin = hsequence 56 | $ #logger <@=> MixLogger.buildPlugin logConf 57 | <: #processContext <@=> mkDefaultProcessContext 58 | <: #config 　<@=> newTVarIO Job.emptyConfig 59 | <: #queue <@=> newTQueueIO 60 | <: nil 61 | in Mix.run plugin $ Client.run dest 62 | 63 | showVersion :: Version -> String 64 | showVersion v = unwords 65 | [ "Version" 66 | , Version.showVersion v ++ "," 67 | , "Git revision" 68 | , $(gitHash) 69 | , "(" ++ $(gitCommitCount) ++ " commits)" 70 | ] 71 | -------------------------------------------------------------------------------- /test/spec/Spec/Git/Plantation/Score.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} 3 | 4 | module Spec.Git.Plantation.Score (spec) where 5 | 6 | import RIO hiding (link2) 7 | 8 | import Data.Extensible 9 | import qualified Fixture 10 | import Git.Plantation.Data.Job (Job) 11 | import Git.Plantation.Score (mkScore) 12 | import Test.Hspec 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "mkScore" $ do 17 | it "should make Score" $ do 18 | let [team] = Fixture.config ^. #teams 19 | stat1 = #problem_id @= 1 20 | <: #correct @= True 21 | <: #pending @= False 22 | <: #corrected_at @= Just 1560000000 23 | <: #answerer @= Just "matsubara0507" 24 | <: nil 25 | stat2 = #problem_id @= 2 26 | <: #correct @= False 27 | <: #pending @= True 28 | <: #corrected_at @= Nothing 29 | <: #answerer @= Just "matsubara0507" 30 | <: nil 31 | link1 = #problem_id @= 1 32 | <: #url @= "https://github.com/sample-hige/git-challenge-tutorial" 33 | <: nil 34 | link2 = #problem_id @= 2 35 | <: #url @= "https://github.com/sample-hige/git-challenge-is-order-an-adding" 36 | <: nil 37 | link3 = #problem_id @= 3 38 | <: #url @= "https://github.com/sample-hige/git-challenge-minesweeper" 39 | <: nil 40 | expect = #team @= "alpha" 41 | <: #point @= 1 42 | <: #stats @= [stat1, stat2] 43 | <: #links @= [link1, link2, link3] 44 | <: nil 45 | mkScore (Fixture.config ^. #problems) team [job1, job2] `shouldBe` expect 46 | 47 | job1, job2 :: Job 48 | job1 49 | = #id @= 1 50 | <: #problem @= 1 51 | <: #team @= "alpha" 52 | <: #author @= Just "matsubara0507" 53 | <: #queuing @= False 54 | <: #running @= False 55 | <: #success @= True 56 | <: #stdout @= "" 57 | <: #stderr @= "" 58 | <: #created @= 1560000000 59 | <: nil 60 | job2 61 | = #id @= 2 62 | <: #problem @= 2 63 | <: #team @= "alpha" 64 | <: #author @= Just "matsubara0507" 65 | <: #queuing @= False 66 | <: #running @= True 67 | <: #success @= False 68 | <: #stdout @= "" 69 | <: #stderr @= "" 70 | <: #created @= 1560000000 71 | <: nil 72 | -------------------------------------------------------------------------------- /src/Git/Plantation/Job/Protocol.hs: -------------------------------------------------------------------------------- 1 | module Git.Plantation.Job.Protocol where 2 | 3 | import RIO 4 | import qualified RIO.ByteString.Lazy as BL 5 | 6 | import qualified Data.Aeson as JSON 7 | import qualified Data.Binary as Binary 8 | import qualified Git.Plantation.Data.Job as Job 9 | import qualified Git.Plantation.Data.Problem as Problem 10 | import qualified Git.Plantation.Data.Team as Team 11 | import qualified Git.Plantation.Data.User as User 12 | import qualified Network.WebSockets as WS 13 | 14 | -- | protocol from Server to Client 15 | data Server 16 | = JobConfig Job.Config 17 | | Enqueue Job.Id Problem.Id Team.Id (Maybe User.GitHubId) 18 | | SUndefined 19 | 20 | instance WS.WebSocketsData Server where 21 | fromDataMessage (WS.Text bl _) = WS.fromLazyByteString bl 22 | fromDataMessage (WS.Binary bl) = WS.fromLazyByteString bl 23 | 24 | fromLazyByteString lbs = case BL.uncons lbs of 25 | Just (1, rest) -> 26 | maybe 27 | SUndefined 28 | JobConfig 29 | (JSON.decode rest) 30 | 31 | Just (2, rest) -> 32 | let (jid, pid, tid, uid) = Binary.decode rest 33 | in Enqueue jid pid tid uid 34 | 35 | _ -> 36 | SUndefined 37 | 38 | toLazyByteString p = case p of 39 | JobConfig configs -> 40 | BL.cons 1 (JSON.encode configs) 41 | 42 | Enqueue jid pid tid uid -> 43 | BL.cons 2 (Binary.encode (jid, pid, tid, uid)) 44 | 45 | SUndefined -> 46 | "" 47 | 48 | -- | protocol from Client to Server 49 | data Client 50 | = JobRunning Job.Id 51 | | JobSuccess Job.Id ByteString ByteString 52 | | JobFailure Job.Id ByteString ByteString 53 | | CUndefined 54 | 55 | instance WS.WebSocketsData Client where 56 | fromDataMessage (WS.Text bl _) = WS.fromLazyByteString bl 57 | fromDataMessage (WS.Binary bl) = WS.fromLazyByteString bl 58 | 59 | fromLazyByteString lbs = case BL.uncons lbs of 60 | Just (1, rest) -> 61 | JobRunning (Binary.decode rest) 62 | 63 | Just (2, rest) -> 64 | let (jid, out, err) = Binary.decode rest 65 | in JobSuccess jid out err 66 | 67 | Just (3, rest) -> 68 | let (jid, out, err) = Binary.decode rest 69 | in JobFailure jid out err 70 | 71 | _ -> 72 | CUndefined 73 | 74 | toLazyByteString p = case p of 75 | JobRunning jid -> 76 | BL.cons 1 $ Binary.encode jid 77 | 78 | JobSuccess jid out err -> 79 | BL.cons 2 $ Binary.encode (jid, out, err) 80 | 81 | JobFailure jid out err -> 82 | BL.cons 3 $ Binary.encode (jid, out, err) 83 | 84 | CUndefined -> 85 | "" 86 | -------------------------------------------------------------------------------- /src/Git/Plantation/Job/Worker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 9 | 10 | module Git.Plantation.Job.Worker where 11 | 12 | import RIO 13 | import RIO.List.Partial ((!!)) 14 | import qualified RIO.Map as Map 15 | 16 | import Data.Aeson (FromJSON, ToJSON) 17 | import Data.Binary (Binary) 18 | import Data.Extensible 19 | import qualified Network.WebSockets as WS 20 | import System.Random (randomRIO) 21 | 22 | newtype Id = Id Int32 23 | deriving newtype (Show, Eq, Ord, Num, Binary, FromJSON, ToJSON, Display) 24 | 25 | type Worker = Record 26 | '[ "id" >: Id 27 | , "working" >: Bool 28 | , "conn" >: WS.Connection 29 | ] 30 | 31 | new :: Id -> WS.Connection -> Worker 32 | new wid conn 33 | = #id @= wid 34 | <: #working @= False 35 | <: #conn @= conn 36 | <: nil 37 | 38 | work, finish :: Worker -> Worker 39 | work w = w & #working `set` True 40 | finish w = w & #working `set` False 41 | 42 | type Info = Record 43 | '[ "id" >: Id 44 | , "working" >: Bool 45 | ] 46 | 47 | type Workers = TVar (Map Id (Maybe Worker)) 48 | 49 | newWorkers :: MonadIO m => m Workers 50 | newWorkers = newTVarIO mempty 51 | 52 | class HasWorkers env where 53 | workersL :: Lens' env Workers 54 | 55 | instance Lookup xs "workers" Workers => HasWorkers (Record xs) where 56 | workersL = lens (view #workers) (\x y -> x & #workers `set` y) 57 | 58 | askWorkers :: HasWorkers env => RIO env Workers 59 | askWorkers = view workersL 60 | 61 | getAllConnected :: HasWorkers env => RIO env [Worker] 62 | getAllConnected = fmap (catMaybes . Map.elems) $ readTVarIO =<< askWorkers 63 | 64 | getRandom :: HasWorkers env => RIO env (Maybe Worker) 65 | getRandom = do 66 | workers <- getAllConnected 67 | case workers of 68 | [] -> 69 | pure Nothing 70 | _ -> do 71 | idx <- (\x -> x - 1) <$> randomRIO (1, length workers) 72 | pure $ Just (workers !! idx) 73 | 74 | connected :: HasWorkers env => WS.Connection -> RIO env Worker 75 | connected conn = do 76 | workers <- askWorkers 77 | atomically $ do 78 | maxId <- Map.size <$> readTVar workers 79 | let worker = new (fromIntegral $ maxId + 1) conn 80 | modifyTVar workers (Map.insert (worker ^. #id) $ Just worker) 81 | pure worker 82 | 83 | disconnected :: HasWorkers env => Id -> RIO env () 84 | disconnected wid = do 85 | workers <- askWorkers 86 | atomically $ modifyTVar workers (Map.update (\_ -> Just Nothing) wid) 87 | 88 | 89 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Org.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Git.Plantation.Cmd.Org 8 | ( OrgCmdArg 9 | , GitHubTeamArg 10 | , actForGitHubTeam 11 | , createGitHubTeam 12 | ) where 13 | 14 | import RIO 15 | 16 | import Data.Extensible 17 | import Git.Plantation.Cmd.Arg 18 | import Git.Plantation.Cmd.Env (CmdEnv) 19 | import Git.Plantation.Data.Team 20 | import qualified Git.Plantation.Data.Team as Team 21 | import Git.Plantation.Env 22 | import GitHub.Data.Name (mkName) 23 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 24 | import qualified Mix.Plugin.GitHub as MixGitHub 25 | import qualified Mix.Plugin.Logger.JSON as Mix 26 | 27 | type OrgCmdArg = Record 28 | '[ "team" >: Team.Id 29 | , "gh_teams" >: [GitHubTeamName] 30 | ] 31 | 32 | type GitHubTeamArg = Record 33 | '[ "team" >: Team 34 | , "org" >: Text 35 | , "gh_team" >: Text 36 | ] 37 | 38 | actForGitHubTeam :: CmdEnv env => (GitHubTeamArg -> RIO env ()) -> OrgCmdArg -> RIO env () 39 | actForGitHubTeam act args = 40 | findByIdWith (view #teams) (args ^. #team) >>= \case 41 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo $ args ^. #team) 42 | Just team -> do 43 | (org, ghTeams) <- findGitHubTeams (args ^. #gh_teams) team 44 | mapM_ act $ hsequence $ #team <@=> [team] <: #org <@=> org <: #gh_team <@=> ghTeams <: nil 45 | 46 | findGitHubTeams :: CmdEnv env => [GitHubTeamName] -> Team -> RIO env ([Text], [Text]) 47 | findGitHubTeams ids team = case (team ^. #org, ids) of 48 | (Nothing, _) -> logError "Undefined GitHub org on team config." >> pure ([],[]) 49 | (Just org, []) -> pure ([org], team ^. #gh_teams) 50 | (Just org, _) -> ([org],) <$> findGitHubTeams' 51 | where 52 | findGitHubTeams' = fmap catMaybes . forM ids $ \idx -> 53 | case findById idx (team ^. #gh_teams) of 54 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo idx) >> pure Nothing 55 | Just t -> pure (Just t) 56 | 57 | createGitHubTeam :: CmdEnv env => GitHubTeamArg -> RIO env () 58 | createGitHubTeam args = do 59 | resp <- MixGitHub.fetch $ GitHub.createTeamForR 60 | (mkName Proxy $ args ^. #org) 61 | (GitHub.CreateTeam (mkName Proxy $ args ^. #gh_team) Nothing mempty GitHub.PrivacyClosed GitHub.PermissionPush) 62 | case resp of 63 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 64 | Right _ -> logInfo $ display success 65 | where 66 | failure err = CreateGitHubTeamError err (args ^. #team) (args ^. #gh_team) 67 | success = mconcat 68 | [ "Success: create GitHub team: ", args ^. #org, ":", args ^. #gh_team ] 69 | -------------------------------------------------------------------------------- /src/Git/Plantation/API/CRUD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Git.Plantation.API.CRUD where 7 | 8 | import RIO 9 | import qualified RIO.List as L 10 | 11 | import qualified Git.Plantation.API.Job as Job 12 | import Git.Plantation.Data (Problem, Team) 13 | import qualified Git.Plantation.Data.Team as Team 14 | import qualified Git.Plantation.Data.User as User 15 | import Git.Plantation.Env (Plant) 16 | import Git.Plantation.Score (Score, mkPlayerScore, mkScore) 17 | import Servant 18 | 19 | type GetAPI 20 | = "teams" :> Get '[JSON] [Team] 21 | :<|> "problems" :> Get '[JSON] [Problem] 22 | :<|> "scores" :> Get '[JSON] [Score] 23 | :<|> "scores" :> Capture "team" Team.Id :> Get '[JSON] [Score] 24 | :<|> "scores" :> Capture "team" Team.Id :> Capture "player" User.GitHubId :> Get '[JSON] [Score] 25 | 26 | getAPI :: ServerT GetAPI Plant 27 | getAPI = getTeams 28 | :<|> getProblems 29 | :<|> getScores 30 | :<|> getTeamScore 31 | :<|> getPlayerScore 32 | 33 | getTeams :: Plant [Team] 34 | getTeams = do 35 | logInfo "[GET] /teams" 36 | asks (view #teams . view #config) 37 | 38 | getProblems :: Plant [Problem] 39 | getProblems = do 40 | logInfo "[GET] /problems" 41 | asks (view #problems . view #config) 42 | 43 | getScores :: Plant [Score] 44 | getScores = do 45 | logInfo "[GET] /scores" 46 | host <- asks (view #jobserver) 47 | jobs <- tryAny (Job.fetchJobs host) >>= \case 48 | Left err -> logError (displayShow err) >> pure mempty 49 | Right x -> pure x 50 | config <- asks (view #config) 51 | pure $ map (flip (mkScore $ config ^. #problems) jobs) (config ^. #teams) 52 | 53 | getTeamScore :: Team.Id -> Plant [Score] 54 | getTeamScore teamID = do 55 | logInfo $ "[GET] /scores/" <> display teamID 56 | host <- asks (view #jobserver) 57 | jobs <- tryAny (Job.fetchJobs host) >>= \case 58 | Left err -> logError (displayShow err) >> pure mempty 59 | Right x -> pure x 60 | config <- asks (view #config) 61 | teams <- case L.find (\team -> team ^. #id == teamID) (config ^. #teams) of 62 | Nothing -> logError "team not found." >> pure mempty 63 | Just team -> pure [team] 64 | pure $ map (flip (mkScore $ config ^. #problems) jobs) teams 65 | 66 | getPlayerScore :: Team.Id -> User.GitHubId -> Plant [Score] 67 | getPlayerScore teamID userID = do 68 | logInfo $ "[GET] /scores/" <> display teamID <> "/" <> display userID 69 | host <- asks (view #jobserver) 70 | jobs <- tryAny (Job.fetchJobs host) >>= \case 71 | Left err -> logError (displayShow err) >> pure mempty 72 | Right x -> pure x 73 | config <- asks (view #config) 74 | teams <- case L.find (\team -> team ^. #id == teamID) (config ^. #teams) of 75 | Nothing -> logError "team not found." >> pure mempty 76 | Just team -> pure [team] 77 | pure . catMaybes $ 78 | liftA2 fmap (\t u -> mkPlayerScore (config ^. #problems) t u jobs) (Team.lookupUser userID) <$> teams 79 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: git-plantation 2 | version: 0.5.0 3 | github: "matsubara0507/git-plantation" 4 | license: MIT 5 | author: "MATSUBARA Nobutada" 6 | maintainer: "t12307043@gunma-u.ac.jp" 7 | copyright: "2018 MATSUBARA Nobutada" 8 | 9 | extra-source-files: 10 | - README.md 11 | - CHANGELOG.md 12 | 13 | description: Please see the README on GitHub at 14 | 15 | ghc-options: 16 | - -Wall 17 | - -Wcompat 18 | - -Wincomplete-record-updates 19 | - -Wincomplete-uni-patterns 20 | - -Wredundant-constraints 21 | 22 | default-extensions: 23 | - NoImplicitPrelude 24 | - GHC2021 25 | 26 | - ConstraintKinds 27 | - FlexibleContexts 28 | - FlexibleInstances 29 | - GeneralizedNewtypeDeriving 30 | - OverloadedStrings 31 | - PolyKinds 32 | - RankNTypes 33 | - StandaloneDeriving 34 | - TypeFamilies 35 | - TypeSynonymInstances 36 | 37 | dependencies: 38 | - base >= 4.7 && < 5 39 | - rio >= 0.1.1.0 40 | - mix 41 | - mix-json-logger 42 | - mix-plugin-github 43 | - mix-plugin-persistent-sqlite 44 | - mix-plugin-shell 45 | - mtl 46 | - aeson 47 | - binary 48 | - blaze-html 49 | - containers 50 | - cryptonite 51 | - dotenv 52 | - elmap 53 | - esqueleto 54 | - extensible >= 0.6 55 | - extensible-elmap 56 | - exceptions 57 | - fallible 58 | - github 59 | - github-webhooks >= 0.17.0 60 | - http-media 61 | - persistent 62 | - persistent-template 63 | - random 64 | - req >= 2.0 65 | - servant-auth-server 66 | - servant-blaze 67 | - servant-elmap 68 | - servant-github-webhook 69 | - servant-server 70 | - yaml >= 0.8.31 71 | - http-api-data 72 | - unliftio 73 | - websockets 74 | - wreq 75 | - shelly 76 | - time 77 | - template-haskell 78 | - memory 79 | - servant 80 | 81 | library: 82 | source-dirs: src 83 | 84 | executables: 85 | git-plantation-app: 86 | main: Main.hs 87 | source-dirs: exec/app 88 | dependencies: 89 | - git-plantation 90 | - gitrev 91 | - warp 92 | git-plantation-job-server: 93 | main: Main.hs 94 | source-dirs: exec/jobserver 95 | dependencies: 96 | - git-plantation 97 | - gitrev 98 | - wai-websockets 99 | - warp 100 | git-plantation-job-runner: 101 | main: Main.hs 102 | source-dirs: exec/jobrunner 103 | dependencies: 104 | - git-plantation 105 | - gitrev 106 | git-plantation-tool: 107 | main: Main.hs 108 | source-dirs: exec/tool 109 | dependencies: 110 | - git-plantation 111 | - gitrev 112 | - optparse-applicative 113 | 114 | tests: 115 | spec: 116 | main: Spec.hs 117 | source-dirs: test/spec 118 | dependencies: 119 | - git-plantation 120 | - tasty 121 | - tasty-hspec 122 | - th-lift-instances 123 | - hspec 124 | generateElm: 125 | main: GenerateElm.hs 126 | source-dirs: test 127 | dependencies: 128 | - git-plantation 129 | other-modules: [] 130 | -------------------------------------------------------------------------------- /elm-src/Pages/Board.elm: -------------------------------------------------------------------------------- 1 | module Pages.Board exposing (view) 2 | 3 | import Generated.API as API exposing (..) 4 | import Html exposing (..) 5 | import Html.Attributes exposing (class, href, id, style, target) 6 | import Score exposing (Score) 7 | 8 | 9 | type alias Model a = 10 | { a 11 | | problems : List API.Problem 12 | , scores : List Score 13 | } 14 | 15 | 16 | view : Model a -> Html msg 17 | view model = 18 | div [ id "scoreboard" ] 19 | [ table 20 | [ class "scoreboard-table col-12 f5 break-word", style "table-layout" "fixed" ] 21 | [ thead [] [ tr [ class "border-bottum" ] (viewHeader model) ] 22 | , tbody [] (viewBody model) 23 | ] 24 | ] 25 | 26 | 27 | viewHeader : Model a -> List (Html msg) 28 | viewHeader model = 29 | List.concat 30 | [ [ th [] [] ] 31 | , List.map viewHeaderCol model.problems 32 | , [ th [ class "text-center p-2 f6" ] [ text "Score" ] ] 33 | ] 34 | 35 | 36 | viewHeaderCol : API.Problem -> Html msg 37 | viewHeaderCol problem = 38 | th 39 | [ id problem.name, class "text-center p-2 f6" ] 40 | [ text problem.name ] 41 | 42 | 43 | viewBody : Model a -> List (Html msg) 44 | viewBody model = 45 | List.indexedMap viewScore model.scores 46 | 47 | 48 | viewScore : Int -> Score -> Html msg 49 | viewScore idx score = 50 | tr 51 | [ class "border-top" 52 | , class 53 | (if modBy 2 idx == 0 then 54 | "bg-gray-light" 55 | 56 | else 57 | "" 58 | ) 59 | ] 60 | (List.concat 61 | [ [ th [ class "text-right p-2 f" ] 62 | [ a [ class "link-gray-dark", href ("/teams/" ++ score.team.id) ] 63 | [ text score.team.name ] 64 | ] 65 | ] 66 | , List.map viewStatus score.stats 67 | , [ th [ class "text-center p-2 f6" ] [ text (String.fromInt score.point) ] ] 68 | ] 69 | ) 70 | 71 | 72 | viewStatus : Score.Status -> Html msg 73 | viewStatus status = 74 | th 75 | [ class "text-center p-2" ] 76 | [ a [ href status.url, target "_blank" ] [ statBadge status.state ] 77 | , div [] [ stars status.difficulty ] 78 | ] 79 | 80 | 81 | statBadge : Score.State -> Html msg 82 | statBadge state = 83 | case state of 84 | Score.None -> 85 | span [ class "State State--small" ] [ text "未提出" ] 86 | 87 | Score.Pending -> 88 | span [ class "State State--small bg-yellow" ] [ text "採点中" ] 89 | 90 | Score.Incorrect -> 91 | span [ class "State State--small bg-red" ] [ text "不正解" ] 92 | 93 | Score.Correct -> 94 | span [ class "State State--small bg-green" ] [ text "正解" ] 95 | 96 | 97 | stars : Int -> Html msg 98 | stars n = 99 | let 100 | star = 101 | i [ class "fas fa-star" ] [] 102 | in 103 | if n < 4 then 104 | div [ class "f6" ] (List.repeat n star) 105 | 106 | else 107 | div [ class "f6" ] [ star, text ("x" ++ String.fromInt n) ] 108 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/Team.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Git.Plantation.Data.Team where 9 | 10 | import RIO 11 | import qualified RIO.List as L 12 | 13 | import Data.Aeson (FromJSON, ToJSON) 14 | import Data.Binary (Binary) 15 | import Data.Coerce (coerce) 16 | import Data.Extensible 17 | import Data.Extensible.Elm.Mapping 18 | import Elm.Mapping 19 | import Git.Plantation.Data.Problem (Problem) 20 | import qualified Git.Plantation.Data.Problem as Problem 21 | import Git.Plantation.Data.Repo (Repo) 22 | import qualified Git.Plantation.Data.Repo as Repo 23 | import Git.Plantation.Data.User (GitHubId, User) 24 | import Language.Haskell.TH.Syntax (Lift) 25 | import Web.HttpApiData (FromHttpApiData) 26 | 27 | newtype Id = Id Text 28 | deriving newtype (Show, Eq, Ord, IsString, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 29 | deriving (Lift) 30 | 31 | newtype Name = Name Text 32 | deriving newtype (Show, Eq, Ord, IsString, Binary, FromJSON, ToJSON, FromHttpApiData, Display, IsElmType) 33 | deriving (Lift) 34 | 35 | type Team = Record 36 | '[ "id" >: Id 37 | , "name" >: Name 38 | , "repos" >: [Repo] 39 | , "member" >: [User] 40 | , "org" >: Maybe Text 41 | , "gh_teams" >: [Text] 42 | ] 43 | 44 | instance IsElmType Team where 45 | compileElmType = compileElmRecordTypeWith "Team" 46 | 47 | instance IsElmDefinition Team where 48 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Team" 49 | 50 | data MemberTarget 51 | = TargetRepo Repo 52 | | TargetOrg Text 53 | | TargetTeam Text Text 54 | deriving (Show, Eq) 55 | 56 | toMemberTargetRecord :: MemberTarget -> Record '[ "type" >: Text, "target" >: Maybe Text ] 57 | toMemberTargetRecord target = case target of 58 | TargetRepo repo -> #type @= "repo" <: #target @= repoGithubPath repo <: nil 59 | TargetOrg org -> #type @= "org" <: #target @= Just org <: emptyRecord 60 | TargetTeam org team -> #type @= "team" <: #target @= Just (org <> ":" <> team) <: nil 61 | 62 | lookupRepo :: Problem -> Team -> Maybe Repo 63 | lookupRepo problem = lookupRepoByProblemId (problem ^. #id) 64 | 65 | lookupRepoByProblemId :: Problem.Id -> Team -> Maybe Repo 66 | lookupRepoByProblemId pid team = 67 | L.find (\repo -> repo ^. #problem == pid) (team ^. #repos) 68 | 69 | lookupRepoByGithub :: Text -> Team -> Maybe Repo 70 | lookupRepoByGithub github team = 71 | L.find (\repo -> repoGithubPath repo == Just github) (team ^. #repos) 72 | 73 | lookupUser :: GitHubId -> Team -> Maybe User 74 | lookupUser github team = 75 | L.find (\user -> github == user ^. #github) (team ^. #member) 76 | 77 | repoGithubPath :: Repo -> Maybe Text 78 | repoGithubPath repo = case (repo ^. #owner, repo ^. #org) of 79 | (Just owner, _) -> Just $ owner <> "/" <> coerce (repo ^. #name) 80 | (_, Just org) -> Just $ org <> "/" <> coerce (repo ^. #name) 81 | _ -> Nothing 82 | 83 | repoIsOrg :: Repo -> Bool 84 | repoIsOrg repo = isJust $ repo ^. #org 85 | -------------------------------------------------------------------------------- /src/Git/Plantation/API/GitHub.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Git.Plantation.API.GitHub 7 | ( WebhookAPI 8 | , webhook 9 | ) where 10 | 11 | import RIO 12 | import qualified RIO.List as L 13 | 14 | import Data.Coerce (coerce) 15 | import qualified Git.Plantation.API.Job as Job 16 | import Git.Plantation.Data (Problem, Team, User) 17 | import qualified Git.Plantation.Data.Problem as Problem 18 | import qualified Git.Plantation.Data.Slack as Slack 19 | import qualified Git.Plantation.Data.Team as Team 20 | import qualified Git.Plantation.Data.User as User 21 | import Git.Plantation.Env (Plant) 22 | import GitHub.Data.Webhooks.Events 23 | import GitHub.Data.Webhooks.Payload 24 | import Servant 25 | import Servant.GitHub.Webhook 26 | import UnliftIO.Concurrent (forkIO) 27 | 28 | type WebhookAPI 29 | = GitHubEvent '[ 'WebhookPingEvent ] :> GitHubSignedReqBody '[JSON] PublicEvent :> Post '[JSON] NoContent 30 | :<|> GitHubEvent '[ 'WebhookPushEvent ] :> GitHubSignedReqBody '[JSON] PushEvent :> Post '[JSON] NoContent 31 | 32 | webhook :: ServerT WebhookAPI Plant 33 | webhook = 34 | pingWebhook :<|> pushWebhook 35 | 36 | pingWebhook :: RepoWebhookEvent -> ((), PublicEvent) -> Plant NoContent 37 | pingWebhook _ (_, ev) = do 38 | logInfo $ "Hook Ping Event: " <> displayShow ev 39 | pure NoContent 40 | 41 | pushWebhook :: RepoWebhookEvent -> ((), PushEvent) -> Plant NoContent 42 | pushWebhook _ (_, ev) = do 43 | logInfo $ "Hook Push Event: " <> displayShow ev 44 | config <- asks (view #config) 45 | when (fromMaybe True $ config ^. #scoreboard ^. #scoring) $ do 46 | _ <- forkIO $ 47 | case findByPushEvent ev (config ^. #teams) (config ^. #problems) of 48 | Just (team, problem) -> startScoring ev team problem 49 | Nothing -> logError "team or problem is not found." 50 | pure () 51 | pure NoContent 52 | 53 | findByPushEvent :: PushEvent -> [Team] -> [Problem] -> Maybe (Team, Problem) 54 | findByPushEvent ev teams problems = do 55 | (team, repo) <- join $ L.find isJust repos 56 | problem <- L.find (\p -> p ^. #id == repo ^. #problem) problems 57 | if evPushRef ev == "refs/heads/" <> problem ^. #answer_branch then 58 | pure (team, problem) 59 | else 60 | Nothing 61 | where 62 | repos = map (\t -> (t,) <$> Team.lookupRepoByGithub repoName t) teams 63 | repoName = whRepoFullName $ evPushRepository ev 64 | 65 | startScoring :: PushEvent -> Team -> Problem -> Plant () 66 | startScoring ev team problem = 67 | case evPushSender ev of 68 | Just sender -> do 69 | let user = Team.lookupUser (coerce $ whUserLogin sender) team 70 | notifySlack team problem user 71 | host <- ask (view #jobserver) 72 | _ <- Job.kickJob host (problem ^. #id) (team ^. #id) (view #github <$> user) 73 | pure () 74 | Nothing -> 75 | logError "push sender is exist in webhook event" 76 | 77 | notifySlack :: Team -> Problem -> Maybe User -> Plant () 78 | notifySlack team problem user' = do 79 | url <- asks (view #slack) 80 | case user' of 81 | Just user -> Slack.sendWebhook url (mkMessage user) 82 | Nothing -> logWarn "sender is not found when notify slack" 83 | where 84 | mkMessage user = Slack.mkMessage $ mconcat 85 | [ coerce $ team ^. #name, " の ", coerce $ user ^. #name, " が ", coerce $ problem ^. #name, " にプッシュしたみたい！" ] 86 | -------------------------------------------------------------------------------- /src/Git/Plantation/Job/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | module Git.Plantation.Job.Client where 11 | 12 | import RIO 13 | import qualified RIO.ByteString.Lazy as BL 14 | import RIO.Process 15 | 16 | import Data.Extensible 17 | import Git.Plantation.Data.Job (Job) 18 | import qualified Git.Plantation.Data.Job as Job 19 | import qualified Git.Plantation.Job.Docker as Docker 20 | import qualified Git.Plantation.Job.Protocol as Protocol 21 | import Mix.Plugin.Logger () 22 | import qualified Network.WebSockets as WS 23 | import UnliftIO.Concurrent (forkIO) 24 | 25 | type Env = Record 26 | '[ "logger" >: LogFunc 27 | , "processContext" >: ProcessContext 28 | , "config" >: TVar Job.Config 29 | , "queue" >: TQueue Job 30 | ] 31 | 32 | instance Lookup xs "processContext" ProcessContext => HasProcessContext (Record xs) where 33 | processContextL = lens (view #processContext) (\x y -> x & #processContext `set` y) 34 | 35 | -- dest is expected 'localhost:8080/hoge/fuga' 36 | parseDest :: String -> Maybe (String, Int, String) 37 | parseDest dest = 38 | (host,, path) <$> readMaybe port' 39 | where 40 | (addr, path) = span (/= '/') dest 41 | (host, port') = drop 1 <$> span (/= ':') addr 42 | 43 | run :: String -> RIO Env () 44 | run dest = 45 | case parseDest dest of 46 | Nothing -> 47 | logError $ "cannot parse " <> fromString dest 48 | 49 | Just (host, port, path) -> do 50 | logDebug $ "Connecting to " <> fromString dest 51 | runInIO <- askRunInIO 52 | let opt = WS.defaultConnectionOptions { WS.connectionOnPong = runInIO $ logDebug "Pong" } 53 | liftIO $ WS.runClientWith host port path opt [] $ \conn -> 54 | liftIO $ WS.withPingThread conn 30 (runInIO $ logDebug "Ping") $ do 55 | runInIO $ logDebug $ "Connected to " <> fromString dest 56 | _ <- forkIO $ forever (runInIO $ runJob conn) 57 | forever (runInIO $ receive conn) `finally` runInIO (logDebug "Close worker") 58 | 59 | receive :: WS.Connection -> RIO Env () 60 | receive conn = do 61 | p <- liftIO $ WS.receiveData conn 62 | case p of 63 | Protocol.JobConfig newConfigs -> do 64 | configs <- asks (view #config) 65 | atomically $ writeTVar configs newConfigs 66 | Protocol.Enqueue jid pid tid uid -> do 67 | queue <- asks (view #queue) 68 | atomically $ writeTQueue queue (Job.new pid tid uid jid) 69 | _ -> 70 | pure () 71 | 72 | runJob :: WS.Connection -> RIO Env () 73 | runJob conn = do 74 | job <- atomically . readTQueue =<< asks (view #queue) 75 | config <- readTVarIO =<< asks (view #config) 76 | case (Job.findProblem config job, Job.findTeam config job) of 77 | (Just problem, Just team) -> do 78 | liftIO $ WS.sendBinaryData conn (Protocol.JobRunning $ job ^. #id) 79 | logDebug $ "Run: " <> display (problem ^. #name) <> "/" <> display (team ^. #name) 80 | (code, out, err) <- Docker.testScript config problem team 81 | let out' = BL.toStrict out 82 | err' = BL.toStrict err 83 | case code of 84 | ExitSuccess -> 85 | liftIO $ WS.sendBinaryData conn (Protocol.JobSuccess (job ^. #id) out' err') 86 | ExitFailure _ -> 87 | liftIO $ WS.sendBinaryData conn (Protocol.JobFailure (job ^. #id) out' err') 88 | _ -> 89 | liftIO $ WS.sendBinaryData conn (Protocol.JobFailure (job ^. #id) "" "") 90 | 91 | -------------------------------------------------------------------------------- /src/Git/Plantation/API/Job.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedLabels #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Git.Plantation.API.Job where 10 | 11 | import RIO 12 | import qualified RIO.List as List 13 | import qualified RIO.Map as Map 14 | import qualified RIO.Text as Text 15 | 16 | import Data.Coerce (coerce) 17 | import Data.Extensible 18 | import Git.Plantation.Data.Job (Job) 19 | import qualified Git.Plantation.Data.Job as Job 20 | import qualified Git.Plantation.Data.Problem as Problem 21 | import qualified Git.Plantation.Data.Team as Team 22 | import qualified Git.Plantation.Data.User as User 23 | import qualified Git.Plantation.Job.Server as Job 24 | import Git.Plantation.Job.Store (askStore) 25 | import qualified Git.Plantation.Job.Worker as Worker 26 | import qualified Network.Wreq as W 27 | import Servant 28 | 29 | type API 30 | = "workers" :> Get '[JSON] [Worker.Info] 31 | :<|> "jobs" :> Get '[JSON] [Job] -- get by cache 32 | :<|> "jobs" :> "queuing" :> Get '[JSON] [Job] 33 | :<|> "jobs" :> "running" :> Get '[JSON] [Job] 34 | :<|> "jobs" :> "team" :> Capture "team" Team.Id :> Get '[JSON] [Job] 35 | :<|> "jobs" :> "problem" :> Capture "problem" Problem.Id :> Get '[JSON] [Job] 36 | :<|> "jobs" :> "requeue" :> Capture "job" Job.Id :> Post '[JSON] Job 37 | :<|> "jobs" :> "kick" :> Capture "problem" Problem.Id :> Capture "team" Team.Id :> Post '[JSON] Job 38 | :<|> "jobs" :> "kick" :> Capture "problem" Problem.Id :> Capture "team" Team.Id :> Capture "user" User.GitHubId :> Post '[JSON] Job 39 | 40 | api :: Proxy API 41 | api = Proxy 42 | 43 | server :: Job.ServerEnv env => ServerT API (RIO env) 44 | server = gethWorkers 45 | :<|> getJobs :<|> getQueuingJobs :<|> getRunningJobs :<|> getTeamJobs :<|> getProblemJobs 46 | :<|> requeueJob 47 | :<|> postJobWithoutUser :<|> postJobWithUser 48 | where 49 | gethWorkers = do 50 | logInfo "[GET] /workers" 51 | map shrink <$> Worker.getAllConnected 52 | getJobs = do 53 | logInfo "[GET] /job" 54 | store <- askStore 55 | Map.elems <$> readTVarIO store 56 | getQueuingJobs = do 57 | store <- askStore 58 | filter (view #queuing) . Map.elems <$> readTVarIO store 59 | getRunningJobs = do 60 | store <- askStore 61 | filter (view #running) . Map.elems <$> readTVarIO store 62 | getTeamJobs tid = do 63 | store <- askStore 64 | filter (\job -> job ^. #team == tid) . Map.elems <$> readTVarIO store 65 | getProblemJobs pid = do 66 | store <- askStore 67 | filter (\job -> job ^. #problem == pid) . Map.elems <$> readTVarIO store 68 | requeueJob jid = do 69 | unwrapError =<< Job.enqueueJob jid 70 | postJobWithoutUser pid tid = postJob pid tid Nothing 71 | postJobWithUser pid tid = postJob pid tid . Just 72 | postJob pid tid uid = unwrapError =<< Job.kickJob pid tid uid 73 | 74 | unwrapError :: Either Job.Error Job -> RIO env Job 75 | unwrapError = \case 76 | Right job -> 77 | pure job 78 | Left (Job.ProblemIsNotFound _) -> 79 | throwM err404 80 | Left (Job.TeamIsNotFound _) -> 81 | throwM err404 82 | Left (Job.UserIsNotFound _) -> 83 | throwM err404 84 | Left Job.WorkerIsNotExist -> 85 | throwM err500 86 | Left (Job.JobIsNotFound _) -> 87 | throwM err404 88 | 89 | fetchJobs :: (MonadThrow m, MonadIO m) => String -> m [Job] 90 | fetchJobs host = do 91 | resp <- W.asJSON =<< liftIO (W.get $ host ++ "/jobs") 92 | pure $ resp ^. W.responseBody 93 | 94 | kickJob :: (MonadThrow m, MonadIO m) => String -> Problem.Id -> Team.Id -> Maybe User.GitHubId -> m Job 95 | kickJob host pid tid uid = do 96 | resp <- W.asJSON =<< liftIO (W.post url ("" :: ByteString)) 97 | pure $ resp ^. W.responseBody 98 | where 99 | url = List.intercalate "/" $ 100 | [ host, "jobs", "kick", show pid, Text.unpack (coerce tid)] ++ maybeToList (Text.unpack . coerce <$> uid) 101 | -------------------------------------------------------------------------------- /elm-src/Score.elm: -------------------------------------------------------------------------------- 1 | module Score exposing (Score, State(..), Status, Team, build, filterByPlayerID, filterByTeamIDs, updateBy) 2 | 3 | import Generated.API as API 4 | import List.Extra as List 5 | 6 | 7 | type alias Score = 8 | { team : Team 9 | , point : Int 10 | , stats : List Status 11 | } 12 | 13 | 14 | type alias Team = 15 | { id : String 16 | , name : String 17 | , member : List API.User 18 | } 19 | 20 | 21 | type alias Status = 22 | { problemId : Int 23 | , problemName : String 24 | , difficulty : Int 25 | , url : String 26 | , state : State 27 | , correctTime : Int -- unixtime 28 | , answerer : String 29 | } 30 | 31 | 32 | type State 33 | = None 34 | | Pending 35 | | Incorrect 36 | | Correct 37 | 38 | 39 | build : { a | problems : List API.Problem, teams : List API.Team } -> List API.Score -> List Score 40 | build { problems, teams } scores = 41 | List.map (buildEmptyScore problems) teams 42 | |> updateBy scores 43 | 44 | 45 | buildEmptyScore : List API.Problem -> API.Team -> Score 46 | buildEmptyScore problems team = 47 | { team = { id = team.id, name = team.name, member = team.member } 48 | , point = 0 49 | , stats = List.map buildEmptyStatus problems 50 | } 51 | 52 | 53 | buildEmptyStatus : API.Problem -> Status 54 | buildEmptyStatus problem = 55 | { problemId = problem.id 56 | , problemName = problem.name 57 | , difficulty = problem.difficulty 58 | , url = "" 59 | , state = None 60 | , correctTime = 0 61 | , answerer = "" 62 | } 63 | 64 | 65 | updateBy : List API.Score -> List Score -> List Score 66 | updateBy respScores scores = 67 | for scores 68 | (\score -> 69 | case List.find (\s -> s.team == score.team.id) respScores of 70 | Nothing -> 71 | score 72 | 73 | Just resp -> 74 | updateScoreBy resp score 75 | ) 76 | 77 | 78 | updateScoreBy : API.Score -> Score -> Score 79 | updateScoreBy respScore score = 80 | { score 81 | | point = respScore.point 82 | , stats = List.map (updateStatusBy respScore) score.stats 83 | } 84 | 85 | 86 | updateStatusBy : API.Score -> Status -> Status 87 | updateStatusBy respScore status = 88 | let 89 | url = 90 | respScore.links 91 | |> List.find (\l -> l.problem_id == status.problemId) 92 | |> Maybe.map .url 93 | |> Maybe.withDefault status.url 94 | 95 | respStatus = 96 | List.find (\s -> s.problem_id == status.problemId) respScore.stats 97 | 98 | state = 99 | respStatus 100 | |> Maybe.map toState 101 | |> Maybe.withDefault None 102 | 103 | correctTime = 104 | respStatus 105 | |> Maybe.andThen .corrected_at 106 | |> Maybe.withDefault 0 107 | 108 | answerer = 109 | respStatus 110 | |> Maybe.andThen .answerer 111 | |> Maybe.withDefault "" 112 | in 113 | { status | url = url, state = state, correctTime = correctTime, answerer = answerer } 114 | 115 | 116 | toState : API.Status -> State 117 | toState status = 118 | case ( status.correct, status.pending ) of 119 | ( _, True ) -> 120 | Pending 121 | 122 | ( False, _ ) -> 123 | Incorrect 124 | 125 | ( True, _ ) -> 126 | Correct 127 | 128 | 129 | filterByTeamIDs : List String -> List Score -> List Score 130 | filterByTeamIDs ids = 131 | List.filter (\s -> List.member s.team.id ids) 132 | 133 | 134 | filterByPlayerID : String -> List Score -> List Score 135 | filterByPlayerID idx scores = 136 | scores 137 | |> List.filter (\score -> List.member idx (List.map .github score.team.member)) 138 | |> List.map 139 | (\score -> 140 | let 141 | team = 142 | score.team 143 | 144 | filtered = 145 | { team | member = List.filter (\u -> u.github == idx) team.member } 146 | in 147 | { score | team = filtered } 148 | ) 149 | 150 | 151 | 152 | -- Util 153 | 154 | 155 | for : List a -> (a -> b) -> List b 156 | for xs f = 157 | List.map f xs 158 | -------------------------------------------------------------------------------- /src/Git/Plantation/Score.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Git.Plantation.Score 7 | ( Score 8 | , Status 9 | , Link 10 | , mkScore 11 | , mkPlayerScore 12 | ) where 13 | 14 | import RIO 15 | import qualified RIO.List as L 16 | import qualified RIO.Map as Map 17 | 18 | import Data.Extensible 19 | import Data.Extensible.Elm.Mapping 20 | import Elm.Mapping 21 | import Git.Plantation.Data (Job, Problem, Repo, Team, User, 22 | repoGithubPath) 23 | import qualified Git.Plantation.Data.Problem as Problem 24 | import qualified Git.Plantation.Data.Team as Team 25 | import qualified Git.Plantation.Data.User as User 26 | 27 | import Orphans () 28 | 29 | type Score = Record 30 | '[ "team" >: Team.Id 31 | , "point" >: Int 32 | , "stats" >: [Status] 33 | , "links" >: [Link] 34 | ] 35 | 36 | type Status = Record 37 | '[ "problem_id" >: Problem.Id 38 | , "correct" >: Bool 39 | , "pending" >: Bool 40 | , "corrected_at" >: Maybe Int64 41 | , "answerer" >: Maybe User.GitHubId 42 | ] 43 | 44 | type Link = Record 45 | '[ "problem_id" >: Problem.Id 46 | , "url" >: Text 47 | ] 48 | 49 | instance IsElmType Score where 50 | compileElmType = compileElmRecordTypeWith "Score" 51 | 52 | instance IsElmDefinition Score where 53 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Score" 54 | 55 | instance IsElmType Status where 56 | compileElmType = compileElmRecordTypeWith "Status" 57 | 58 | instance IsElmDefinition Status where 59 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Status" 60 | 61 | instance IsElmType Link where 62 | compileElmType = compileElmRecordTypeWith "Link" 63 | 64 | instance IsElmDefinition Link where 65 | compileElmDef = ETypeAlias . compileElmRecordAliasWith "Link" 66 | 67 | mkScore :: [Problem] -> Team -> [Job] -> Score 68 | mkScore problems team jobs 69 | = #team @= team ^. #id 70 | <: #point @= calcPoint stats problems 71 | <: #stats @= Map.elems stats 72 | <: #links @= links 73 | <: nil 74 | where 75 | stats = Map.mapWithKey toStatus $ mkGroupedTeamJobs problems team jobs 76 | links = map toLink $ team ^. #repos 77 | 78 | mkPlayerScore :: [Problem] -> Team -> User -> [Job] -> Score 79 | mkPlayerScore problems team user jobs 80 | = #team @= team ^. #id 81 | <: #point @= calcPoint stats problems 82 | <: #stats @= Map.elems stats 83 | <: #links @= links 84 | <: nil 85 | where 86 | teamJobs = mkGroupedTeamJobs problems team jobs 87 | playerJobs = filter (\job -> job ^. #author == Just (user ^. #github)) <$> teamJobs 88 | stats = Map.mapWithKey toStatus playerJobs 89 | links = map toLink $ team ^. #repos 90 | 91 | mkGroupedTeamJobs :: [Problem] -> Team -> [Job] -> Map Problem.Id [Job] 92 | mkGroupedTeamJobs problems team jobs = 93 | Map.fromListWith (++) $ fmap (\job -> (job ^. #problem, [job])) teamJobs 94 | where 95 | teamJobs = mkTeamJobs problems team jobs 96 | 97 | mkTeamJobs :: [Problem] -> Team -> [Job] -> [Job] 98 | mkTeamJobs problems team = 99 | filter (\job -> job ^. #team == team ^. #id && any (\p -> p ^. #id == job ^. #problem) problems) 100 | 101 | toStatus :: Problem.Id -> [Job] -> Status 102 | toStatus pid jobs 103 | = #problem_id @= pid 104 | <: #correct @= any (\job -> job ^. #success) jobs 105 | <: #pending @= any (\job -> job ^. #queuing || job ^. #running) jobs 106 | <: #corrected_at @= L.minimumMaybe (view #created <$> filter (\job -> job ^. #success) jobs) 107 | <: #answerer @= listToMaybe (mapMaybe (view #author) jobs) 108 | <: nil 109 | 110 | calcPoint :: Map Problem.Id Status -> [Problem] -> Int 111 | calcPoint stats = sum . map (toPoint stats) 112 | 113 | toPoint :: Map Problem.Id Status -> Problem -> Int 114 | toPoint stats problem = 115 | case Map.lookup (problem ^. #id) stats of 116 | Just s | s ^. #correct -> problem ^. #difficulty 117 | _ -> 0 118 | 119 | toLink :: Repo -> Link 120 | toLink repo 121 | = #problem_id @= repo ^. #problem 122 | <: #url @= maybe "" ("https://github.com/" <>) (repoGithubPath repo) 123 | <: nil 124 | -------------------------------------------------------------------------------- /src/Git/Plantation/API/Slack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Git.Plantation.API.Slack 10 | ( SlackAPIEnv 11 | , SlashCmdAPI 12 | , slashCmdApi 13 | ) where 14 | 15 | import RIO 16 | import qualified RIO.ByteString.Lazy as BL 17 | import qualified RIO.List as L 18 | import qualified RIO.Text as Text 19 | import qualified RIO.Text.Lazy as TL 20 | 21 | import qualified Data.Aeson.Text as Json 22 | import Data.Coerce (coerce) 23 | import Data.Extensible 24 | import qualified Git.Plantation.Cmd as Cmd 25 | import Git.Plantation.Config (Config) 26 | import Git.Plantation.Data (Problem, Repo, Team) 27 | import qualified Git.Plantation.Data.Problem as Problem 28 | import Git.Plantation.Data.Slack (askSlashCmdConfig) 29 | import qualified Git.Plantation.Data.Slack as Slack 30 | import qualified Git.Plantation.Data.Team as Team 31 | import qualified Mix.Plugin.Config as Mix 32 | import Servant 33 | import UnliftIO.Concurrent (forkIO) 34 | 35 | type SlackAPIEnv env = (Cmd.CmdEnv env, Mix.HasConfig Config env, Slack.HasSlackSlashCmdConfig env, HasLogFunc env) 36 | 37 | type SlashCmdAPI 38 | = ReqBody '[Slack.SlashCmd] (LByteString, Slack.SlashCmdData) 39 | :> Header "X-Slack-Request-Timestamp" Slack.RequestTimestamp 40 | :> Header "X-Slack-Signature" Slack.SignatureHeader 41 | :> Post '[JSON] NoContent 42 | 43 | slashCmdApi :: SlackAPIEnv env => ServerT SlashCmdAPI (RIO env) 44 | slashCmdApi = verifiedRequest resetRepo 45 | 46 | verifiedRequest 47 | :: SlackAPIEnv env 48 | => (Slack.SlashCmdData -> RIO env a) 49 | -> (LByteString, Slack.SlashCmdData) 50 | -> Maybe Slack.RequestTimestamp 51 | -> Maybe Slack.SignatureHeader 52 | -> RIO env a 53 | verifiedRequest next (body, postData) (Just ts) (Just sign) = do 54 | secret <- view #signing_secret <$> askSlashCmdConfig 55 | let digest = Slack.encodeSignature secret ts (BL.toStrict body) 56 | if Just digest == Slack.convertSignatureHeader sign then 57 | next postData 58 | else do 59 | logError "invalid signature" 60 | throwM err401 61 | verifiedRequest _ _ Nothing _ = do 62 | logError "invalid request: Request-Timestamp header is nothing" 63 | throwM err401 64 | verifiedRequest _ _ _ Nothing = do 65 | logError "invalid request: Signature header is nothing" 66 | throwM err401 67 | 68 | resetRepo :: SlackAPIEnv env => Slack.SlashCmdData -> RIO env NoContent 69 | resetRepo postData = do 70 | logInfo $ fromString $ mconcat 71 | [ "[POST] /slack/reset-repo " 72 | -- , TL.unpack $ Json.encodeToLazyText (shrink postData :: Slack.DisplayLogData) 73 | ] 74 | _ <- forkIO $ Slack.verifySlashCmd postData >>= \case 75 | Left err -> logError $ display err 76 | Right _ -> (logError . display) `handleIO` resetRepo' (postData ^. #text) 77 | pure NoContent 78 | where 79 | resetRepo' :: SlackAPIEnv env => Text -> RIO env () 80 | resetRepo' text = do 81 | logDebug "reset-cmd: find repository by message" 82 | Slack.respondMessage postData $ Slack.mkMessage "リポジトリをリセットするね！" 83 | config <- Mix.askConfig 84 | message <- case findInfos config text of 85 | Nothing -> pure $ Slack.mkMessage "うーん、リポジトリが見つからなーい..." 86 | Just info -> Slack.mkMessage <$> reset info 87 | slackConfig <- Slack.askSlashCmdConfig 88 | case slackConfig ^. #webhook of 89 | Just url -> Slack.sendWebhook url message 90 | Nothing -> Slack.respondMessage postData message 91 | 92 | reset :: SlackAPIEnv env => (Team, Problem, Repo) -> RIO env Text 93 | reset (team, problem, repo) = do 94 | let success = [coerce $ team ^. #name, " の ", coerce $ problem ^. #name, " をリセットしました！"] 95 | tryIO (Cmd.resetRepo $ #repo @= repo <: #team @= team <: nil) >>= \case 96 | Left err -> logError (display err) >> pure "うーん、なんか失敗したみたい..." 97 | Right _ -> pure (mconcat success) 98 | 99 | findInfos :: Config -> Text -> Maybe (Team, Problem, Repo) 100 | findInfos config txt = do 101 | (team, repo) <- L.find (\(_, r) -> Team.repoGithubPath r == Just ghPath) repos 102 | problem <- L.find (\p -> p ^. #id == repo ^. #problem) $ config ^. #problems 103 | pure (team, problem, repo) 104 | where 105 | ghPath = Text.dropSuffix "/" $ Text.dropPrefix "https://github.com/" txt 106 | repos = concatMap (\t -> (t,) <$> t ^. #repos) $ config ^. #teams 107 | -------------------------------------------------------------------------------- /src/Git/Plantation/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Git.Plantation.Env where 9 | 10 | import RIO 11 | 12 | import Data.Aeson (ToJSON) 13 | import qualified Data.Aeson.Text as Json 14 | import Data.Extensible 15 | import Git.Plantation.Config 16 | import Git.Plantation.Data 17 | import qualified Git.Plantation.Data.Slack as Slack 18 | import qualified GitHub.Data as GitHub 19 | import qualified Mix.Plugin.GitHub as GitHub 20 | import Mix.Plugin.Logger () 21 | import qualified Mix.Plugin.Logger.JSON as Mix 22 | import qualified RIO.Text.Lazy as TL 23 | import qualified Servant.Auth.Server as Auth 24 | 25 | type Plant = RIO Env 26 | 27 | type Env = Record 28 | '[ "config" >: Config 29 | , "github" >: GitHub.Token 30 | , "gh_user" >: Text 31 | , "slack" >: Text -- slack webhook url 32 | , "slash" >: Slack.SlashCmdConfig 33 | , "work" >: FilePath 34 | , "webhook" >: WebhookConfig 35 | , "jobserver" >: String -- URL for jobserver 36 | , "logger" >: LogFunc 37 | , "oauth" >: OAuthSettings 38 | ] 39 | 40 | type WebhookConfig = [(Text, Text)] 41 | 42 | mkWebhookConf :: Text -> Text -> WebhookConfig 43 | mkWebhookConf url secret = 44 | [ ("url", url) 45 | , ("content_type", "json") 46 | , ("secret", secret) 47 | ] 48 | 49 | class HasWebhookConfig env where 50 | webhookConfigL :: Lens' env WebhookConfig 51 | 52 | instance Lookup xs "webhook" WebhookConfig => HasWebhookConfig (Record xs) where 53 | webhookConfigL = lens (view #webhook) (\x y -> x & #webhook `set` y) 54 | 55 | askWebhookConfig :: HasWebhookConfig env => RIO env WebhookConfig 56 | askWebhookConfig = view webhookConfigL 57 | 58 | type OAuthSettings = Record 59 | '[ "client_id" >: String 60 | , "client_secret" >: String 61 | , "cookie" >: Auth.CookieSettings 62 | , "jwt" >: Auth.JWTSettings 63 | ] 64 | 65 | fromJustWithThrow :: Exception e => Maybe a -> e -> RIO env a 66 | fromJustWithThrow (Just x) _ = pure x 67 | fromJustWithThrow Nothing e = throwIO e 68 | 69 | mkLogMessage' :: 70 | Forall (KeyTargetAre KnownSymbol (Instance1 ToJSON Identity)) xs 71 | => Text -> Record xs -> String 72 | mkLogMessage' message = 73 | TL.unpack . Json.encodeToLazyText . Mix.mkLogMessage message LevelError 74 | 75 | data GitPlantException = UndefinedTeamProblem Team Problem 76 | | UndefinedProblem Int 77 | | CreateRepoError GitHub.Error Team Repo 78 | | DeleteRepoError GitHub.Error Repo 79 | | SetupWebhookError GitHub.Error Repo 80 | | AddRepoToGitHubTeamError GitHub.Error Text Text Repo 81 | | InviteUserError GitHub.Error User MemberTarget 82 | | KickUserError GitHub.Error User MemberTarget 83 | | CreateGitHubTeamError GitHub.Error Team Text 84 | | InvalidRepoConfig Repo 85 | deriving (Typeable) 86 | 87 | instance Exception GitPlantException 88 | 89 | instance Show GitPlantException where 90 | show = \case 91 | UndefinedTeamProblem team problem -> 92 | mkLogMessage' 93 | "undefined team repo" 94 | (#team @= team <: #problem @= problem <: nil) 95 | UndefinedProblem idx -> 96 | mkLogMessage' 97 | "undefined problem" 98 | (#id @= idx <: nil) 99 | CreateRepoError _err team problem -> 100 | mkLogMessage' 101 | "can't create repository" 102 | (#team @= team <: #problem @= problem <: nil) 103 | DeleteRepoError _err repo -> 104 | mkLogMessage' 105 | "can't delete repository" 106 | (#repo @= repo <: nil) 107 | SetupWebhookError _err repo -> 108 | mkLogMessage' 109 | "can't setup github webhook" 110 | (#repo @= repo <: nil) 111 | AddRepoToGitHubTeamError _err org name repo -> 112 | mkLogMessage' 113 | "cant't add repository to GitHub team" 114 | (#org @= org <: #gh_team @= name <: #repo @= repo <: nil) 115 | InviteUserError _err user target -> 116 | mkLogMessage' 117 | "can't invite user to repository" 118 | (#user @= user <: #target @= toMemberTargetRecord target <: nil) 119 | KickUserError _err user target -> 120 | mkLogMessage' 121 | "can't kick user from repository" 122 | (#user @= user <: #target @= toMemberTargetRecord target <: nil) 123 | CreateGitHubTeamError _err team name -> 124 | mkLogMessage' 125 | "can't create GitHub team in org" 126 | (#team @= team <: #gh_team @= name <: nil) 127 | InvalidRepoConfig repo -> 128 | mkLogMessage' 129 | "invalid repo config" 130 | (#repo @= repo <: nil) 131 | -------------------------------------------------------------------------------- /exec/jobserver/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | module Main where 11 | 12 | import Paths_git_plantation (version) 13 | import RIO hiding (catch) 14 | import qualified RIO.ByteString as B 15 | 16 | import Configuration.Dotenv (defaultConfig, loadFile) 17 | import Data.Extensible 18 | import Data.Extensible.GetOpt 19 | import Data.Version (Version) 20 | import qualified Data.Version as Version 21 | import Development.GitRev 22 | import Git.Plantation (Config, readConfig) 23 | import qualified Git.Plantation.API.Job as Job 24 | import qualified Git.Plantation.Data.Job as Job 25 | import qualified Git.Plantation.Data.Slack as Slack 26 | import qualified Git.Plantation.Job.Server as Job 27 | import qualified Git.Plantation.Job.Store as Job 28 | import qualified Git.Plantation.Job.Worker as Job 29 | import qualified Mix 30 | import qualified Mix.Plugin as Mix (withPlugin) 31 | import qualified Mix.Plugin.Logger as MixLogger 32 | import qualified Mix.Plugin.Persist.Sqlite as MixDB 33 | import qualified Network.Wai.Handler.Warp as Warp 34 | import Network.Wai.Handler.WebSockets (websocketsOr) 35 | import qualified Network.WebSockets as WS 36 | import Servant 37 | import System.Environment (getEnv) 38 | 39 | import Orphans () 40 | 41 | main :: IO () 42 | main = withGetOpt "[options] [config-file]" opts $ \r args -> do 43 | _ <- tryIO $ loadFile defaultConfig 44 | if 45 | | r ^. #version -> B.putStr $ fromString (showVersion version) <> "\n" 46 | | r ^. #migrate -> runMigration r 47 | | otherwise -> 48 | case listToMaybe args of 49 | Nothing -> error "please input config file path." 50 | Just path -> runServer r =<< readConfig path 51 | where 52 | opts = #port @= portOpt 53 | <: #verbose @= verboseOpt 54 | <: #version @= versionOpt 55 | <: #migrate @= migrateOpt 56 | <: nil 57 | 58 | type Options = Record 59 | '[ "port" >: Int 60 | , "verbose" >: Bool 61 | , "version" >: Bool 62 | , "migrate" >: Bool 63 | ] 64 | 65 | portOpt :: OptDescr' Int 66 | portOpt = optionReqArg 67 | (pure . fromMaybe 8080 . (readMaybe <=< listToMaybe)) 68 | ['p'] ["port"] "PORT" "Set port to PORT instead of 8080." 69 | 70 | verboseOpt :: OptDescr' Bool 71 | verboseOpt = optFlag ['v'] ["verbose"] "Enable verbose mode: verbosity level \"debug\"" 72 | 73 | versionOpt :: OptDescr' Bool 74 | versionOpt = optFlag [] ["version"] "Show version" 75 | 76 | migrateOpt :: OptDescr' Bool 77 | migrateOpt = optFlag [] ["migrate"] "Migrate SQLite tables" 78 | 79 | runMigration :: Options -> IO () 80 | runMigration opts = do 81 | sqlitePath <- liftIO $ fromString <$> getEnv "SQLITE_PATH" 82 | let logConf = #handle @= stdout <: #verbose @= (opts ^. #verbose) <: nil 83 | plugin = hsequence 84 | $ #logger <@=> MixLogger.buildPlugin logConf 85 | <: #sqlite <@=> MixDB.buildPluginWithoutPool sqlitePath 86 | <: nil 87 | Mix.run plugin (Job.migrate @(Record '[ "logger" >: LogFunc, "sqlite" >: MixDB.Config ])) 88 | 89 | type Env = Record 90 | '[ "config" >: Config 91 | , "logger" >: LogFunc 92 | , "workers" >: Job.Workers 93 | , "store" >: Job.Store 94 | , "sqlite" >: MixDB.Config 95 | , "notify" >: Slack.NotifyConfig 96 | ] 97 | 98 | runServer :: Options -> Config -> IO () 99 | runServer opts config = do 100 | slackToken <- liftIO $ fromString <$> getEnv "SLACK_API_TOKEN" 101 | slackChannel <- liftIO $ fromString <$> getEnv "SLACK_NOTIFY_CHANNEL" 102 | sqlitePath <- liftIO $ fromString <$> getEnv "SQLITE_PATH" 103 | let logConf = #handle @= stdout <: #verbose @= (opts ^. #verbose) <: nil 104 | slackConfig = #api_token @= slackToken <: #channel_id @= slackChannel <: nil 105 | plugin = hsequence 106 | $ #config <@=> pure config 107 | <: #logger <@=> MixLogger.buildPlugin logConf 108 | <: #workers <@=> Job.newWorkers 109 | <: #store <@=> Job.newStore 110 | <: #sqlite <@=> MixDB.buildPlugin sqlitePath 2 111 | <: #notify <@=> pure slackConfig 112 | <: nil 113 | B.putStr $ "Listening on port " <> (fromString . show) (opts ^. #port) <> "\n" 114 | flip Mix.withPlugin plugin $ \env -> do 115 | runRIO env $ do 116 | jobs <- Job.selectAll 117 | Job.initializeStore jobs 118 | Warp.run (opts ^. #port) $ 119 | websocketsOr 120 | WS.defaultConnectionOptions 121 | (runRIO env . Job.serveRunner') 122 | (app env) 123 | 124 | app :: Env -> Application 125 | app env = 126 | serve Job.api $ hoistServer Job.api (runRIO env) Job.server 127 | 128 | showVersion :: Version -> String 129 | showVersion v = unwords 130 | [ "Version" 131 | , Version.showVersion v ++ "," 132 | , "Git revision" 133 | , $(gitHash) 134 | , "(" ++ $(gitCommitCount) ++ " commits)" 135 | ] 136 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for git-plantation 2 | 3 | ## Unreleased changes 4 | 5 | ## v0.5.0 6 | 7 | - スコアボードにグラフを描写するページを追加(#49) 8 | - `end_time` と `zone` を設定に追加 9 | - `tesk9/palette` に対応させた `terezka/line-charts` のフォークをローカルで差し替え 10 | - スコアボードのページの構造をリファクタリング(#50) 11 | - `Score` 型を作って両方のページで共用した 12 | - 一つの SPA にした 13 | - チームごとのページを追加(#52) 14 | - 特定のチームだけのボード + グラフ 15 | - スコアボードの見た目を改修(#52) 16 | - ヘッダーを追加した 17 | - `primer.css` の cdn を変更(13.2 にバージョンアップ) 18 | - ボード部分がでか過ぎるレイアウトを修正 19 | - スコアボードに個人のページを追加(#56) 20 | - GitHub Actions の設定を追加(#57) 21 | - Elm のバージョンを 0.19.1 に変更(#57) 22 | - LTS を 15.5 に更新(#58) 23 | - GHC を 8.8.3 に更新 24 | - extensible を 0.8 に更新 25 | - github を 0.25 に更新 26 | - drone を 1.1.0 に更新 27 | - GitHub OAuth 2.0 による認証機能を追加(#59) 28 | - make 時の stack test で generateElm だけが動作するように変更(#59) 29 | - elm build 時に optimize オプションを追加(#59) 30 | - 採点可能かどうかのフラグを設定に追加(#60) 31 | - Slack Webhook を受けるサーバーを App サーバーに統合(#62) 32 | 33 | ## v0.4.0 34 | 35 | * キャッシュ(store)の更新を遅延させた(#46) 36 | * リセットするSlackボット用のAPIをAppから切り分けた (#47) 37 | * Slack からのIP制限をすることができないため 38 | * リセットの結果はチャンネルにいる全員が見えるようにした (#47) 39 | * Drone の Build を作成時刻でフィルタリングする機能を追加 (#48) 40 | * `start_time` 設定を追加(ただし unix time を直接書く) 41 | * `drone` が `Int64` に対応してなかったのでバージョンアップ 42 | 43 | ## v0.3.0 44 | 45 | * mix パッケージを作成 (#26) 46 | * [tonatona](http://hackage.haskell.org/package/tonatona) にインスパイアされた [rio](http://hackage.haskell.org/package/rio) の薄いラッパーパッケージ 47 | * rio-logger, [github-client](https://github.com/matsubara0507/github/tree/collaborator-api), [drone-client](https://github.com/matsubara0507/drone-haskell), [shh](http://hackage.haskell.org/package/shh) プラグインも作成 48 | * ~~shelly を shh に移行~~ thred unsafe だったので shelly に戻した(#40)　 49 | * リセットするSlackボット用のAPIを追加 (#27) 50 | * shh-cmd パッケージを作成 (#28) 51 | * [shh](http://hackage.haskell.org/package/shh) の薄いラッパーパッケージ 52 | * よく使うコマンド関数を作成 53 | * `tool` をサブサブコマンド化 (#29) 54 | * `git-plantation-tool (config|problem|member|repo) COMMAND` と指定する形式に変更 55 | * 合わせてディレクトリ構造も刷新 56 | * `problem` コマンドも追加 57 | * `mix-json-logger` パッケージを作成(#30) 58 | * GitHub Team に関するコマンドを追加(#31) 59 | * `github` パッケージを更新 60 | * `member invite/kick` に `--org` `--gh_team` オプションを追加して GitHub Team に招待/除外 61 | * `org create_team` コマンドで GitHub Team を作成 62 | * `repo add_gh_team` コマンドでリポジトリを GitHub Team に追加する 63 | * 問題リポジトリの Drone CI をアクティベイトするコマンドを追加(#32) 64 | * リポジトリのリセット処理を修正(#33) 65 | * ワークディレクトリをチームごとに区切ってたが、さらに問題リポジトリ用のサブディレクトリ `/problem` を追加 66 | * 回答者を Slack に通知する機能を追加(#34) 67 | * 回答リポジトのリデフォルトブランチを更新するコマンドを追加(#35) 68 | * `repo new` の時にも実行される 69 | * `github` パッケージが対応してなかったので独自で更新 70 | * 独自キャッシュサーバー `git-plantation-store` を作成(#41) 71 | * DroneCI のビルドデータを必要な分だけキャッシュしている 72 | * スコアボードなどの負荷対策 73 | * App で GitHub Webohook 取得時・DroneCI での採点終了時に更新をする 74 | * Drone とのやりとりに http を指定できるようにした(#42) 75 | * `stack image container` を使わないで Docker Image を作れるように変更(#45) 76 | * stack v2 対応するため 77 | * LTS を 14.6 に更新(#45) 78 | * `extensible` のバージョンを 0.6.1 に変更 79 | * `drone` のバージョンを 1.0.1 に更新 80 | * `github` を更新 (0.22 をマージしたもの) 81 | * `elm-export` から `elmap.hs` に変更 82 | * `mix.hs` を更新(`extensible` の 0.6 以上に対応したもの) 83 | * stack docker integration の base image を `matsubara0507/stack-build` に変更(#45) 84 | * こっちの方が軽くて CI との相性が良い 85 | * docker-compose での Drone のバージョンを 1.4.0 に変更 86 | 87 | ## v0.2.0 88 | 89 | * org アカウント以外で config 設定 (#10) 90 | * dotenv ファイルが使えるようになる (#10) 91 | * `/score` エンドポイントで drone から取得できなくても空リストを返す (#10) 92 | * `fail` の代わりに例外処理を追加 (#11) 93 | * JSON 形式のログを追加(#11) 94 | * 回答リポジトリの生成の各ステップコマンドを追加(#13) 95 | * GitHub に空リポジトリを作成 96 | * リポジトリを初期化(問題リポジトリを参照して) 97 | * 回答のためCIを問題リポジトリに設定 98 | * メンバーを回答リポジトリに招待する(#13) 99 | * 回答リポジトリのリセット(#13) 100 | * コマンドの追加と変更(#14) 101 | * `verify` : 設定ファイルの検査 102 | * `delete_repo` : 回答リポジトリとCIの設定の削除 103 | * private リポジトリを生成できるように変更 104 | * org アカウント以外でもちゃんと動作するように修正 105 | * 設定周りの更新(#14) 106 | * `Problem` と 回答リポジトリの対応関係を `id` にした 107 | * `provate` 設定の追加 108 | * `org` と `owner` を明示的に指定するように変更 109 | * 解答リポジトリの生成時に GitHub Webhook の設定をする(#15) 110 | * GitHub Webhook の設定をするコマンドを追加(#15) 111 | * Webhook API の修正(#15) 112 | * 問題の検索周りの処理が間違っていた 113 | * Docker イメージの修正(#15) 114 | * `static` ディレクトリの追加 115 | * git コマンドの設定を追加 116 | * `.env` ファイルがなくても動作するように修正(#15) 117 | * app の base image を変更(#16) 118 | * `invite_member` コマンドの修正(#17) 119 | * 変数の指定間違い 120 | * 失敗時にエラーを返すように(`github` パッケージから修正) 121 | * `setup_webhook` コマンドの GitHub Webhook の設定の仕方を修正(#17) 122 | * `APP_HOST` や `APP_PORT` を `APP_SERVER` 環境変数に変更して URL を修正 123 | * Secret を追加 (`GH_SECRET`) 124 | * 各コマンドで `git checkout` の前に `git pull` をするように修正(#17) 125 | * リポジトリ系のコマンドの `--repo` 引数を `problem.id` に変更(#17) 126 | * work space をチームごとに区切るように修正(#17) 127 | * 別々のチームから同じ問題に対し同時にプッシュが来ても問題ないようになった 128 | * 同じチームから同じ問題で別々のブランチなどに対し同時にプッシュが来たらおそらくまずい 129 | * webhook の時に `ci` ブランチにプッシュするのを `answer_branch` だけに限定(#17) 130 | * これで「同じチームから同じ問題で別々のブランチなどに対し同時にプッシュ」も平気 131 | * 一つのブランチでしか動作しないので 132 | * スコアボードに「採点中」を追加(#19) 133 | * `invite_member` コマンドを修正(#20) 134 | * 201 が返ってくる(`github` 側から修正) 135 | * リポジトリ系コマンドの修正・変更(#20) 136 | * work directory の cd 先が間違っていたのを修正 137 | * `--repos` で複数問題を指定できるように変更 138 | * スコアボードのスコアの総和の仕方が間違っていたのを修正(#20) 139 | * スコアボードで回答リポジトリに飛べるようにした(#20) 140 | * `new_repo` コマンドで任意の処理をスキップできるように変更(#21) 141 | * スコアボードの更新間隔を設定ファイルから指定できるように変更(#21) 142 | * 参加者をリポジトリからキックするコマンドを追加(#24) 143 | * スコア取得失敗時に画面を真っ白にしないように修正(#39) 144 | * `api/scores` で取得できないときに前のモデルを見るようにした 145 | * shell コマンド実行が thread unsafe だったのを修正(#40) 146 | * shh から shelly に戻した 147 | * [mix パッケージ](https://github.com/matsubara0507/mix.hs)を外部のに変更(#38) 148 | * LTS を 13.21 に更新(#38) 149 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/Slack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 9 | 10 | module Git.Plantation.Data.Slack 11 | ( module Slack 12 | , SlashCmdConfig 13 | , HasSlackSlashCmdConfig 14 | , askSlashCmdConfig 15 | , SlashCmdData 16 | , DisplayLogData 17 | , verifySlashCmd 18 | , SlashCmd 19 | , Message 20 | , mkMessage 21 | , respondMessage 22 | , sendWebhook 23 | , NotifyConfig 24 | , HasSlackNotifyConfig 25 | , askNotifyConfig 26 | , SnipetMessage 27 | , uploadFile 28 | ) where 29 | 30 | import RIO 31 | import qualified RIO.Text as Text 32 | 33 | import Control.Arrow ((+++)) 34 | import qualified Data.Aeson as J 35 | import Data.Extensible 36 | import Git.Plantation.Data.Slack.Verification as Slack 37 | import qualified Network.HTTP.Media as M 38 | import qualified Network.Wreq as W 39 | import Servant.API.ContentTypes (Accept (..), 40 | MimeUnrender (..)) 41 | import Web.FormUrlEncoded (urlDecodeAsForm) 42 | 43 | import Orphans () 44 | 45 | type SlashCmdConfig = Record 46 | '[ "signing_secret" >: Slack.SigningSecret 47 | , "verify_token" >: Text 48 | , "team_id" >: Text 49 | , "channel_ids" >: [Text] 50 | , "reset_repo_cmd" >: Text 51 | , "webhook" >: Maybe Text 52 | ] 53 | 54 | class HasSlackSlashCmdConfig env where 55 | slackSlashCmdConfigL :: Lens' env SlashCmdConfig 56 | 57 | instance Lookup xs "slash" SlashCmdConfig => HasSlackSlashCmdConfig (Record xs) where 58 | slackSlashCmdConfigL = lens (view #slash) (\x y -> x & #slash `set` y) 59 | 60 | askSlashCmdConfig :: HasSlackSlashCmdConfig env => RIO env SlashCmdConfig 61 | askSlashCmdConfig = view slackSlashCmdConfigL 62 | 63 | type SlashCmdData = Record 64 | '[ "token" >: Text 65 | , "team_id" >: Text 66 | , "team_domain" >: Text 67 | , "channel_id" >: Text 68 | , "channel_name" >: Text 69 | , "user_id" >: Text 70 | , "user_name" >: Text 71 | , "text" >: Text 72 | , "command" >: Text 73 | , "response_url" >: Text 74 | ] 75 | 76 | type DisplayLogData = Record 77 | '[ "team_domain" >: Text 78 | , "channel_name" >: Text 79 | , "user_name" >: Text 80 | , "text" >: Text 81 | , "command" >: Text 82 | ] 83 | 84 | verifySlashCmd :: HasSlackSlashCmdConfig env => SlashCmdData -> RIO env (Either Text ()) 85 | verifySlashCmd dat = do 86 | config <- askSlashCmdConfig 87 | pure $ if 88 | | dat ^. #token /= config ^. #verify_token -> Left "Invalid token..." 89 | | dat ^. #team_id /= config ^. #team_id -> Left "Invalid team..." 90 | | dat ^. #channel_id `notElem` config ^. #channel_ids -> Left "Invalid channel..." 91 | | dat ^. #command /= config ^. #reset_repo_cmd -> Left "Invalid command..." 92 | | otherwise -> pure () 93 | 94 | data SlashCmd 95 | 96 | instance Accept SlashCmd where 97 | contentType _ = "application" M.// "x-www-form-urlencoded" 98 | 99 | instance MimeUnrender SlashCmd (LByteString, SlashCmdData) where 100 | mimeUnrender _ bs = Text.unpack +++ (bs,) $ urlDecodeAsForm bs 101 | 102 | type Message = Record '[ "text" >: Text ] 103 | 104 | mkMessage :: Text -> Message 105 | mkMessage txt = #text @= txt <: nil 106 | 107 | respondMessage :: MonadIO m => SlashCmdData -> Message -> m () 108 | respondMessage postData message = do 109 | let url = Text.unpack $ postData ^. #response_url 110 | _ <- liftIO $ W.post url (J.toJSON message) 111 | pure () 112 | 113 | sendWebhook :: MonadIO m => Text -> Message -> m () 114 | sendWebhook url msg = 115 | liftIO (W.post (Text.unpack url) $ J.toJSON msg) >> pure () 116 | 117 | type NotifyConfig = Record 118 | '[ "api_token" >: ByteString 119 | , "channel_id" >: Text 120 | ] 121 | 122 | class HasSlackNotifyConfig env where 123 | slackNotifyConfigL :: Lens' env NotifyConfig 124 | 125 | instance Lookup xs "notify" NotifyConfig => HasSlackNotifyConfig (Record xs) where 126 | slackNotifyConfigL = lens (view #notify) (\x y -> x & #notify `set` y) 127 | 128 | askNotifyConfig :: HasSlackNotifyConfig env => RIO env NotifyConfig 129 | askNotifyConfig = view slackNotifyConfigL 130 | 131 | type SnipetMessage = Record 132 | '[ "content" >: Text 133 | , "filename" >: Text 134 | , "filetype" >: Text 135 | , "initial_comment" >: Text 136 | ] 137 | 138 | uploadFile :: (HasLogFunc env, HasSlackNotifyConfig env) => SnipetMessage -> RIO env () 139 | uploadFile msg = do 140 | config <- askNotifyConfig 141 | let opts = W.defaults 142 | & W.header "Content-Type" .~ ["application/x-www-form-urlencoded"] 143 | & W.header "Authorization" .~ ["Bearer " <> config ^. #api_token] 144 | dat = 145 | [ "content" W.:= msg ^. #content 146 | , "filename" W.:= msg ^. #filename 147 | , "filetype" W.:= msg ^. #filetype 148 | , "initial_comment" W.:= msg ^. #initial_comment 149 | , "channels" W.:= config ^. #channel_id 150 | ] 151 | _ <- liftIO (W.postWith opts "https://slack.com/api/files.upload" dat) 152 | pure () 153 | -------------------------------------------------------------------------------- /src/Git/Plantation/Job/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | 5 | module Git.Plantation.Job.Server 6 | ( ServerEnv 7 | , Error (..) 8 | , kickJob 9 | , enqueueJob 10 | , serveRunner 11 | , serveRunner' 12 | , migrate 13 | ) where 14 | 15 | import RIO 16 | import qualified RIO.List as List 17 | import qualified RIO.Text as Text 18 | 19 | import Data.Coerce (coerce) 20 | import Data.Extensible 21 | import Git.Plantation.Config (Config, askConfig) 22 | import Git.Plantation.Data.Job (Job) 23 | import qualified Git.Plantation.Data.Job as Job 24 | import Git.Plantation.Data.Problem (Problem) 25 | import qualified Git.Plantation.Data.Problem as Problem 26 | import qualified Git.Plantation.Data.Slack as Slack 27 | import Git.Plantation.Data.Team (Team) 28 | import qualified Git.Plantation.Data.Team as Team 29 | import qualified Git.Plantation.Data.User as User 30 | import qualified Git.Plantation.Job.Protocol as Protocol 31 | import qualified Git.Plantation.Job.Store as Store 32 | import qualified Git.Plantation.Job.Worker as Worker 33 | import qualified Mix.Plugin.Config as MixConfig 34 | import qualified Mix.Plugin.Persist.Sqlite as MixDB 35 | import qualified Network.WebSockets as WS 36 | 37 | data Error 38 | = ProblemIsNotFound Problem.Id 39 | | TeamIsNotFound Team.Id 40 | | UserIsNotFound User.GitHubId 41 | | WorkerIsNotExist 42 | | JobIsNotFound Job.Id 43 | deriving (Show, Eq) 44 | 45 | type ServerEnv env = 46 | ( Worker.HasWorkers env 47 | , Store.HasStore env 48 | , Slack.HasSlackNotifyConfig env 49 | , MixDB.HasSqliteConfig env 50 | , MixConfig.HasConfig Config env 51 | , HasLogFunc env 52 | ) 53 | 54 | kickJob :: ServerEnv env => Problem.Id -> Team.Id -> Maybe User.GitHubId -> RIO env (Either Error Job) 55 | kickJob pid tid uid = do 56 | config <- askConfig 57 | case (findProblem config pid, findTeam config tid) of 58 | (Nothing, _) -> 59 | pure $ Left (ProblemIsNotFound pid) 60 | (_, Nothing) -> 61 | pure $ Left (TeamIsNotFound tid) 62 | (Just _, Just _) -> do 63 | w <- Worker.getRandom 64 | case w of 65 | Nothing -> 66 | pure $ Left WorkerIsNotExist 67 | Just worker -> do 68 | job <- Job.create pid tid uid 69 | liftIO $ WS.sendBinaryData (worker ^. #conn) $ Protocol.Enqueue (job ^. #id) pid tid uid 70 | pure $ Right job 71 | 72 | enqueueJob :: ServerEnv env => Job.Id -> RIO env (Either Error Job) 73 | enqueueJob jid = do 74 | w <- Worker.getRandom 75 | j <- Job.findById jid 76 | case (w, j) of 77 | (Nothing, _) -> 78 | pure $ Left WorkerIsNotExist 79 | (_, Nothing) -> 80 | pure $ Left (JobIsNotFound jid) 81 | (Just worker, Just job) -> do 82 | let dat = Protocol.Enqueue jid (job ^. #problem) (job ^. #team) (job ^. #author) 83 | liftIO $ WS.sendBinaryData (worker ^. #conn) dat 84 | pure $ Right job 85 | 86 | serveRunner :: ServerEnv env => WS.Connection -> RIO env () 87 | serveRunner conn = do 88 | config <- askConfig 89 | worker <- Worker.connected conn 90 | logDebug $ "Connected worker " <> display (worker ^. #id) 91 | liftIO $ WS.sendBinaryData (worker ^. #conn) (Protocol.JobConfig $ shrink config) 92 | logDebug $ "Setuped worker " <> display (worker ^. #id) 93 | _ <- forever (receive worker) `finally` Worker.disconnected (worker ^. #id) 94 | logDebug $ "Disconnected worker " <> display (worker ^. #id) 95 | where 96 | receive worker = do 97 | p <- liftIO $ WS.receiveData (worker ^. #conn) 98 | case p of 99 | Protocol.JobRunning jid -> do 100 | _ <- Store.withStore $ Job.updateToRunning jid 101 | pure () 102 | Protocol.JobSuccess jid out err -> do 103 | let out' = Text.decodeUtf8With Text.lenientDecode out 104 | err' = Text.decodeUtf8With Text.lenientDecode err 105 | job <- Store.withStore $ Job.updateToSuccess jid out' err' 106 | notifySlack job 107 | Protocol.JobFailure jid out err -> do 108 | let out' = Text.decodeUtf8With Text.lenientDecode out 109 | err' = Text.decodeUtf8With Text.lenientDecode err 110 | job <- Store.withStore $ Job.updateToFailure jid out' err' 111 | notifySlack job 112 | _ -> 113 | pure () 114 | 115 | serveRunner' :: ServerEnv env => WS.PendingConnection -> RIO env () 116 | serveRunner' pending = serveRunner =<< liftIO (WS.acceptRequest pending) 117 | 118 | findProblem :: Config -> Problem.Id -> Maybe Problem 119 | findProblem config pid = List.find (\p -> p ^. #id == pid) $ config ^. #problems 120 | 121 | findTeam :: Config -> Team.Id -> Maybe Team 122 | findTeam config tid = List.find (\t -> t ^. #id == tid) $ config ^. #teams 123 | 124 | notifySlack :: ServerEnv env => Job -> RIO env () 125 | notifySlack job = do 126 | config <- askConfig 127 | case (findProblem config $ job ^. #problem, findTeam config $ job ^. #team) of 128 | (Just problem, Just team) -> 129 | Slack.uploadFile 130 | $ #content @= job ^. #stdout 131 | <: #filename @= coerce (team ^. #name) <> "-" <> coerce (problem ^. #name) <> "-log.txt" 132 | <: #filetype @= "text" 133 | <: #initial_comment @= mkMessage problem team 134 | <: nil 135 | (Nothing, _) -> 136 | logWarn "problem is not found when notify slack" 137 | (_, Nothing) -> 138 | logWarn "team is not found when notify slack" 139 | where 140 | mkMessage problem team = mconcat $ 141 | if job ^. #success then 142 | [ "チーム ", coerce $ team ^. #name, " が ", coerce $ problem ^. #name," を正解したみたいだよ！すごーい！！" ] 143 | else 144 | [ "チーム ", coerce $ team ^. #name, " の ", coerce $ problem ^. #name," は不正解だね...残念！" ] 145 | 146 | migrate :: (MixDB.HasSqliteConfig env, HasLogFunc env) => RIO env () 147 | migrate = do 148 | (MixDB.Config config) <- asks (view MixDB.configL) 149 | let connName = config ^. (#info . MixDB.sqlConnectionStr) 150 | logInfo (display $ "Migate SQLite: " <> connName) 151 | MixDB.runMigrate Job.migrateAll 152 | -------------------------------------------------------------------------------- /src/Git/Plantation/Data/Job.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NumericUnderscores #-} 7 | {-# LANGUAGE OverloadedLabels #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Git.Plantation.Data.Job where 16 | 17 | import RIO 18 | import qualified RIO.List as List 19 | import RIO.Time 20 | 21 | import Data.Aeson (FromJSON, ToJSON) 22 | import Data.Binary (Binary) 23 | import Data.Coerce (coerce) 24 | import Data.Extensible 25 | import Database.Esqueleto.Experimental hiding (set, (^.)) 26 | import qualified Database.Persist as Persist 27 | import Database.Persist.TH 28 | import Git.Plantation.Data.Problem (Problem) 29 | import qualified Git.Plantation.Data.Problem as Problem 30 | import Git.Plantation.Data.Team (Team) 31 | import qualified Git.Plantation.Data.Team as Team 32 | import Git.Plantation.Data.User (User) 33 | import qualified Git.Plantation.Data.User as User 34 | import qualified Mix.Plugin.Persist.Sqlite as MixDB 35 | import Web.HttpApiData (FromHttpApiData) 36 | 37 | newtype Id = Id Int64 38 | deriving newtype (Show, Eq, Ord, Num, Binary, FromJSON, ToJSON, FromHttpApiData, Display) 39 | 40 | type Job = Record 41 | '[ "id" >: Id 42 | , "problem" >: Problem.Id 43 | , "team" >: Team.Id 44 | , "author" >: Maybe User.GitHubId 45 | , "queuing" >: Bool 46 | , "running" >: Bool 47 | , "success" >: Bool 48 | , "stdout" >: Text 49 | , "stderr" >: Text 50 | , "created" >: Int64 51 | ] 52 | 53 | new :: Problem.Id -> Team.Id -> Maybe User.GitHubId -> Id -> Job 54 | new pid tid uid jid 55 | = #id @= jid 56 | <: #problem @= pid 57 | <: #team @= tid 58 | <: #author @= uid 59 | <: #queuing @= True 60 | <: #running @= False 61 | <: #success @= False 62 | <: #stdout @= "" 63 | <: #stderr @= "" 64 | <: #created @= 0 65 | <: nil 66 | 67 | type Config = Record 68 | '[ "problems" >: [Problem] 69 | , "teams" >: [Team] 70 | , "image" >: Text 71 | ] 72 | 73 | emptyConfig :: Config 74 | emptyConfig 75 | = #problems @= mempty 76 | <: #teams @= mempty 77 | <: #image @= mempty 78 | <: nil 79 | 80 | findProblem :: Config -> Job -> Maybe Problem 81 | findProblem config job = 82 | List.find (\p -> p ^. #id == job ^. #problem) $ config ^. #problems 83 | 84 | findTeam :: Config -> Job -> Maybe Team 85 | findTeam config job = 86 | List.find (\t -> t ^. #id == job ^. #team) $ config ^. #teams 87 | 88 | findUser :: Team -> Job -> Maybe User 89 | findUser team job = 90 | case job ^. #author of 91 | Nothing -> Nothing 92 | Just author -> List.find (\u -> u ^. #github == author) $ team ^. #member 93 | 94 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 95 | JobData 96 | problem Int 97 | team Text 98 | author Text Maybe 99 | queuing Bool 100 | running Bool 101 | success Bool 102 | stdout Text 103 | stderr Text 104 | created UTCTime default=CURRENT_TIME 105 | updated UTCTime default=CURRENT_TIME 106 | deriving Show 107 | |] 108 | 109 | fromData :: Int64 -> JobData -> Job 110 | fromData jid JobData{..} 111 | = #id @= coerce jid 112 | <: #problem @= coerce jobDataProblem 113 | <: #team @= coerce jobDataTeam 114 | <: #author @= coerce jobDataAuthor 115 | <: #queuing @= jobDataQueuing 116 | <: #running @= jobDataRunning 117 | <: #success @= jobDataSuccess 118 | <: #stdout @= jobDataStdout 119 | <: #stderr @= jobDataStderr 120 | <: #created @= utcTimeToInt64 jobDataCreated 121 | <: nil 122 | 123 | utcTimeToInt64 :: UTCTime -> Int64 124 | utcTimeToInt64 (UTCTime (ModifiedJulianDay d) t) 125 | = 86400 * (fromIntegral d - unixEpochDay) 126 | + fromIntegral (diffTimeToPicoseconds t) `div` 1_000_000_000_000 127 | where 128 | unixEpochDay = 40587 129 | 130 | type SQLitable m env = (MixDB.HasSqliteConfig env, HasLogFunc env, MonadReader env m, MonadUnliftIO m) 131 | 132 | create :: SQLitable m env => Problem.Id -> Team.Id -> Maybe User.GitHubId -> m Job 133 | create pid tid uid = MixDB.run $ do 134 | currentTime <- getCurrentTime 135 | let dat = JobData 136 | (coerce $ job ^. #problem) 137 | (coerce $ job ^. #team) 138 | (coerce $ job ^. #author) 139 | (job ^. #queuing) 140 | (job ^. #running) 141 | (job ^. #success) 142 | (job ^. #stdout) 143 | (job ^. #stderr) 144 | currentTime 145 | currentTime 146 | jid <- insert dat 147 | pure $ job & #id `set` coerce jid 148 | where 149 | job = new pid tid uid 0 150 | 151 | updateToRunning :: SQLitable m env => Id -> m Job 152 | updateToRunning jid = 153 | MixDB.run $ fromData (coerce jid) <$> updateGet (toSqlKey $ coerce jid) 154 | [ JobDataQueuing Persist.=. False 155 | , JobDataRunning Persist.=. True 156 | ] 157 | 158 | updateToSuccess, updateToFailure :: SQLitable m env => Id -> Text -> Text -> m Job 159 | updateToSuccess jid out err = 160 | MixDB.run $ fromData (coerce jid) <$> updateGet (toSqlKey $ coerce jid) 161 | [ JobDataRunning Persist.=. False 162 | , JobDataSuccess Persist.=. True 163 | , JobDataStdout Persist.=. out 164 | , JobDataStderr Persist.=. err 165 | ] 166 | updateToFailure jid out err = 167 | MixDB.run $ fromData (coerce jid) <$> updateGet (toSqlKey $ coerce jid) 168 | [ JobDataRunning Persist.=. False 169 | , JobDataSuccess Persist.=. False 170 | , JobDataStdout Persist.=. out 171 | , JobDataStderr Persist.=. err 172 | ] 173 | 174 | selectAll :: SQLitable m env => m [Job] 175 | selectAll = MixDB.run $ do 176 | jobs <- select $ from $ table @JobData 177 | pure $ map (\dat -> fromData (fromSqlKey $ entityKey dat) $ entityVal dat) jobs 178 | 179 | findById :: SQLitable m env => Id -> m (Maybe Job) 180 | findById jid = 181 | MixDB.run $ fmap (fromData $ coerce jid) <$> get (toSqlKey $ coerce jid) 182 | -------------------------------------------------------------------------------- /elm-src/Pages/Graph.elm: -------------------------------------------------------------------------------- 1 | module Pages.Graph exposing (Model, Msg(..), init, update, view) 2 | 3 | import Color exposing (Color) 4 | import Dict 5 | import Generated.API as API exposing (..) 6 | import Html exposing (..) 7 | import Html.Attributes exposing (style) 8 | import LineChart 9 | import LineChart.Area as Area 10 | import LineChart.Axis as Axis 11 | import LineChart.Axis.Intersection as Intersection 12 | import LineChart.Axis.Line as AxisLine 13 | import LineChart.Axis.Range as Range 14 | import LineChart.Axis.Ticks as Ticks 15 | import LineChart.Axis.Title as Title 16 | import LineChart.Colors as Colors 17 | import LineChart.Container as Container 18 | import LineChart.Coordinate as Coordinate 19 | import LineChart.Dots as Dots 20 | import LineChart.Events as Events 21 | import LineChart.Grid as Grid 22 | import LineChart.Interpolation as Interpolation 23 | import LineChart.Junk as Junk 24 | import LineChart.Legends as Legends 25 | import LineChart.Line as Line 26 | import List.Extra as List 27 | import Palette.Cubehelix as Palette 28 | import Palette.Tango as Palette 29 | import Score exposing (Score) 30 | import Time exposing (Posix, Zone) 31 | import TimeZone 32 | 33 | 34 | type alias Global a = 35 | { a 36 | | config : API.ScoreBoardConfig 37 | , scores : List Score 38 | } 39 | 40 | 41 | type alias Model = 42 | { zone : Zone 43 | , hinted : Maybe ScoreHistory 44 | } 45 | 46 | 47 | type alias ScoreHistory = 48 | { point : Int 49 | , latest : Maybe Score.Status 50 | } 51 | 52 | 53 | type Msg 54 | = Hint (Maybe ScoreHistory) 55 | 56 | 57 | init : Global a -> Model 58 | init model = 59 | let 60 | zone = 61 | model.config.zone 62 | |> Maybe.andThen (\k -> Dict.get k TimeZone.zones) 63 | |> Maybe.withDefault (\_ -> Time.utc) 64 | in 65 | { hinted = Nothing, zone = zone () } 66 | 67 | 68 | update : Msg -> Model -> ( Model, Cmd Msg ) 69 | update msg model = 70 | case msg of 71 | Hint point -> 72 | ( { model | hinted = point }, Cmd.none ) 73 | 74 | 75 | view : Global a -> Model -> Html Msg 76 | view global model = 77 | Html.div [ style "margin-top" "1em" ] [ chart global model ] 78 | 79 | 80 | chart : Global a -> Model -> Html Msg 81 | chart global model = 82 | LineChart.viewCustom 83 | { y = 84 | Axis.custom 85 | { title = Title.default "Point" 86 | , variable = Just << toFloat << .point 87 | , pixels = 380 88 | , range = Range.padded 20 20 89 | , axisLine = AxisLine.full Colors.gray 90 | , ticks = Ticks.float 5 91 | } 92 | , x = 93 | Axis.custom 94 | { title = Title.default "Time" 95 | , variable = Maybe.map toFloat << Maybe.map (\n -> n * 1000) << Maybe.map .correctTime << .latest 96 | , pixels = 1270 97 | , range = Range.padded 20 20 98 | , axisLine = AxisLine.full Colors.gray 99 | , ticks = Ticks.time model.zone 10 100 | } 101 | , container = 102 | Container.custom 103 | { attributesHtml = [] 104 | , attributesSvg = [] 105 | , size = Container.relative 106 | , margin = Container.Margin 30 140 30 70 107 | , id = "line-chart-stepped" 108 | } 109 | , interpolation = Interpolation.stepped 110 | , intersection = Intersection.default 111 | , legends = Legends.default 112 | , events = Events.hoverOne Hint 113 | , junk = 114 | Junk.hoverOne model.hinted 115 | [ ( "Problem", Maybe.withDefault "" << Maybe.map .problemName << .latest ) 116 | , ( "Time", toCorrectTime model.zone ) 117 | ] 118 | , grid = Grid.default 119 | , area = Area.default 120 | , line = Line.default 121 | , dots = 122 | let 123 | styleLegend _ = 124 | Dots.empty 5 1 125 | 126 | styleIndividual datum = 127 | if Just datum == model.hinted then 128 | Dots.full 5 129 | 130 | else 131 | Dots.empty 5 1 132 | in 133 | Dots.customAny 134 | { legend = styleLegend 135 | , individual = styleIndividual 136 | } 137 | } 138 | (buildData global.scores) 139 | 140 | 141 | buildData : List Score -> List (LineChart.Series ScoreHistory) 142 | buildData scores = 143 | let 144 | colors = 145 | Palette.generateAdvanced (List.length scores + 4) 146 | { start = Color.fromHSL ( 0, 100, 50 ) 147 | , rotationDirection = Palette.RGB 148 | , rotations = 1.5 149 | , gamma = 1.2 150 | } 151 | |> List.drop 2 152 | |> List.take (List.length scores) 153 | in 154 | List.sortBy (.name << .team) scores 155 | |> List.map2 buildScoreHistories colors 156 | 157 | 158 | buildScoreHistories : Color -> Score -> LineChart.Series ScoreHistory 159 | buildScoreHistories color score = 160 | score.stats 161 | |> List.filter (\s -> s.state == Score.Correct) 162 | |> List.sortBy .correctTime 163 | |> List.scanl (::) [] 164 | |> List.map buildScoreHistory 165 | |> LineChart.line color Dots.circle score.team.name 166 | 167 | 168 | buildScoreHistory : List Score.Status -> ScoreHistory 169 | buildScoreHistory stats = 170 | { point = List.sum (List.map .difficulty stats) 171 | , latest = List.head stats 172 | } 173 | 174 | 175 | toCorrectTime : Zone -> ScoreHistory -> String 176 | toCorrectTime zone score = 177 | let 178 | time = 179 | score.latest 180 | |> Maybe.map .correctTime 181 | |> Maybe.map (\n -> n * 1000) 182 | |> Maybe.map Time.millisToPosix 183 | in 184 | String.concat 185 | [ Maybe.map (Time.toHour zone) time 186 | |> Maybe.withDefault 0 187 | |> String.fromInt 188 | |> String.padLeft 2 '0' 189 | , ":" 190 | , Maybe.map (Time.toMinute zone) time 191 | |> Maybe.withDefault 0 192 | |> String.fromInt 193 | |> String.padLeft 2 '0' 194 | , ":" 195 | , Maybe.map (Time.toSecond zone) time 196 | |> Maybe.withDefault 0 197 | |> String.fromInt 198 | |> String.padLeft 2 '0' 199 | ] 200 | -------------------------------------------------------------------------------- /src/Git/Plantation/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedLabels #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Git.Plantation.API where 10 | 11 | import RIO 12 | import qualified RIO.Text as T 13 | 14 | import qualified Crypto.Hash as Hash 15 | import qualified Crypto.Random as Random 16 | import qualified Data.Aeson.Text as Json 17 | import Data.Coerce (coerce) 18 | import Data.Extensible 19 | import Data.Fallible 20 | import Git.Plantation.API.CRUD (GetAPI, getAPI) 21 | import qualified Git.Plantation.API.GitHub as GitHub 22 | import qualified Git.Plantation.API.Slack as Slack 23 | import qualified Git.Plantation.Auth.GitHub as Auth 24 | import qualified Git.Plantation.Data.User as User 25 | import Git.Plantation.Env (Plant) 26 | import qualified GitHub 27 | import Servant 28 | import Servant.Auth.Server (Auth) 29 | import qualified Servant.Auth.Server as Auth 30 | import Servant.HTML.Blaze 31 | import Text.Blaze.Html5 ((!)) 32 | import qualified Text.Blaze.Html5 as H 33 | import qualified Text.Blaze.Html5.Attributes as H 34 | 35 | type LoginPageSession = Record 36 | '[ "state" >: Text 37 | , "salt" >: Text 38 | ] 39 | 40 | newSession :: MonadIO m => m LoginPageSession 41 | newSession = do 42 | gen <- liftIO Random.drgNew 43 | let (stat, gen') = randomGenerateBS gen 44 | (salt, _) = randomGenerateBS gen' 45 | pure $ #state @= tshow (Hash.hash stat :: Hash.Digest Hash.SHA256) 46 | <: #salt @= tshow (Hash.hash salt :: Hash.Digest Hash.SHA256) 47 | <: nil 48 | where 49 | randomGenerateBS :: Random.ChaChaDRG -> (ByteString, Random.ChaChaDRG) 50 | randomGenerateBS = Random.randomBytesGenerate 32 51 | 52 | toState :: LoginPageSession -> String 53 | toState session = T.unpack $ session ^. #state 54 | 55 | type Account = Record '[ "login" >: User.GitHubId ] 56 | 57 | toAccount :: GitHub.User -> Account 58 | toAccount user = #login @= coerce (GitHub.untagName $ GitHub.userLogin user) <: nil 59 | 60 | type API 61 | = LoginPage 62 | :<|> (Auth '[Auth.Cookie] LoginPageSession :> LoginCollback) 63 | :<|> (Auth '[Auth.Cookie] Account :> Protected) 64 | :<|> Unprotected 65 | 66 | type LoginPage 67 | = "login" :> Get '[HTML] (Headers JWTCookieHeaders H.Html) 68 | 69 | type LoginCollback 70 | = "callback" 71 | :> QueryParam "code" String 72 | :> QueryParam "state" String 73 | :> GetRedirected JWTCookieHeaders 74 | 75 | type Protected = "api" :> GetAPI :<|> Index 76 | 77 | type Index 78 | = Get '[HTML] H.Html 79 | :<|> "graph" :> Get '[HTML] H.Html 80 | :<|> "teams" :> Capture "id" Text :> Get '[HTML] H.Html 81 | :<|> "teams" :> Capture "id" Text :> Capture "user" Text :> Get '[HTML] H.Html 82 | 83 | type Unprotected 84 | = "static" :> Raw 85 | :<|> "hook" :> GitHub.WebhookAPI 86 | :<|> "slash" :> Slack.SlashCmdAPI 87 | 88 | type GetRedirected headers = 89 | Verb 'GET 303 '[HTML] (Headers (Header "Location" String ': headers) NoContent) 90 | 91 | type JWTCookieHeaders = 92 | '[ Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie ] 93 | 94 | api :: Proxy API 95 | api = Proxy 96 | 97 | type LoginConfig = Record 98 | '[ "whitelist" >: [User.GitHubId] 99 | , "allow_guest" >: Bool 100 | ] 101 | 102 | server :: LoginConfig -> ServerT API Plant 103 | server config 104 | = loginPage 105 | :<|> callback 106 | :<|> protected config 107 | :<|> serveDirectoryFileServer "static" 108 | :<|> GitHub.webhook 109 | :<|> Slack.slashCmdApi 110 | 111 | loginPage :: Plant (Headers JWTCookieHeaders H.Html) 112 | loginPage = evalContT $ do 113 | config <- asks (view #oauth) 114 | session <- lift newSession 115 | applyCookies <- acceptLogin' config session !?? exit throw401 116 | let url = fromString $ Auth.authorizeUrl config (toState session) 117 | pure $ applyCookies (loginHtml url) 118 | where 119 | loginHtml loginUrl = 120 | H.docTypeHtml $ do 121 | H.head $ do 122 | stylesheet "https://unpkg.com/@primer/css@13.2.0/dist/primer.css" 123 | stylesheet "https://use.fontawesome.com/releases/v5.2.0/css/all.css" 124 | H.div ! H.class_ "m-3" $ 125 | H.a ! H.href loginUrl $ "Login by GitHub" 126 | acceptLogin' conf = liftIO . Auth.acceptLogin (conf ^. #cookie) (conf ^. #jwt) 127 | throw401 = Auth.throwAll err401 128 | 129 | callback 130 | :: Auth.AuthResult LoginPageSession 131 | -> Maybe String 132 | -> Maybe String 133 | -> Plant (Headers (Header "Location" String ': JWTCookieHeaders) NoContent) 134 | callback auth code state = 135 | case auth of 136 | Auth.Authenticated s | Just (toState s) == state -> do 137 | logDebug $ fromString ("[GET] /callback: " <> toState s) 138 | callback' 139 | _ -> do 140 | logWarn "[GET] /callback: no session" 141 | throw401 142 | where 143 | callback' = evalContT $ do 144 | code' <- code ??? exit throw401 145 | config <- asks (view #oauth) 146 | token <- lift $ Auth.fetchToken config code' 147 | user <- lift (Auth.fetchUser token) !?= const (exit throw401) 148 | applyCookies <- acceptLogin' config (toAccount user) !?? exit throw401 149 | pure $ addHeader "/" (applyCookies NoContent) 150 | acceptLogin' conf = liftIO . Auth.acceptLogin (conf ^. #cookie) (conf ^. #jwt) 151 | throw401 = Auth.throwAll err401 152 | 153 | protected :: LoginConfig -> Auth.AuthResult Account -> ServerT Protected Plant 154 | protected config = \case 155 | Auth.Authenticated a | a ^. #login `elem` config ^. #whitelist -> 156 | getAPI :<|> index 157 | Auth.Indefinite | config ^. #allow_guest -> 158 | getAPI :<|> index 159 | Auth.Indefinite -> 160 | Auth.throwAll login 161 | _ -> 162 | Auth.throwAll err401 163 | where 164 | index = indexHtml :<|> indexHtml :<|> const indexHtml :<|> (\_ _ -> indexHtml) 165 | login = err303 { errHeaders = [("Location", "/login")] } 166 | 167 | indexHtml :: Plant H.Html 168 | indexHtml = do 169 | config <- asks (view #config) 170 | pure $ H.docTypeHtml $ do 171 | H.head $ do 172 | stylesheet "https://unpkg.com/@primer/css@13.2.0/dist/primer.css" 173 | stylesheet "https://use.fontawesome.com/releases/v5.2.0/css/all.css" 174 | H.div ! H.id "main" $ H.text "" 175 | H.script ! H.type_ "application/json" ! H.id "config" $ 176 | H.preEscapedLazyText (Json.encodeToLazyText config) 177 | H.script ! H.src "/static/main.js" $ H.text "" 178 | H.script ! H.src "/static/index.js" $ H.text "" 179 | 180 | stylesheet :: H.AttributeValue -> H.Html 181 | stylesheet url = 182 | H.link ! H.rel "stylesheet" ! H.type_ "text/css" ! H.href url ! H.media "all" 183 | 184 | redirectTo :: AddHeader "Location" String NoContent a => String -> a 185 | redirectTo url = addHeader url NoContent 186 | -------------------------------------------------------------------------------- /exec/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 10 | 11 | module Main where 12 | 13 | import Paths_git_plantation (version) 14 | import RIO hiding (catch) 15 | import qualified RIO.ByteString as B 16 | import qualified RIO.Text as Text 17 | import qualified RIO.Time as Time 18 | 19 | import Configuration.Dotenv (defaultConfig, loadFile) 20 | import Control.Monad.Catch (catch) 21 | import Data.Extensible 22 | import Data.Extensible.GetOpt 23 | import Data.Version (Version) 24 | import qualified Data.Version as Version 25 | import Development.GitRev 26 | import Git.Plantation 27 | import Git.Plantation.API (LoginConfig, api, server) 28 | import qualified Mix.Plugin as Mix (withPlugin) 29 | import qualified Mix.Plugin.GitHub as MixGitHub 30 | import qualified Mix.Plugin.Logger as MixLogger 31 | import qualified Mix.Plugin.Shell as MixShell 32 | import qualified Network.Wai.Handler.Warp as Warp 33 | import Servant 34 | import qualified Servant.Auth.Server as Auth 35 | import qualified Servant.GitHub.Webhook (GitHubKey, gitHubKey) 36 | import System.Environment (getEnv) 37 | 38 | import Orphans () 39 | 40 | main :: IO () 41 | main = withGetOpt "[options] [config-file]" opts $ \r args -> do 42 | _ <- tryIO $ loadFile defaultConfig 43 | if r ^. #version then 44 | B.putStr $ fromString (showVersion version) <> "\n" 45 | else 46 | case listToMaybe args of 47 | Nothing -> error "please input config file path." 48 | Just path -> runServer r =<< readConfig path 49 | where 50 | opts = #port @= portOpt 51 | <: #work @= workOpt 52 | <: #guest @= guestOpt 53 | <: #verbose @= verboseOpt 54 | <: #version @= versionOpt 55 | <: nil 56 | 57 | type Options = Record 58 | '[ "port" >: Int 59 | , "work" >: FilePath 60 | , "guest" >: Bool 61 | , "verbose" >: Bool 62 | , "version" >: Bool 63 | ] 64 | 65 | portOpt :: OptDescr' Int 66 | portOpt = optionReqArg 67 | (pure . fromMaybe 8080 . (readMaybe <=< listToMaybe)) 68 | ['p'] ["port"] "PORT" "Set port to PORT instead of 8080." 69 | 70 | workOpt :: OptDescr' FilePath 71 | workOpt = optionReqArg 72 | (pure . fromMaybe ".temp" . listToMaybe) 73 | [] ["work"] "DIR" "Set workdir to DIR instead of ./.temp" 74 | 75 | guestOpt :: OptDescr' Bool 76 | guestOpt = optFlag [] ["guest"] "Allow guest mode" 77 | 78 | verboseOpt :: OptDescr' Bool 79 | verboseOpt = optFlag ['v'] ["verbose"] "Enable verbose mode: verbosity level \"debug\"" 80 | 81 | versionOpt :: OptDescr' Bool 82 | versionOpt = optFlag [] ["version"] "Show version" 83 | 84 | runServer :: Options -> Config -> IO () 85 | runServer opts config = do 86 | token <- liftIO $ fromString <$> getEnv "GH_TOKEN" 87 | ghUser <- liftIO $ fromString <$> getEnv "GH_USER" 88 | sSignSecret <- liftIO $ fromString <$> getEnv "SLACK_SIGNING_SECRET" 89 | sVerifyToken <- liftIO $ fromString <$> getEnv "SLACK_VERIFY_TOKEN" 90 | slashTeam <- liftIO $ fromString <$> getEnv "SLACK_SLASH_TEAM_ID" 91 | slashChannels <- liftIO $ readListEnv <$> getEnv "SLACK_SLASH_CHANNEL_IDS" 92 | sResetRepoCmd <- liftIO $ fromString <$> getEnv "SLACK_SLASH_RESET_REPO_CMD" 93 | slashWebhook <- liftIO $ fromString <$> getEnv "SLACK_SLASH_WEBHOOK" 94 | sPushWebhook <- liftIO $ fromString <$> getEnv "SLACK_PUSH_NOTIFY_WEBHOOK" 95 | clientId <- liftIO $ fromString <$> getEnv "AUTHN_CLIENT_ID" 96 | clientSecret <- liftIO $ fromString <$> getEnv "AUTHN_CLIENT_SECRET" 97 | jobserverHost <- liftIO $ getEnv "JOBSERVER_HOST" 98 | jwtSettings <- Auth.defaultJWTSettings <$> Auth.generateKey 99 | let logConf = #handle @= stdout <: #verbose @= (opts ^. #verbose) <: nil 100 | slashConf 101 | = #signing_secret @= sSignSecret 102 | <: #verify_token @= sVerifyToken 103 | <: #team_id @= slashTeam 104 | <: #channel_ids @= slashChannels 105 | <: #reset_repo_cmd @= sResetRepoCmd 106 | <: #webhook @= Just slashWebhook 107 | <: nil 108 | oauthConf 109 | = #client_id @= clientId 110 | <: #client_secret @= clientSecret 111 | <: #cookie @= cookieSettings 112 | <: #jwt @= jwtSettings 113 | <: nil 114 | plugin = hsequence 115 | $ #config <@=> pure config 116 | <: #github <@=> MixGitHub.buildPlugin token 117 | <: #gh_user <@=> pure ghUser 118 | <: #slack <@=> pure sPushWebhook 119 | <: #slash <@=> pure slashConf 120 | <: #work <@=> MixShell.buildPlugin (opts ^. #work) 121 | <: #webhook <@=> pure mempty 122 | <: #jobserver <@=> pure jobserverHost 123 | <: #logger <@=> MixLogger.buildPlugin logConf 124 | <: #oauth <@=> pure oauthConf 125 | <: nil 126 | B.putStr $ "Listening on port " <> (fromString . show) (opts ^. #port) <> "\n" 127 | flip Mix.withPlugin plugin $ \env -> do 128 | let key = gitHubKey $ fromString <$> getEnv "GH_SECRET" 129 | loginConf 130 | = #whitelist @= mkAuthnWhitelist (env ^. #config) 131 | <: #allow_guest @= opts ^. #guest 132 | <: nil 133 | Warp.run (opts ^. #port) (app loginConf env cookieSettings jwtSettings key) 134 | where 135 | cookieSettings = Auth.defaultCookieSettings 136 | { Auth.cookieMaxAge = Just $ Time.secondsToDiffTime (3 * 60) 137 | , Auth.cookieXsrfSetting = Nothing 138 | } 139 | 140 | app :: LoginConfig -> Env -> Auth.CookieSettings -> Auth.JWTSettings -> GitHubKey -> Application 141 | app loginConfig env cookie jwt key = 142 | serveWithContext api (cookie :. jwt :. key :. EmptyContext) $ 143 | hoistServerWithContext api context 144 | (\x -> runRIO env x `catch` throwError) (server loginConfig) 145 | 146 | context :: Proxy '[ Auth.CookieSettings, Auth.JWTSettings, GitHubKey ] 147 | context = Proxy 148 | 149 | showVersion :: Version -> String 150 | showVersion v = unwords 151 | [ "Version" 152 | , Version.showVersion v ++ "," 153 | , "Git revision" 154 | , $(gitHash) 155 | , "(" ++ $(gitCommitCount) ++ " commits)" 156 | ] 157 | 158 | readListEnv :: Read a => String -> [a] 159 | readListEnv = mapMaybe (readMaybe . show) . Text.split (== ',') . fromString 160 | 161 | -- HACK 162 | newtype GitHubKey = GitHubKey (forall result. Servant.GitHub.Webhook.GitHubKey result) 163 | 164 | gitHubKey :: IO ByteString -> GitHubKey 165 | gitHubKey k = GitHubKey (Servant.GitHub.Webhook.gitHubKey k) 166 | 167 | instance HasContextEntry '[GitHubKey] (Servant.GitHub.Webhook.GitHubKey result) where 168 | getContextEntry (GitHubKey x :. _) = x 169 | -------------------------------------------------------------------------------- /elm-src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (main) 2 | 3 | import Browser as Browser 4 | import Browser.Navigation as Nav 5 | import Generated.API as API exposing (..) 6 | import Html exposing (..) 7 | import Html.Attributes exposing (checked, class, href, id, style, type_) 8 | import Html.Events exposing (onCheck) 9 | import Http 10 | import Pages.Board as Board 11 | import Pages.Graph as Graph 12 | import Pages.Player as Player 13 | import Pages.Team as Team 14 | import Score exposing (Score) 15 | import Time exposing (Posix) 16 | import Url 17 | import Url.Parser as Parser exposing ((), Parser, oneOf, top) 18 | 19 | 20 | main = 21 | Browser.application 22 | { init = init 23 | , view = view 24 | , update = update 25 | , subscriptions = subscriptions 26 | , onUrlRequest = LinkClicked 27 | , onUrlChange = UrlChanged 28 | } 29 | 30 | 31 | type alias Model = 32 | { key : Nav.Key 33 | , page : Page 34 | , config : API.ScoreBoardConfig 35 | , problems : List API.Problem 36 | , scores : List Score 37 | , reload : Bool 38 | } 39 | 40 | 41 | type Page 42 | = Home -- Board 43 | | Graph Graph.Model 44 | | Team Team.Model 45 | | Player Player.Model 46 | 47 | 48 | type Msg 49 | = LinkClicked Browser.UrlRequest 50 | | UrlChanged Url.Url 51 | | CheckReload Bool 52 | | Tick Posix 53 | | FetchScores (Result Http.Error (List API.Score)) 54 | | GraphMsg Graph.Msg 55 | | TeamMsg Team.Msg 56 | | PlayerMsg Player.Msg 57 | 58 | 59 | init : { config : API.Config } -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) 60 | init { config } url key = 61 | stepUrl url 62 | { key = key 63 | , page = Home 64 | , config = config.scoreboard 65 | , reload = True 66 | , problems = config.problems 67 | , scores = Score.build config [] 68 | } 69 | 70 | 71 | stepUrl : Url.Url -> Model -> ( Model, Cmd Msg ) 72 | stepUrl url model = 73 | let 74 | parser = 75 | oneOf 76 | [ route top 77 | { model | page = Home } 78 | , route (Parser.s "graph") 79 | { model | page = Graph (Graph.init model) } 80 | , route (Parser.s "teams" Parser.string) 81 | (\id -> { model | page = Team (Team.init model id) }) 82 | , route (Parser.s "teams" Parser.string Parser.string) 83 | (\teamID id -> { model | page = Player (Player.init model teamID id) }) 84 | ] 85 | in 86 | case Parser.parse parser url of 87 | Just answer -> 88 | answer |> stepScores 89 | 90 | Nothing -> 91 | ( model, Cmd.none ) 92 | 93 | 94 | stepScores : Model -> ( Model, Cmd Msg ) 95 | stepScores model = 96 | case model.page of 97 | Home -> 98 | ( model, API.getApiScores FetchScores ) 99 | 100 | Graph _ -> 101 | ( model, API.getApiScores FetchScores ) 102 | 103 | Team local -> 104 | ( model, API.getApiScoresByTeam local.id FetchScores ) 105 | 106 | Player local -> 107 | ( model, API.getApiScoresByTeamByPlayer local.teamID local.id FetchScores ) 108 | 109 | 110 | route : Parser a b -> a -> Parser (b -> c) c 111 | route parser handler = 112 | Parser.map handler parser 113 | 114 | 115 | stepPageWith : ( model -> Page, msg -> Msg ) -> Model -> ( model, Cmd msg ) -> ( Model, Cmd Msg ) 116 | stepPageWith ( toPage, toMsg ) model ( local, msg ) = 117 | ( { model | page = toPage local }, Cmd.map toMsg msg ) 118 | 119 | 120 | update : Msg -> Model -> ( Model, Cmd Msg ) 121 | update message model = 122 | case message of 123 | LinkClicked (Browser.Internal url) -> 124 | ( model, Nav.pushUrl model.key (Url.toString url) ) 125 | 126 | LinkClicked (Browser.External href) -> 127 | ( model, Nav.load href ) 128 | 129 | UrlChanged url -> 130 | stepUrl url model 131 | 132 | CheckReload reload -> 133 | ( { model | reload = reload }, Cmd.none ) 134 | 135 | Tick _ -> 136 | if model.reload then 137 | stepScores model 138 | 139 | else 140 | ( model, Cmd.none ) 141 | 142 | FetchScores (Ok resp) -> 143 | ( { model | scores = Score.updateBy resp model.scores }, Cmd.none ) 144 | 145 | FetchScores (Err _) -> 146 | ( model, Cmd.none ) 147 | 148 | GraphMsg msg -> 149 | case model.page of 150 | Graph local -> 151 | stepPageWith ( Graph, GraphMsg ) model (Graph.update msg local) 152 | 153 | _ -> 154 | ( model, Cmd.none ) 155 | 156 | TeamMsg msg -> 157 | case model.page of 158 | Team local -> 159 | stepPageWith ( Team, TeamMsg ) model (Team.update msg local) 160 | 161 | _ -> 162 | ( model, Cmd.none ) 163 | 164 | PlayerMsg msg -> 165 | case model.page of 166 | Player local -> 167 | stepPageWith ( Player, PlayerMsg ) model (Player.update msg local) 168 | 169 | _ -> 170 | ( model, Cmd.none ) 171 | 172 | 173 | subscriptions : Model -> Sub Msg 174 | subscriptions model = 175 | Time.every model.config.interval Tick 176 | 177 | 178 | view : Model -> Browser.Document Msg 179 | view model = 180 | { title = "Git Challenge ScoreBoard" 181 | , body = viewBody model 182 | } 183 | 184 | 185 | viewBody : Model -> List (Html Msg) 186 | viewBody model = 187 | [ div [ class "my-3 mx-auto col-10" ] 188 | [ div [ class "Header" ] 189 | [ div [ class "Header-item Header-item--full" ] 190 | [ a [ class "Header-link", href "/" ] 191 | [ h2 [] [ text "Git Challenge ScoreBoard" ] ] 192 | ] 193 | , div [ class "Header-item" ] 194 | [ a [ class "Header-link", href "/graph" ] 195 | [ text "Graph" ] 196 | ] 197 | , div [ class "Header-item mr-0" ] [ viewCheckReload model ] 198 | ] 199 | , viewPage model 200 | ] 201 | ] 202 | 203 | 204 | viewCheckReload : Model -> Html Msg 205 | viewCheckReload model = 206 | form [] 207 | [ div [ class "form-checkbox" ] 208 | [ label [] 209 | [ input 210 | [ type_ "checkbox" 211 | , checked model.reload 212 | , onCheck CheckReload 213 | ] 214 | [] 215 | , text "Auto Reload" 216 | ] 217 | ] 218 | ] 219 | 220 | 221 | viewPage : Model -> Html Msg 222 | viewPage model = 223 | case model.page of 224 | Home -> 225 | Board.view model 226 | 227 | Graph local -> 228 | Html.map GraphMsg (Graph.view model local) 229 | 230 | Team local -> 231 | Html.map TeamMsg (Team.view model local) 232 | 233 | Player local -> 234 | Html.map PlayerMsg (Player.view model local) 235 | -------------------------------------------------------------------------------- /exec/tool/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | module Options where 11 | 12 | import RIO 13 | import qualified RIO.Text as Text 14 | import SubCmd 15 | 16 | import Data.Extensible 17 | import Data.Version (Version) 18 | import qualified Data.Version as Version 19 | import Development.GitRev 20 | import Git.Plantation.Cmd 21 | import Options.Applicative 22 | 23 | type Options = Record 24 | '[ "verbose" >: Bool 25 | , "config" >: FilePath 26 | , "work" >: FilePath 27 | , "subcmd" >: SubCmd 28 | ] 29 | 30 | options :: Parser Options 31 | options = hsequence 32 | $ #verbose <@=> switch (long "verbose" <> short 'v' <> help "Enable verbose mode: verbosity level \"debug\"") 33 | <: #config <@=> strOption (long "config" <> short 'c' <> value "config.yaml" <> metavar "PATH" <> help "Configuration file") 34 | <: #work <@=> strOption (long "work" <> value "~/.git-plantation" <> metavar "PATH" <> help "Work directory to exec git commands") 35 | <: #subcmd <@=> subcmdParser 36 | <: nil 37 | 38 | subcmdParser :: Parser SubCmd 39 | subcmdParser = variantFrom 40 | $ #config @= configCmdParser `withInfo` "Manage git-plantation config file." 41 | <: #repo @= repoCmdParser `withInfo` "Manage team repository in GitHub." 42 | <: #member @= memberCmdParser `withInfo` "Manage team member with GitHub Account." 43 | <: #problem @= problemCmdParser `withInfo` "Manage problem repository in GitHub." 44 | <: #org @= orgCmdParser `withInfo` "Manage GitHub organization for team." 45 | <: nil 46 | 47 | configCmdParser :: Parser ConfigCmd 48 | configCmdParser = fmap ConfigCmd . variantFrom 49 | $ #verify @= pure () `withInfo` "Verify git-plantation config file." 50 | <: nil 51 | 52 | repoCmdParser :: Parser RepoCmd 53 | repoCmdParser = fmap RepoCmd . variantFrom 54 | $ #new @= newRepoCmdParser `withInfo` "Create repository for team." 55 | <: #new_github @= repoCmdArgParser `withInfo` "Create new repository for team in GitHub" 56 | <: #init_github @= repoCmdArgParser `withInfo` "Init repository for team in GitHub" 57 | <: #setup_default_branch @= repoCmdArgParser `withInfo` "Setup default branch to team repository" 58 | <: #setup_webhook @= repoCmdArgParser `withInfo` "Setup GitHub Webhook to team repository" 59 | <: #init_ci @= repoCmdArgParser `withInfo` "Init CI repository by team repository" 60 | <: #reset @= repoCmdArgParser `withInfo` "Reset repository for team" 61 | <: #delete @= repoCmdArgParser `withInfo` "Delete repository for team." 62 | <: #add_gh_team @= repoCmdArgParser `withInfo` "Add repository to GitHub team." 63 | <: nil 64 | where 65 | newRepoCmdParser = (,) <$> repoCmdArgParser <*> newRepoFlags 66 | 67 | repoCmdArgParser :: Parser RepoCmdArg 68 | repoCmdArgParser = hsequence 69 | $ #repos <@=> option comma (long "repos" <> value [] <> metavar "IDS" <> help "Sets reopsitory that want to controll by problem id.") 70 | <: #team <@=> strArgument (metavar "TEXT" <> help "Sets team that want to controll.") 71 | <: nil 72 | 73 | newRepoFlags :: Parser NewRepoFlags 74 | newRepoFlags = hsequence 75 | $ #skip_create_repo <@=> switch (long "skip_create_repo" <> help "Flag for skip create new repository in GitHub") 76 | <: #skip_init_repo <@=> switch (long "skip_init_repo" <> help "Flag for skip init repository in GitHub") 77 | <: #skip_setup_default_branch <@=> switch (long "skip_setup_default_branch" <> help "Flag for skip setup default branch to repository") 78 | <: #skip_setup_webhook <@=> switch (long "skip_setup_webhook" <> help "Flag for skip setup GitHub Webhook to repository") 79 | <: #skip_init_ci <@=> switch (long "skip_init_ci" <> help "Flag for skip init CI by repository") 80 | <: nil 81 | 82 | memberCmdParser :: Parser MemberCmd 83 | memberCmdParser = fmap MemberCmd . variantFrom 84 | $ #invite @= memberCmdArgParser `withInfo` "Invite member to team repository" 85 | <: #kick @= memberCmdArgParser `withInfo` "Kick member from team repository" 86 | <: nil 87 | 88 | memberCmdArgParser :: Parser MemberCmdArg 89 | memberCmdArgParser = hsequence 90 | $ #team <@=> strArgument (metavar "TEXT" <> help "Sets team that want to controll.") 91 | <: #repos <@=> option comma (long "repos" <> value [] <> metavar "ID" <> help "Sets reopsitory that want to controll by problem id.") 92 | <: #user <@=> option (Just <$> str) (long "user" <> value Nothing <> metavar "TEXT" <> help "Sets user that want to controll.") 93 | <: #org <@=> switch (long "org" <> help "Manage member to GitHub Organization if true.") 94 | <: #gh_team <@=> option (Just <$> str) (long "gh_team" <> value Nothing <> metavar "TEXT" <> help "Manage member to GitHub Org Team.") 95 | <: nil 96 | 97 | problemCmdParser :: Parser ProblemCmd 98 | problemCmdParser = fmap ProblemCmd . variantFrom 99 | $ #show @= problemCmdArgParser `withInfo` "Display problem info." 100 | <: nil 101 | 102 | problemCmdArgParser :: Parser ProblemCmdArg 103 | problemCmdArgParser = hsequence 104 | $ #problems <@=> option comma (long "problems" <> value [] <> metavar "IDS" <> help "Set problem ids that want to manage.") 105 | <: nil 106 | 107 | orgCmdParser :: Parser OrgCmd 108 | orgCmdParser = fmap OrgCmd . variantFrom 109 | $ #create_team @= orgCmdArgParser `withInfo` "Create GitHub Team in org" 110 | <: nil 111 | 112 | orgCmdArgParser :: Parser OrgCmdArg 113 | orgCmdArgParser = hsequence 114 | $ #team <@=> strArgument (metavar "TEXT" <> help "Sets team that want to controll.") 115 | <: #gh_teams <@=> option commaS (long "gh_teams" <> value [] <> metavar "NAME" <> help "Manage GitHub Team names in config.") 116 | <: nil 117 | 118 | variantFrom :: 119 | Forall (KeyIs KnownSymbol) xs => RecordOf ParserInfo xs -> Parser (Variant xs) 120 | variantFrom = subparser . subcmdVariant 121 | where 122 | subcmdVariant = hfoldMapWithIndexFor (Proxy @(KeyIs KnownSymbol)) $ \m x -> 123 | command (stringKeyOf m) (EmbedAt m . Field . pure <$> getField x) 124 | 125 | instance Wrapper ParserInfo where 126 | type Repr ParserInfo a = ParserInfo a 127 | _Wrapper = id 128 | 129 | -- | 130 | -- support `--hoge 1,2,3` 131 | comma :: Read a => ReadM [a] 132 | comma = maybeReader (\s -> readMaybe $ "[" ++ s ++ "]") 133 | 134 | commaS :: IsString s => ReadM [s] 135 | commaS = 136 | maybeReader $ Just . map (fromString . Text.unpack) . Text.split (== ',') . fromString 137 | 138 | withInfo :: Parser a -> String -> ParserInfo a 139 | withInfo opts = info (helper <*> opts) . progDesc 140 | 141 | version :: Version -> Parser (a -> a) 142 | version v = infoOption (showVersion v) 143 | $ long "version" 144 | <> help "Show version" 145 | 146 | showVersion :: Version -> String 147 | showVersion v = unwords 148 | [ "Version" 149 | , Version.showVersion v ++ "," 150 | , "Git revision" 151 | , $(gitHash) 152 | , "(" ++ $(gitCommitCount) ++ " commits)" 153 | ] 154 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Member.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Git.Plantation.Cmd.Member 7 | ( MemberCmdArg 8 | , MemberArg 9 | , actForMember 10 | , inviteUserToRepo 11 | , kickUserFromRepo 12 | , actForMemberWithOrg 13 | , inviteUserToGitHubOrg 14 | , kickUserFromGitHubOrg 15 | , actForMemberWithGitHubTeam 16 | , inviteUserToGitHubOrgTeam 17 | , kickUserFromGitHubOrgTeam 18 | ) where 19 | 20 | import RIO 21 | 22 | import Data.Coerce (coerce) 23 | import Data.Extensible 24 | import Git.Plantation.Cmd.Arg 25 | import Git.Plantation.Cmd.Env (CmdEnv) 26 | import Git.Plantation.Cmd.Repo (repoGithub, 27 | splitRepoName) 28 | import Git.Plantation.Data 29 | import qualified Git.Plantation.Data.Team as Team 30 | import qualified Git.Plantation.Data.User as User 31 | import Git.Plantation.Env 32 | import GitHub.Data.Name (mkName) 33 | import qualified GitHub.Endpoints.Organizations.Members as GitHub 34 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 35 | import qualified GitHub.Endpoints.Repos.Collaborators as GitHub 36 | import qualified Mix.Plugin.GitHub as MixGitHub 37 | import qualified Mix.Plugin.Logger.JSON as Mix 38 | 39 | type MemberCmdArg = Record 40 | '[ "team" >: Team.Id 41 | , "repos" >: [RepoId] 42 | , "user" >: Maybe User.GitHubId 43 | , "org" >: Bool 44 | , "gh_team" >: Maybe Text 45 | ] 46 | 47 | type MemberArg = Record 48 | '[ "user" >: User 49 | , "repo" >: Repo 50 | ] 51 | 52 | type MemberWithOrgArg = Record 53 | '[ "user" >: User 54 | , "org" >: Text 55 | ] 56 | 57 | type MemberWithGitHubTeamArg = Record 58 | '[ "user" >: User 59 | , "org" >: Text 60 | , "gh_team" >: Text 61 | ] 62 | 63 | actForMember :: CmdEnv env => (MemberArg -> RIO env ()) -> MemberCmdArg -> RIO env () 64 | actForMember act args = 65 | findByIdWith (view #teams) (args ^. #team) >>= \case 66 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo $ args ^. #team) 67 | Just team -> do 68 | member <- findMember (args ^. #user) team 69 | repos <- findRepos (args ^. #repos) team 70 | mapM_ act $ hsequence $ #user <@=> member <: #repo <@=> repos <: nil 71 | 72 | actForMemberWithOrg :: 73 | CmdEnv env => (MemberWithOrgArg -> RIO env ()) -> MemberCmdArg -> RIO env () 74 | actForMemberWithOrg act args = 75 | findByIdWith (view #teams) (args ^. #team) >>= \case 76 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo $ args ^. #team) 77 | Just team -> do 78 | member <- findMember (args ^. #user) team 79 | ghOrg <- findGitHubOrg team 80 | mapM_ act $ hsequence $ #user <@=> member <: #org <@=> ghOrg <: nil 81 | 82 | actForMemberWithGitHubTeam :: 83 | CmdEnv env => (MemberWithGitHubTeamArg -> RIO env ()) -> MemberCmdArg -> RIO env () 84 | actForMemberWithGitHubTeam act args = 85 | findByIdWith (view #teams) (args ^. #team) >>= \case 86 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo $ args ^. #team) 87 | Just team -> do 88 | member <- findMember (args ^. #user) team 89 | ghOrg <- findGitHubOrg team 90 | ghTeam <- findGitHubTeam (args ^. #gh_team) team 91 | mapM_ act $ hsequence $ #user <@=> member <: #org <@=> ghOrg <: #gh_team <@=> ghTeam <: nil 92 | 93 | findMember :: CmdEnv env => Maybe User.GitHubId -> Team -> RIO env [User] 94 | findMember Nothing team = pure $ team ^. #member 95 | findMember (Just idx) team = 96 | case findById idx (team ^. #member) of 97 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo idx) >> pure [] 98 | Just user -> pure [user] 99 | 100 | findRepos :: CmdEnv env => [RepoId] -> Team -> RIO env [Repo] 101 | findRepos [] team = pure $ team ^. #repos 102 | findRepos ids team = fmap catMaybes . forM ids $ \idx -> 103 | case findById idx (team ^. #repos) of 104 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo idx) >> pure Nothing 105 | Just r -> pure (Just r) 106 | 107 | findGitHubOrg :: CmdEnv env => Team -> RIO env [Text] 108 | findGitHubOrg team = case team ^. #org of 109 | Nothing -> Mix.logErrorR "undefined GitHub org in config" nil >> pure [] 110 | Just org -> pure [org] 111 | 112 | findGitHubTeam :: CmdEnv env => Maybe Text -> Team -> RIO env [Text] 113 | findGitHubTeam Nothing _ = pure [] 114 | findGitHubTeam (Just name) team 115 | | name `elem` team ^. #gh_teams = pure [name] 116 | | otherwise = Mix.logErrorR "not found by config" (#gh_team @= name <: nil) >> pure [] 117 | 118 | inviteUserToRepo :: CmdEnv env => MemberArg -> RIO env () 119 | inviteUserToRepo args = do 120 | github <- repoGithub $ args ^. #repo 121 | let (owner, repo) = splitRepoName github 122 | resp <- MixGitHub.fetch $ GitHub.addCollaboratorR 123 | (mkName Proxy owner) 124 | (mkName Proxy repo) 125 | (mkName Proxy $ coerce $ args ^. #user ^. #github) 126 | case resp of 127 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 128 | Right _ -> logInfo $ display (success github) 129 | where 130 | failure err = InviteUserError err (args ^. #user) (TargetRepo $ args ^. #repo) 131 | success githubPath = mconcat 132 | [ "Success: invite " 133 | , coerce $ args ^. #user ^. #name, "(", coerce $ args ^. #user ^. #github, ")" 134 | , " to ", githubPath, "." 135 | ] 136 | 137 | kickUserFromRepo :: CmdEnv env => MemberArg -> RIO env () 138 | kickUserFromRepo args = do 139 | github <- repoGithub $ args ^. #repo 140 | let (owner, repo) = splitRepoName github 141 | resp <- MixGitHub.fetch $ GitHub.removeCollaboratorR 142 | (mkName Proxy owner) 143 | (mkName Proxy repo) 144 | (mkName Proxy $ coerce $ args ^. #user ^. #github) 145 | case resp of 146 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 147 | Right _ -> logInfo $ display (success github) 148 | where 149 | failure err = KickUserError err (args ^. #user) (TargetRepo $ args ^. #repo) 150 | success githubPath = mconcat 151 | [ "Success: kick " 152 | , coerce $ args ^. #user ^. #name, "(", coerce $ args ^. #user ^. #github, ")" 153 | , " from ", githubPath, "." 154 | ] 155 | 156 | inviteUserToGitHubOrg :: CmdEnv env => MemberWithOrgArg -> RIO env () 157 | inviteUserToGitHubOrg args = do 158 | resp <- MixGitHub.fetch $ GitHub.addOrUpdateMembershipR 159 | (mkName Proxy $ args ^. #org) 160 | (mkName Proxy $ coerce $ args ^. #user ^. #github) 161 | False 162 | case resp of 163 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 164 | Right _ -> logInfo $ display success 165 | where 166 | failure err = InviteUserError err (args ^. #user) (TargetOrg $ args ^. #org) 167 | success = mconcat 168 | [ "Success: invite " 169 | , coerce $ args ^. #user ^. #name, "(", coerce $ args ^. #user ^. #github, ")" 170 | , " to ", args ^. #org, "." 171 | ] 172 | 173 | kickUserFromGitHubOrg :: CmdEnv env => MemberWithOrgArg -> RIO env () 174 | kickUserFromGitHubOrg args = do 175 | resp <- MixGitHub.fetch $ GitHub.removeMembershipR 176 | (mkName Proxy $ args ^. #org) 177 | (mkName Proxy $ coerce $ args ^. #user ^. #github) 178 | case resp of 179 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 180 | Right _ -> logInfo $ display success 181 | where 182 | failure err = KickUserError err (args ^. #user) (TargetOrg $ args ^. #org) 183 | success = mconcat 184 | [ "Success: kick " 185 | , coerce $ args ^. #user ^. #name, "(", coerce $ args ^. #user ^. #github, ")" 186 | , " from ", args ^. #org, "." 187 | ] 188 | 189 | inviteUserToGitHubOrgTeam :: CmdEnv env => MemberWithGitHubTeamArg -> RIO env () 190 | inviteUserToGitHubOrgTeam args = do 191 | resp <- MixGitHub.fetch $ GitHub.teamInfoByNameR 192 | (mkName Proxy $ args ^. #org) 193 | (mkName Proxy $ args ^. #gh_team) 194 | team <- case resp of 195 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 196 | Right team -> pure team 197 | resp' <- MixGitHub.fetch $ GitHub.addTeamMembershipForR 198 | (GitHub.teamId team) 199 | (mkName Proxy $ coerce $ args ^. #user ^. #github) 200 | GitHub.RoleMember 201 | case resp' of 202 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 203 | Right _ -> logInfo $ display success 204 | where 205 | failure err = InviteUserError err (args ^. #user) (TargetTeam (args ^. #org) $ args ^. #gh_team) 206 | success = mconcat 207 | [ "Success: invite " 208 | , coerce $ args ^. #user ^. #name, "(", coerce $ args ^. #user ^. #github, ")" 209 | , " to ", args ^. #org, ":", args ^. #gh_team, "." 210 | ] 211 | 212 | kickUserFromGitHubOrgTeam :: CmdEnv env => MemberWithGitHubTeamArg -> RIO env () 213 | kickUserFromGitHubOrgTeam args = do 214 | resp <- MixGitHub.fetch $ GitHub.teamInfoByNameR 215 | (mkName Proxy $ args ^. #org) 216 | (mkName Proxy $ args ^. #gh_team) 217 | team <- case resp of 218 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 219 | Right team -> pure team 220 | resp' <- MixGitHub.fetch $ GitHub.deleteTeamMembershipForR 221 | (GitHub.teamId team) 222 | (mkName Proxy $ coerce $ args ^. #user ^. #github) 223 | case resp' of 224 | Left err -> logDebug (displayShow err) >> throwIO (failure err) 225 | Right _ -> logInfo $ display success 226 | where 227 | failure err = KickUserError err (args ^. #user) (TargetTeam (args ^. #org) $ args ^. #gh_team) 228 | success = mconcat 229 | [ "Success: kick " 230 | , coerce $ args ^. #user ^. #name, "(", coerce $ args ^. #user ^. #github, ")" 231 | , " from ", args ^. #org, ":", args ^. #gh_team, "." 232 | ] 233 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: binary-instances-1.0.4@sha256:97b8d6ccf5c111f41fd8bc2026ac683ae6999a730844ac5440ba9ff56d95d70f,2913 9 | pantry-tree: 10 | sha256: 9830c749da36cd66b383a5bca7afa76f5ef5512fa5d5b2da26e57d54d2a99241 11 | size: 1114 12 | original: 13 | hackage: binary-instances-1.0.4 14 | - completed: 15 | hackage: extensible-0.9@sha256:a93b7e55ccf0407915a2a60944b73577c50377f75de2c28d5a3acac96d231fcd,3344 16 | pantry-tree: 17 | sha256: aa0afe76b3c419438d09d173ac6080916d40bdcb6749dc2c7693983840a8f00e 18 | size: 2040 19 | original: 20 | hackage: extensible-0.9 21 | - completed: 22 | hackage: fallible-0.1.0@sha256:0e0032c34120a43bf1d446172162b546e36441c38f620afb24e9d447ed7ce6b6,1312 23 | pantry-tree: 24 | sha256: 7de6ccd3ae9fa01eafdb02afdd5a50f1f6babf48aeb31afa21d0329f0fdd19d1 25 | size: 369 26 | original: 27 | hackage: fallible-0.1.0 28 | - completed: 29 | hackage: incremental-0.3.1@sha256:9c697bae4f7e5ceb144bde13e03ca2f36b4bc2d0c92bbc02e0a604231ee279c2,1153 30 | pantry-tree: 31 | sha256: fd5f40352dbf1602babd2c5db2a120c26e57bbd5ad30b19ce24d04189f6a18d1 32 | size: 370 33 | original: 34 | hackage: incremental-0.3.1 35 | - completed: 36 | hackage: membership-0.0.1@sha256:6c4d4ab6e3fb3253c6c670e8a63f74454dc91be50b9f292d0b1355792190aee5,999 37 | pantry-tree: 38 | sha256: b918a1a207108313b2bf453b0d9aa65122d9845c4b360c8ade46d3429ff1107a 39 | size: 408 40 | original: 41 | hackage: membership-0.0.1 42 | - completed: 43 | name: servant-github-webhook 44 | pantry-tree: 45 | sha256: dc8e86b7e441351496ede201fcc6dc3fcfb96862d2be7559ecf72ed9f11a3c99 46 | size: 730 47 | sha256: 61ccafa1759b4df214265ada0555ecdf95b0b02473cdf12f86b3f0c128048445 48 | size: 10360 49 | url: https://github.com/tsani/servant-github-webhook/archive/f8cb8bc10d3e9d275fa995b0d01ba2d1eeaa700b.tar.gz 50 | version: 0.4.2.0 51 | original: 52 | url: https://github.com/tsani/servant-github-webhook/archive/f8cb8bc10d3e9d275fa995b0d01ba2d1eeaa700b.tar.gz 53 | - completed: 54 | name: servant 55 | pantry-tree: 56 | sha256: f49cc9bb3f65cc9ce7bf64b6978ac3c09a2cf3bd03462dc27082f4c016b91e8e 57 | size: 3020 58 | sha256: 30d8ba6b3c0ef09ab3613312b6b84837c3d86ea0412a20b722d1e41b5acd143f 59 | size: 409224 60 | subdir: servant 61 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 62 | version: 0.19.1 63 | original: 64 | subdir: servant 65 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 66 | - completed: 67 | name: servant-auth 68 | pantry-tree: 69 | sha256: 5a89f680a57fcebc5a6901d4bed45536e7ba297482e462234803f99c69a6a5ea 70 | size: 426 71 | sha256: 30d8ba6b3c0ef09ab3613312b6b84837c3d86ea0412a20b722d1e41b5acd143f 72 | size: 409224 73 | subdir: servant-auth/servant-auth 74 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 75 | version: 0.4.1.0 76 | original: 77 | subdir: servant-auth/servant-auth 78 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 79 | - completed: 80 | name: servant-auth-server 81 | pantry-tree: 82 | sha256: d5b050ec7b8b22e07d6d4f9987e25b789a7dd616ecac4812dcc1488feb0c2184 83 | size: 1469 84 | sha256: 30d8ba6b3c0ef09ab3613312b6b84837c3d86ea0412a20b722d1e41b5acd143f 85 | size: 409224 86 | subdir: servant-auth/servant-auth-server 87 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 88 | version: 0.4.7.0 89 | original: 90 | subdir: servant-auth/servant-auth-server 91 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 92 | - completed: 93 | name: servant-foreign 94 | pantry-tree: 95 | sha256: 0e6c55e22eb56501b6da5e8290c41bd25c0adb825cf0ac401e081b9f247053d9 96 | size: 590 97 | sha256: 30d8ba6b3c0ef09ab3613312b6b84837c3d86ea0412a20b722d1e41b5acd143f 98 | size: 409224 99 | subdir: servant-foreign 100 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 101 | version: 0.15.4 102 | original: 103 | subdir: servant-foreign 104 | url: https://github.com/haskell-servant/servant/archive/a082794a48546ffd681f4206436c59b9c1f901e1.tar.gz 105 | - completed: 106 | hackage: servant-elm-0.7.3@sha256:262f21c7092f7ce7448a9f936d69febe50fdc8c00c21d4c9f1811d8e748a8853,4579 107 | pantry-tree: 108 | sha256: eb07459399cbe9f7f3d95ba13bec97c71967f5a4df57e862228416a39655b6b1 109 | size: 2081 110 | original: 111 | hackage: servant-elm-0.7.3 112 | - completed: 113 | name: github 114 | pantry-tree: 115 | sha256: adcf2ac3bf9ddee24522d8d239792b02ba140753b6bcbfbef31ac18b0b09b2c9 116 | size: 16819 117 | sha256: 5e607797c11b67703907fe15f0480dc6f129e501aa2d38d68426e3fdd20dcba5 118 | size: 95015 119 | url: https://github.com/matsubara0507/github/archive/521ee92de8811cad022b5924e3be5c668d5b7b73.tar.gz 120 | version: 0.28.0.1 121 | original: 122 | url: https://github.com/matsubara0507/github/archive/521ee92de8811cad022b5924e3be5c668d5b7b73.tar.gz 123 | - completed: 124 | name: elmap 125 | pantry-tree: 126 | sha256: b38023fb7e22af9c326855669b51aed720146e2959d44b6abd09571a5046c8d9 127 | size: 476 128 | sha256: 709e3d7639d0f460dbc8c2ae629ad5f8edb17f22735cda7f79c34a12a30d3375 129 | size: 19910 130 | subdir: elmap 131 | url: https://github.com/matsubara0507/elmap.hs/archive/3cd415ba620aeb588c5f7217d96a8d6f05cb45f1.tar.gz 132 | version: 0.1.0.1 133 | original: 134 | subdir: elmap 135 | url: https://github.com/matsubara0507/elmap.hs/archive/3cd415ba620aeb588c5f7217d96a8d6f05cb45f1.tar.gz 136 | - completed: 137 | name: servant-elmap 138 | pantry-tree: 139 | sha256: c29a94be05a0f3cc087761f36cee959f17aa4c0d11a43ff18e4e1658478624b3 140 | size: 614 141 | sha256: 709e3d7639d0f460dbc8c2ae629ad5f8edb17f22735cda7f79c34a12a30d3375 142 | size: 19910 143 | subdir: servant-elmap 144 | url: https://github.com/matsubara0507/elmap.hs/archive/3cd415ba620aeb588c5f7217d96a8d6f05cb45f1.tar.gz 145 | version: 0.1.0.1 146 | original: 147 | subdir: servant-elmap 148 | url: https://github.com/matsubara0507/elmap.hs/archive/3cd415ba620aeb588c5f7217d96a8d6f05cb45f1.tar.gz 149 | - completed: 150 | name: extensible-elmap 151 | pantry-tree: 152 | sha256: 25681ca163a6aabe877c08555907b6b04fae34e92ad2ef0e0b91e40c692bd065 153 | size: 439 154 | sha256: 709e3d7639d0f460dbc8c2ae629ad5f8edb17f22735cda7f79c34a12a30d3375 155 | size: 19910 156 | subdir: extensible-elmap 157 | url: https://github.com/matsubara0507/elmap.hs/archive/3cd415ba620aeb588c5f7217d96a8d6f05cb45f1.tar.gz 158 | version: 0.1.0.1 159 | original: 160 | subdir: extensible-elmap 161 | url: https://github.com/matsubara0507/elmap.hs/archive/3cd415ba620aeb588c5f7217d96a8d6f05cb45f1.tar.gz 162 | - completed: 163 | name: mix 164 | pantry-tree: 165 | sha256: 934c2b8605c35e49d36c87c3c41dc0459e399919cf12161e16cc0d82340251b5 166 | size: 598 167 | sha256: 2c9640592d44d865663a1d8814e90efb48fadb7d2ee4fea1781784c7a55b2a89 168 | size: 12036 169 | subdir: mix 170 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 171 | version: 0.1.1 172 | original: 173 | subdir: mix 174 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 175 | - completed: 176 | name: mix-json-logger 177 | pantry-tree: 178 | sha256: 7dcec7237b58fc21fd53b19a88c37a680fdd16cc2994e7bb90ed38e83b3d8768 179 | size: 334 180 | sha256: 2c9640592d44d865663a1d8814e90efb48fadb7d2ee4fea1781784c7a55b2a89 181 | size: 12036 182 | subdir: mix-json-logger 183 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 184 | version: 0.1.0 185 | original: 186 | subdir: mix-json-logger 187 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 188 | - completed: 189 | name: mix-plugin-github 190 | pantry-tree: 191 | sha256: c12925af9288415df9626130d555a09b2b27e26a04ecf1530ce65cff704cfdc4 192 | size: 458 193 | sha256: 2c9640592d44d865663a1d8814e90efb48fadb7d2ee4fea1781784c7a55b2a89 194 | size: 12036 195 | subdir: mix-plugin-github 196 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 197 | version: 0.3.0 198 | original: 199 | subdir: mix-plugin-github 200 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 201 | - completed: 202 | name: mix-plugin-persistent-sqlite 203 | pantry-tree: 204 | sha256: 8ba3753486908e267620ff8c32c6799d703dfa80395f14a94e957a9728da6002 205 | size: 357 206 | sha256: 2c9640592d44d865663a1d8814e90efb48fadb7d2ee4fea1781784c7a55b2a89 207 | size: 12036 208 | subdir: mix-plugin-persistent-sqlite 209 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 210 | version: 0.1.0 211 | original: 212 | subdir: mix-plugin-persistent-sqlite 213 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 214 | - completed: 215 | name: mix-plugin-shell 216 | pantry-tree: 217 | sha256: 2c30acc53ef040b03bdacf6275dc225c07f01a05fa67b5872b0fcf05c8e8b72c 218 | size: 383 219 | sha256: 2c9640592d44d865663a1d8814e90efb48fadb7d2ee4fea1781784c7a55b2a89 220 | size: 12036 221 | subdir: mix-plugin-shell 222 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 223 | version: 0.1.0 224 | original: 225 | subdir: mix-plugin-shell 226 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 227 | - completed: 228 | name: rio-logger-ext 229 | pantry-tree: 230 | sha256: 6610dacdf9c92484902401f6303863c28afa54e6e385d89584889226dc01a741 231 | size: 275 232 | sha256: 2c9640592d44d865663a1d8814e90efb48fadb7d2ee4fea1781784c7a55b2a89 233 | size: 12036 234 | subdir: helper/rio-logger-ext 235 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 236 | version: 0.1.0 237 | original: 238 | subdir: helper/rio-logger-ext 239 | url: https://github.com/matsubara0507/mix.hs/archive/da914f3c0ec152e5814ed5495c9c3aef2ceec4ed.tar.gz 240 | snapshots: 241 | - completed: 242 | sha256: a7af444c35e8ccf8cc4dc5f23d3507bbdcc7e6cfd674f0f8b24cdc10474e2b4b 243 | size: 632756 244 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2023/6/16.yaml 245 | original: nightly-2023-06-16 246 | -------------------------------------------------------------------------------- /src/Git/Plantation/Cmd/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExtendedDefaultRules #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 8 | 9 | module Git.Plantation.Cmd.Repo 10 | ( RepoCmdArg 11 | , RepoArg 12 | , NewRepoFlags 13 | , actForRepo 14 | , createRepo 15 | , createRepoInGitHub 16 | , initRepoInGitHub 17 | , setupDefaultBranch 18 | , setupWebhook 19 | , initProblemCI 20 | , resetRepo 21 | , pushForCI 22 | , deleteRepo 23 | , addGitHubTeam 24 | , splitRepoName 25 | , repoGithub 26 | ) where 27 | 28 | import RIO 29 | import qualified RIO.Map as Map 30 | import qualified RIO.Text as Text 31 | import qualified RIO.Vector as V 32 | 33 | import Data.Coerce (coerce) 34 | import Data.Extensible 35 | import Git.Plantation.Cmd.Arg 36 | import Git.Plantation.Cmd.Env (CmdEnv, ghUserL) 37 | import Git.Plantation.Data (Problem, Repo, Team, 38 | User) 39 | import qualified Git.Plantation.Data.Problem as Problem 40 | import qualified Git.Plantation.Data.Team as Team 41 | import qualified Git.Plantation.Data.User as User 42 | import Git.Plantation.Env 43 | import GitHub.Data.Name (mkName) 44 | import GitHub.Data.Repos (newRepo, newRepoPrivate, newRepoAllowMergeCommit) 45 | import GitHub.Data.Webhooks (NewRepoWebhook (..), 46 | RepoWebhookEvent (..)) 47 | import qualified GitHub.Endpoints.Organizations.Teams as GitHub 48 | import qualified GitHub.Endpoints.Repos as GitHub 49 | import qualified GitHub.Endpoints.Repos.Webhooks as GitHub 50 | 51 | import qualified Git.Cmd as Git 52 | import qualified Mix.Plugin.GitHub as MixGitHub 53 | import qualified Mix.Plugin.Logger.JSON as Mix 54 | import qualified Mix.Plugin.Shell as MixShell 55 | import qualified Shelly as Shell 56 | 57 | type RepoCmdArg = Record 58 | '[ "repos" >: [RepoId] 59 | , "team" >: Team.Id 60 | ] 61 | 62 | type RepoArg = Record 63 | '[ "repo" >: Repo 64 | , "team" >: Team 65 | ] 66 | 67 | type NewRepoFlags = Record 68 | '[ "skip_create_repo" >: Bool 69 | , "skip_init_repo" >: Bool 70 | , "skip_setup_default_branch" >: Bool 71 | , "skip_setup_webhook" >: Bool 72 | , "skip_init_ci" >: Bool 73 | ] 74 | 75 | actForRepo :: CmdEnv env => (RepoArg -> RIO env ()) -> RepoCmdArg -> RIO env () 76 | actForRepo act args = 77 | findByIdWith (view #teams) (args ^. #team) >>= \case 78 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo $ args ^. #team) 79 | Just team -> do 80 | repos <- findRepos (args ^. #repos) team 81 | mapM_ act $ hsequence $ #repo <@=> repos <: #team <@=> pure team <: nil 82 | 83 | findRepos :: CmdEnv env => [RepoId] -> Team -> RIO env [Repo] 84 | findRepos [] team = pure $ team ^. #repos 85 | findRepos ids team = fmap catMaybes . forM ids $ \idx -> 86 | case findById idx (team ^. #repos) of 87 | Nothing -> Mix.logErrorR "not found by config" (toArgInfo idx) >> pure Nothing 88 | Just r -> pure (Just r) 89 | 90 | findProblemWithThrow :: CmdEnv env => Problem.Id -> RIO env Problem 91 | findProblemWithThrow idx = 92 | findByIdWith (view #problems) idx >>= \case 93 | Nothing -> throwIO $ UndefinedProblem (coerce idx) 94 | Just p -> pure p 95 | 96 | createRepo :: (HasWebhookConfig env, CmdEnv env) => NewRepoFlags -> RepoArg -> RIO env () 97 | createRepo flags args = do 98 | Mix.logInfoR "create team repository" args 99 | unless (flags ^. #skip_create_repo) $ createRepoInGitHub args 100 | unless (flags ^. #skip_init_repo) $ initRepoInGitHub args 101 | unless (flags ^. #skip_setup_default_branch) $ setupDefaultBranch args 102 | unless (flags ^. #skip_setup_webhook) $ setupWebhook args 103 | 104 | createRepoInGitHub :: CmdEnv env => RepoArg -> RIO env () 105 | createRepoInGitHub args = do 106 | (owner, repo) <- splitRepoName <$> repoGithub (args ^. #repo) 107 | logInfo $ "create repo in github: " <> displayShow (owner <> "/" <> repo) 108 | resp <- MixGitHub.fetch $ request owner 109 | ((newRepo $ mkName Proxy repo) { newRepoPrivate = Just (args ^. #repo ^. #private), newRepoAllowMergeCommit = Just True }) 110 | case resp of 111 | Left err -> logDebug (displayShow err) >> throwIO (mkErr err) 112 | Right _ -> logInfo "Success: create repository in GitHub" 113 | where 114 | request owner = 115 | if Team.repoIsOrg (args ^. #repo) then 116 | GitHub.createOrganizationRepoR (mkName Proxy owner) 117 | else 118 | GitHub.createRepoR 119 | mkErr err = CreateRepoError err (args ^. #team) (args ^. #repo) 120 | 121 | initRepoInGitHub :: CmdEnv env => RepoArg -> RIO env () 122 | initRepoInGitHub args = do 123 | token <- MixGitHub.tokenText 124 | ghUser <- view ghUserL 125 | github <- repoGithub (args ^. #repo) 126 | problem <- findProblemWithThrow (args ^. #repo ^. #problem) 127 | let (owner, repo) = splitRepoName $ problem ^. #repo 128 | (_, teamRepo) = splitRepoName github 129 | teamUrl = mconcat ["https://", ghUser, ":", token, "@github.com/", github, ".git"] 130 | problemUrl = mconcat ["https://", ghUser, ":", token, "@github.com/", owner, "/", repo, ".git"] 131 | 132 | execGitForTeam (args ^. #team) teamRepo False teamUrl $ do 133 | Shell.errExit False $ Git.branch ["-D", "temp"] 134 | Shell.errExit False $ Git.checkout ["-b", "temp"] 135 | Shell.errExit False $ Git.branch $ "-D" : problem ^. #challenge_branches 136 | Shell.errExit False $ Git.remote ["add", "problem", problemUrl] 137 | Git.fetch ["--all"] 138 | forM_ (problem ^. #challenge_branches) $ 139 | \branch -> Git.checkout ["-b", branch, "problem/" <> branch] 140 | Git.push $ "-f" : "-u" : "origin" : problem ^. #challenge_branches 141 | logInfo $ "Success: create repo as " <> displayShow github 142 | 143 | setupDefaultBranch :: CmdEnv env => RepoArg -> RIO env () 144 | setupDefaultBranch args = do 145 | (owner, repo) <- splitRepoName <$> repoGithub (args ^. #repo) 146 | problem <- findProblemWithThrow (args ^. #repo ^. #problem) 147 | resp <- MixGitHub.fetch $ GitHub.editRepoR 148 | (mkName Proxy owner) 149 | (mkName Proxy repo) 150 | $ edit { GitHub.editDefaultBranch = Just $ problem ^. #default_branch 151 | , GitHub.editPrivate = Just (args ^. #repo ^. #private) 152 | } 153 | case resp of 154 | Left err -> logDebug (displayShow err) >> throwIO (DeleteRepoError err $ args ^. #repo) 155 | Right _ -> logInfo "Success: set default branch in GitHub" 156 | where 157 | edit = GitHub.EditRepo 158 | Nothing Nothing Nothing Nothing Nothing Nothing 159 | Nothing Nothing Nothing Nothing Nothing Nothing 160 | 161 | setupWebhook :: (HasWebhookConfig env, CmdEnv env) => RepoArg -> RIO env () 162 | setupWebhook args = do 163 | (owner, repo) <- splitRepoName <$> repoGithub (args ^. #repo) 164 | webhookConfig <- askWebhookConfig 165 | logInfo $ "setup github webhook to repo: " <> displayShow (owner <> "/" <> repo) 166 | resp <- MixGitHub.fetch $ 167 | GitHub.createRepoWebhookR (mkName Proxy owner) (mkName Proxy repo) (webhook webhookConfig) 168 | case resp of 169 | Left err -> logDebug (displayShow err) >> throwIO (mkErr err) 170 | Right _ -> logInfo "Success: setup GitHub Webhook to repository" 171 | where 172 | webhook conf = NewRepoWebhook 173 | { newRepoWebhookName = "web" 174 | , newRepoWebhookConfig = Map.fromList conf 175 | , newRepoWebhookEvents = Just $ V.fromList [WebhookPushEvent] 176 | , newRepoWebhookActive = Just True 177 | } 178 | mkErr err = SetupWebhookError err (args ^. #repo) 179 | 180 | initProblemCI :: CmdEnv env => RepoArg -> RIO env () 181 | initProblemCI args = do 182 | token <- MixGitHub.tokenText 183 | ghUser <- view ghUserL 184 | github <- repoGithub (args ^. #repo) 185 | problem <- findProblemWithThrow (args ^. #repo ^. #problem) 186 | let (owner, repo) = splitRepoName $ problem ^. #repo 187 | problemUrl = mconcat ["https://", ghUser, ":", token, "@github.com/", owner, "/", repo, ".git"] 188 | 189 | execGitForTeam (args ^. #team) repo True problemUrl $ do 190 | Git.checkout [problem ^. #ci_branch] 191 | Git.pull [] 192 | Shell.errExit False $ Git.branch ["-D", coerce $ args ^. #team ^. #name] 193 | Git.checkout ["-b", coerce $ args ^. #team ^. #name] 194 | Shell.writefile ciFileName github 195 | Git.add [ciFileName] 196 | Git.commit ["-m", "[CI SKIP] Add ci branch"] 197 | Git.push ["-f", "-u", "origin", coerce $ args ^. #team ^. #name] 198 | logInfo $ "Success: create ci branch in " <> displayShow (problem ^. #repo) 199 | 200 | resetRepo :: CmdEnv env => RepoArg -> RIO env () 201 | resetRepo args = do 202 | problem <- findProblemWithThrow (args ^. #repo ^. #problem) 203 | let (_, repo) = splitRepoName $ problem ^. #repo 204 | local (over MixShell.workL $ toTeamWork (args ^. #team) False) $ do 205 | local (over MixShell.workL $ toWorkWith $ Text.unpack repo) $ MixShell.exec (Shell.ls "." >> pure ()) 206 | MixShell.exec $ Shell.rm_rf $ Shell.fromText repo 207 | initRepoInGitHub args 208 | 209 | pushForCI :: CmdEnv env => Team -> Problem -> Maybe User -> RIO env () 210 | pushForCI team problem user = do 211 | token <- MixGitHub.tokenText 212 | ghUser <- view ghUserL 213 | let (owner, repo) = splitRepoName $ problem ^. #repo 214 | problemUrl = mconcat ["https://", ghUser, ":", token, "@github.com/", owner, "/", repo, ".git"] 215 | 216 | execGitForTeam team repo True problemUrl $ do 217 | Git.checkout [coerce $ team ^. #name] 218 | Git.pull [] 219 | Git.commit ["--allow-empty", "-m", "pushed by: @" <> userAccount] 220 | Git.push ["origin", coerce $ team ^. #name] 221 | logInfo "Success push" 222 | where 223 | userAccount = coerce $ maybe "" (view #github) user 224 | 225 | deleteRepo :: CmdEnv env => RepoArg -> RIO env () 226 | deleteRepo args = do 227 | Mix.logInfoR "delete team repository" args 228 | problem <- findProblemWithThrow (args ^. #repo ^. #problem) 229 | deleteRepoInGithub (args ^. #repo) 230 | deleteProblemCI (args ^. #team) problem 231 | 232 | deleteRepoInGithub :: CmdEnv env => Repo -> RIO env () 233 | deleteRepoInGithub info = do 234 | (owner, repo) <- splitRepoName <$> repoGithub info 235 | logInfo $ "delete repo in github: " <> displayShow (owner <> "/" <> repo) 236 | resp <- MixGitHub.fetch $ 237 | GitHub.deleteRepoR (mkName Proxy owner) (mkName Proxy repo) 238 | case resp of 239 | Left err -> logDebug (displayShow err) >> throwIO (DeleteRepoError err info) 240 | Right _ -> logInfo "Success: delete repository in GitHub" 241 | 242 | deleteProblemCI :: CmdEnv env => Team -> Problem -> RIO env () 243 | deleteProblemCI team problem = do 244 | token <- MixGitHub.tokenText 245 | ghUser <- view ghUserL 246 | let (owner, repo) = splitRepoName $ problem ^. #repo 247 | problemUrl = mconcat ["https://", ghUser, ":", token, "@github.com/", owner, "/", repo, ".git"] 248 | execGitForTeam team repo True problemUrl $ 249 | Shell.errExit False $ Git.push [ "--delete", "origin", coerce $ team ^. #name] 250 | logInfo $ "Success: delete ci branch in " <> displayShow (problem ^. #repo) 251 | 252 | execGitForTeam :: CmdEnv env => Team -> Text -> Bool -> Text -> MixShell.Sh () -> RIO env () 253 | execGitForTeam team repo isProblem url act = 254 | local (over MixShell.workL $ toTeamWork team isProblem) $ do 255 | MixShell.exec $ unlessM (Shell.test_d $ fromString repo') $ Git.clone [url, repo] 256 | local (over MixShell.workL $ toWorkWith repo') $ MixShell.exec act 257 | where 258 | repo' = Text.unpack repo 259 | 260 | addGitHubTeam :: CmdEnv env => RepoArg -> RIO env () 261 | addGitHubTeam args = case (args ^. #team ^. #org, args ^. #repo ^. #only) of 262 | (Nothing, _) -> logError "Undefined GitHub org in team" 263 | (_, Nothing) -> logError "Undefined 'only' option in team repo." 264 | (Just org, Just name) 265 | | valid name -> addGitHubTeam' org name (args ^. #repo) 266 | | otherwise -> logError $ display $ "Undefined GitHub team in team: " <> name 267 | where 268 | valid name = name `elem` args ^. #team ^. #gh_teams 269 | 270 | addGitHubTeam' :: CmdEnv env => Text -> Text -> Repo -> RIO env () 271 | addGitHubTeam' org name repo = do 272 | resp <- MixGitHub.fetch $ GitHub.teamInfoByNameR 273 | (mkName Proxy org) 274 | (mkName Proxy name) 275 | team <- case resp of 276 | Left err -> logDebug (displayShow err) >> throwIO (failure err org name) 277 | Right team -> pure team 278 | (owner, repoName) <- splitRepoName <$> repoGithub repo 279 | resp' <- MixGitHub.fetch $ GitHub.addOrUpdateTeamRepoR 280 | (GitHub.teamId team) 281 | (mkName Proxy owner) 282 | (mkName Proxy repoName) 283 | GitHub.PermissionPush 284 | case resp' of 285 | Left err -> logDebug (displayShow err) >> throwIO (failure err org name) 286 | Right _ -> logInfo $ display $ "Success: add repository to GitHub team: " <> name 287 | 288 | failure err org name = 289 | AddRepoToGitHubTeamError err org name $ args ^. #repo 290 | 291 | -- | 292 | -- helper functions 293 | 294 | splitRepoName :: Text -> (Text, Text) 295 | splitRepoName = fmap (Text.drop 1) . Text.span(/= '/') 296 | 297 | repoGithub :: CmdEnv env => Repo -> RIO env Text 298 | repoGithub repo = 299 | Team.repoGithubPath repo `fromJustWithThrow` InvalidRepoConfig repo 300 | 301 | ciFileName :: IsString s => s 302 | ciFileName = "REPOSITORY" 303 | 304 | toWorkWith :: FilePath -> FilePath -> FilePath 305 | toWorkWith path = (<> "/" <> path) 306 | 307 | toTeamWork :: Team -> Bool -> FilePath -> FilePath 308 | toTeamWork team isProblem = 309 | toWorkWith $ Text.unpack $ coerce (team ^. #name) <> if isProblem then "/problem" else "" 310 | -------------------------------------------------------------------------------- /git-plantation.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: git-plantation 8 | version: 0.5.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/matsubara0507/git-plantation#readme 11 | bug-reports: https://github.com/matsubara0507/git-plantation/issues 12 | author: MATSUBARA Nobutada 13 | maintainer: t12307043@gunma-u.ac.jp 14 | copyright: 2018 MATSUBARA Nobutada 15 | license: MIT 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-source-files: 19 | README.md 20 | CHANGELOG.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/matsubara0507/git-plantation 25 | 26 | library 27 | exposed-modules: 28 | Git.Cmd 29 | Git.Plantation 30 | Git.Plantation.API 31 | Git.Plantation.API.CRUD 32 | Git.Plantation.API.GitHub 33 | Git.Plantation.API.Job 34 | Git.Plantation.API.Slack 35 | Git.Plantation.Auth.GitHub 36 | Git.Plantation.Cmd 37 | Git.Plantation.Cmd.Arg 38 | Git.Plantation.Cmd.Arg.Internal 39 | Git.Plantation.Cmd.Arg.Problem 40 | Git.Plantation.Cmd.Arg.Team 41 | Git.Plantation.Cmd.Env 42 | Git.Plantation.Cmd.Member 43 | Git.Plantation.Cmd.Org 44 | Git.Plantation.Cmd.Problem 45 | Git.Plantation.Cmd.Repo 46 | Git.Plantation.Config 47 | Git.Plantation.Data 48 | Git.Plantation.Data.Job 49 | Git.Plantation.Data.Problem 50 | Git.Plantation.Data.Repo 51 | Git.Plantation.Data.Slack 52 | Git.Plantation.Data.Slack.Verification 53 | Git.Plantation.Data.Team 54 | Git.Plantation.Data.User 55 | Git.Plantation.Env 56 | Git.Plantation.Job.Client 57 | Git.Plantation.Job.Docker 58 | Git.Plantation.Job.Protocol 59 | Git.Plantation.Job.Server 60 | Git.Plantation.Job.Store 61 | Git.Plantation.Job.Worker 62 | Git.Plantation.Score 63 | Orphans 64 | other-modules: 65 | Paths_git_plantation 66 | hs-source-dirs: 67 | src 68 | default-extensions: 69 | NoImplicitPrelude 70 | GHC2021 71 | ConstraintKinds 72 | FlexibleContexts 73 | FlexibleInstances 74 | GeneralizedNewtypeDeriving 75 | OverloadedStrings 76 | PolyKinds 77 | RankNTypes 78 | StandaloneDeriving 79 | TypeFamilies 80 | TypeSynonymInstances 81 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 82 | build-depends: 83 | aeson 84 | , base >=4.7 && <5 85 | , binary 86 | , blaze-html 87 | , containers 88 | , cryptonite 89 | , dotenv 90 | , elmap 91 | , esqueleto 92 | , exceptions 93 | , extensible >=0.6 94 | , extensible-elmap 95 | , fallible 96 | , github 97 | , github-webhooks >=0.17.0 98 | , http-api-data 99 | , http-media 100 | , memory 101 | , mix 102 | , mix-json-logger 103 | , mix-plugin-github 104 | , mix-plugin-persistent-sqlite 105 | , mix-plugin-shell 106 | , mtl 107 | , persistent 108 | , persistent-template 109 | , random 110 | , req >=2.0 111 | , rio >=0.1.1.0 112 | , servant 113 | , servant-auth-server 114 | , servant-blaze 115 | , servant-elmap 116 | , servant-github-webhook 117 | , servant-server 118 | , shelly 119 | , template-haskell 120 | , time 121 | , unliftio 122 | , websockets 123 | , wreq 124 | , yaml >=0.8.31 125 | default-language: Haskell2010 126 | 127 | executable git-plantation-app 128 | main-is: Main.hs 129 | other-modules: 130 | Paths_git_plantation 131 | hs-source-dirs: 132 | exec/app 133 | default-extensions: 134 | NoImplicitPrelude 135 | GHC2021 136 | ConstraintKinds 137 | FlexibleContexts 138 | FlexibleInstances 139 | GeneralizedNewtypeDeriving 140 | OverloadedStrings 141 | PolyKinds 142 | RankNTypes 143 | StandaloneDeriving 144 | TypeFamilies 145 | TypeSynonymInstances 146 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 147 | build-depends: 148 | aeson 149 | , base >=4.7 && <5 150 | , binary 151 | , blaze-html 152 | , containers 153 | , cryptonite 154 | , dotenv 155 | , elmap 156 | , esqueleto 157 | , exceptions 158 | , extensible >=0.6 159 | , extensible-elmap 160 | , fallible 161 | , git-plantation 162 | , github 163 | , github-webhooks >=0.17.0 164 | , gitrev 165 | , http-api-data 166 | , http-media 167 | , memory 168 | , mix 169 | , mix-json-logger 170 | , mix-plugin-github 171 | , mix-plugin-persistent-sqlite 172 | , mix-plugin-shell 173 | , mtl 174 | , persistent 175 | , persistent-template 176 | , random 177 | , req >=2.0 178 | , rio >=0.1.1.0 179 | , servant 180 | , servant-auth-server 181 | , servant-blaze 182 | , servant-elmap 183 | , servant-github-webhook 184 | , servant-server 185 | , shelly 186 | , template-haskell 187 | , time 188 | , unliftio 189 | , warp 190 | , websockets 191 | , wreq 192 | , yaml >=0.8.31 193 | default-language: Haskell2010 194 | 195 | executable git-plantation-job-runner 196 | main-is: Main.hs 197 | other-modules: 198 | Paths_git_plantation 199 | hs-source-dirs: 200 | exec/jobrunner 201 | default-extensions: 202 | NoImplicitPrelude 203 | GHC2021 204 | ConstraintKinds 205 | FlexibleContexts 206 | FlexibleInstances 207 | GeneralizedNewtypeDeriving 208 | OverloadedStrings 209 | PolyKinds 210 | RankNTypes 211 | StandaloneDeriving 212 | TypeFamilies 213 | TypeSynonymInstances 214 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 215 | build-depends: 216 | aeson 217 | , base >=4.7 && <5 218 | , binary 219 | , blaze-html 220 | , containers 221 | , cryptonite 222 | , dotenv 223 | , elmap 224 | , esqueleto 225 | , exceptions 226 | , extensible >=0.6 227 | , extensible-elmap 228 | , fallible 229 | , git-plantation 230 | , github 231 | , github-webhooks >=0.17.0 232 | , gitrev 233 | , http-api-data 234 | , http-media 235 | , memory 236 | , mix 237 | , mix-json-logger 238 | , mix-plugin-github 239 | , mix-plugin-persistent-sqlite 240 | , mix-plugin-shell 241 | , mtl 242 | , persistent 243 | , persistent-template 244 | , random 245 | , req >=2.0 246 | , rio >=0.1.1.0 247 | , servant 248 | , servant-auth-server 249 | , servant-blaze 250 | , servant-elmap 251 | , servant-github-webhook 252 | , servant-server 253 | , shelly 254 | , template-haskell 255 | , time 256 | , unliftio 257 | , websockets 258 | , wreq 259 | , yaml >=0.8.31 260 | default-language: Haskell2010 261 | 262 | executable git-plantation-job-server 263 | main-is: Main.hs 264 | other-modules: 265 | Paths_git_plantation 266 | hs-source-dirs: 267 | exec/jobserver 268 | default-extensions: 269 | NoImplicitPrelude 270 | GHC2021 271 | ConstraintKinds 272 | FlexibleContexts 273 | FlexibleInstances 274 | GeneralizedNewtypeDeriving 275 | OverloadedStrings 276 | PolyKinds 277 | RankNTypes 278 | StandaloneDeriving 279 | TypeFamilies 280 | TypeSynonymInstances 281 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 282 | build-depends: 283 | aeson 284 | , base >=4.7 && <5 285 | , binary 286 | , blaze-html 287 | , containers 288 | , cryptonite 289 | , dotenv 290 | , elmap 291 | , esqueleto 292 | , exceptions 293 | , extensible >=0.6 294 | , extensible-elmap 295 | , fallible 296 | , git-plantation 297 | , github 298 | , github-webhooks >=0.17.0 299 | , gitrev 300 | , http-api-data 301 | , http-media 302 | , memory 303 | , mix 304 | , mix-json-logger 305 | , mix-plugin-github 306 | , mix-plugin-persistent-sqlite 307 | , mix-plugin-shell 308 | , mtl 309 | , persistent 310 | , persistent-template 311 | , random 312 | , req >=2.0 313 | , rio >=0.1.1.0 314 | , servant 315 | , servant-auth-server 316 | , servant-blaze 317 | , servant-elmap 318 | , servant-github-webhook 319 | , servant-server 320 | , shelly 321 | , template-haskell 322 | , time 323 | , unliftio 324 | , wai-websockets 325 | , warp 326 | , websockets 327 | , wreq 328 | , yaml >=0.8.31 329 | default-language: Haskell2010 330 | 331 | executable git-plantation-tool 332 | main-is: Main.hs 333 | other-modules: 334 | Options 335 | SubCmd 336 | SubCmd.Config 337 | SubCmd.Member 338 | SubCmd.Org 339 | SubCmd.Problem 340 | SubCmd.Repo 341 | Paths_git_plantation 342 | hs-source-dirs: 343 | exec/tool 344 | default-extensions: 345 | NoImplicitPrelude 346 | GHC2021 347 | ConstraintKinds 348 | FlexibleContexts 349 | FlexibleInstances 350 | GeneralizedNewtypeDeriving 351 | OverloadedStrings 352 | PolyKinds 353 | RankNTypes 354 | StandaloneDeriving 355 | TypeFamilies 356 | TypeSynonymInstances 357 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 358 | build-depends: 359 | aeson 360 | , base >=4.7 && <5 361 | , binary 362 | , blaze-html 363 | , containers 364 | , cryptonite 365 | , dotenv 366 | , elmap 367 | , esqueleto 368 | , exceptions 369 | , extensible >=0.6 370 | , extensible-elmap 371 | , fallible 372 | , git-plantation 373 | , github 374 | , github-webhooks >=0.17.0 375 | , gitrev 376 | , http-api-data 377 | , http-media 378 | , memory 379 | , mix 380 | , mix-json-logger 381 | , mix-plugin-github 382 | , mix-plugin-persistent-sqlite 383 | , mix-plugin-shell 384 | , mtl 385 | , optparse-applicative 386 | , persistent 387 | , persistent-template 388 | , random 389 | , req >=2.0 390 | , rio >=0.1.1.0 391 | , servant 392 | , servant-auth-server 393 | , servant-blaze 394 | , servant-elmap 395 | , servant-github-webhook 396 | , servant-server 397 | , shelly 398 | , template-haskell 399 | , time 400 | , unliftio 401 | , websockets 402 | , wreq 403 | , yaml >=0.8.31 404 | default-language: Haskell2010 405 | 406 | test-suite generateElm 407 | type: exitcode-stdio-1.0 408 | main-is: GenerateElm.hs 409 | hs-source-dirs: 410 | test 411 | default-extensions: 412 | NoImplicitPrelude 413 | GHC2021 414 | ConstraintKinds 415 | FlexibleContexts 416 | FlexibleInstances 417 | GeneralizedNewtypeDeriving 418 | OverloadedStrings 419 | PolyKinds 420 | RankNTypes 421 | StandaloneDeriving 422 | TypeFamilies 423 | TypeSynonymInstances 424 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 425 | build-depends: 426 | aeson 427 | , base >=4.7 && <5 428 | , binary 429 | , blaze-html 430 | , containers 431 | , cryptonite 432 | , dotenv 433 | , elmap 434 | , esqueleto 435 | , exceptions 436 | , extensible >=0.6 437 | , extensible-elmap 438 | , fallible 439 | , git-plantation 440 | , github 441 | , github-webhooks >=0.17.0 442 | , http-api-data 443 | , http-media 444 | , memory 445 | , mix 446 | , mix-json-logger 447 | , mix-plugin-github 448 | , mix-plugin-persistent-sqlite 449 | , mix-plugin-shell 450 | , mtl 451 | , persistent 452 | , persistent-template 453 | , random 454 | , req >=2.0 455 | , rio >=0.1.1.0 456 | , servant 457 | , servant-auth-server 458 | , servant-blaze 459 | , servant-elmap 460 | , servant-github-webhook 461 | , servant-server 462 | , shelly 463 | , template-haskell 464 | , time 465 | , unliftio 466 | , websockets 467 | , wreq 468 | , yaml >=0.8.31 469 | default-language: Haskell2010 470 | 471 | test-suite spec 472 | type: exitcode-stdio-1.0 473 | main-is: Spec.hs 474 | other-modules: 475 | Fixture 476 | Spec.Git.Plantation.Score 477 | Paths_git_plantation 478 | hs-source-dirs: 479 | test/spec 480 | default-extensions: 481 | NoImplicitPrelude 482 | GHC2021 483 | ConstraintKinds 484 | FlexibleContexts 485 | FlexibleInstances 486 | GeneralizedNewtypeDeriving 487 | OverloadedStrings 488 | PolyKinds 489 | RankNTypes 490 | StandaloneDeriving 491 | TypeFamilies 492 | TypeSynonymInstances 493 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 494 | build-depends: 495 | aeson 496 | , base >=4.7 && <5 497 | , binary 498 | , blaze-html 499 | , containers 500 | , cryptonite 501 | , dotenv 502 | , elmap 503 | , esqueleto 504 | , exceptions 505 | , extensible >=0.6 506 | , extensible-elmap 507 | , fallible 508 | , git-plantation 509 | , github 510 | , github-webhooks >=0.17.0 511 | , hspec 512 | , http-api-data 513 | , http-media 514 | , memory 515 | , mix 516 | , mix-json-logger 517 | , mix-plugin-github 518 | , mix-plugin-persistent-sqlite 519 | , mix-plugin-shell 520 | , mtl 521 | , persistent 522 | , persistent-template 523 | , random 524 | , req >=2.0 525 | , rio >=0.1.1.0 526 | , servant 527 | , servant-auth-server 528 | , servant-blaze 529 | , servant-elmap 530 | , servant-github-webhook 531 | , servant-server 532 | , shelly 533 | , tasty 534 | , tasty-hspec 535 | , template-haskell 536 | , th-lift-instances 537 | , time 538 | , unliftio 539 | , websockets 540 | , wreq 541 | , yaml >=0.8.31 542 | default-language: Haskell2010 543 | --------------------------------------------------------------------------------