├── .gitignore ├── .obelisk └── impl │ ├── default.nix │ └── github.json ├── CHANGELOG.md ├── LICENSE ├── README.md ├── backend ├── backend.cabal ├── frontend.jsexe ├── frontendJs │ └── frontend.jsexe ├── src-bin │ └── main.hs ├── src │ ├── Backend.hs │ ├── Backend │ │ ├── Build.hs │ │ ├── Cache.hs │ │ ├── CacheServer.hs │ │ ├── Common.hs │ │ ├── Db.hs │ │ ├── DbLib.hs │ │ ├── ExecutablePaths.hs │ │ ├── Github.hs │ │ ├── Gitlab.hs │ │ ├── Gitlab │ │ │ ├── Request.hs │ │ │ └── Schema.hs │ │ ├── NixBase32.hs │ │ ├── Process.hs │ │ ├── Schedule.hs │ │ ├── Types │ │ │ ├── BackendSettings.hs │ │ │ ├── ConnRepo.hs │ │ │ ├── NixCacheKeyPair.hs │ │ │ └── ServerEnv.hs │ │ ├── WsCmds.hs │ │ └── WsUtils.hs │ └── Nix │ │ └── Types.hs └── static ├── cabal.project ├── common ├── common.cabal └── src │ ├── Common │ ├── Api.hs │ ├── Route.hs │ └── Types │ │ ├── BinaryCache.hs │ │ ├── BuildJob.hs │ │ ├── Builder.hs │ │ ├── CacheJob.hs │ │ ├── CachedHash.hs │ │ ├── CiSettings.hs │ │ ├── ConnectedAccount.hs │ │ ├── GitHash.hs │ │ ├── JobStatus.hs │ │ ├── NixCacheKeyPair.hs │ │ ├── ProcMsg.hs │ │ ├── Repo.hs │ │ ├── RepoBuildInfo.hs │ │ └── S3Cache.hs │ └── Humanizable.hs ├── default.nix ├── deps ├── github │ ├── default.nix │ ├── github.json │ └── thunk.nix └── reflex-dom-contrib │ ├── default.nix │ ├── github.json │ └── thunk.nix ├── frontend.jsexe.assets ├── frontend ├── frontend.cabal ├── src-bin │ └── main.hs └── src │ ├── Frontend.hs │ └── Frontend │ ├── App.hs │ ├── AppState.hs │ ├── Common.hs │ ├── Nav.hs │ └── Widgets │ ├── Accounts.hs │ ├── Caches.hs │ ├── Common.hs │ ├── Form.hs │ ├── Jobs.hs │ ├── Repos.hs │ └── Settings.hs ├── makeLinks ├── migrations.md ├── static.assets └── static ├── css └── custom.css ├── favicon.svg ├── jquery-3.1.1.min.js ├── semantic.min.css ├── semantic.min.js └── themes └── default └── assets ├── fonts ├── brand-icons.eot ├── brand-icons.svg ├── brand-icons.ttf ├── brand-icons.woff ├── brand-icons.woff2 ├── icons.eot ├── icons.otf ├── icons.svg ├── icons.ttf ├── icons.woff ├── icons.woff2 ├── outline-icons.eot ├── outline-icons.svg ├── outline-icons.ttf ├── outline-icons.woff └── outline-icons.woff2 └── images └── flags.png /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | result 4 | result-android 5 | result-ios 6 | result-exe 7 | .attr-cache 8 | ghcid-output.txt 9 | config/backend 10 | zeus-access-token 11 | zeus.db 12 | .ghc.environment* 13 | log 14 | webhook-baseurl 15 | *.swp 16 | *.pub 17 | *.sec 18 | config 19 | -------------------------------------------------------------------------------- /.obelisk/impl/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import ((import {}).fetchFromGitHub ( 3 | let json = builtins.fromJSON (builtins.readFile ./github.json); 4 | in { inherit (json) owner repo rev sha256; 5 | private = json.private or false; 6 | } 7 | )) 8 | -------------------------------------------------------------------------------- /.obelisk/impl/github.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "obsidiansystems", 3 | "repo": "obelisk", 4 | "branch": "develop", 5 | "rev": "06da48feca28e9b85cd745acb6a2b4c3f9e782e9", 6 | "sha256": "1vxch6x3xycdds899f7m6ah298bn2k208vgnlcpl1rp68nsa8hkg" 7 | } 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Zeus Changelog 2 | 3 | ## 2020-07-15 Change DB keys to Int32 4 | 5 | An upgrade to the Beam DB library resulted in columns with type INTEGER changing 6 | to BIGINT. We avoid a migration by changing these types to Int32. 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Doug Beardsley 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its contributors 15 | may be used to endorse or promote products derived from this software without 16 | specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /backend/backend.cabal: -------------------------------------------------------------------------------- 1 | name: backend 2 | version: 0.1 3 | cabal-version: >= 1.8 4 | build-type: Simple 5 | 6 | library 7 | hs-source-dirs: src 8 | if impl(ghcjs) 9 | buildable: False 10 | build-depends: 11 | aeson >= 1.3 && < 1.5 12 | , amazonka 13 | , amazonka-core 14 | , amazonka-s3 15 | , barbies 16 | , base >= 4.10 && < 4.13 17 | , base16-bytestring >= 0.1 && < 0.2 18 | , base64-bytestring >= 1.0 && < 1.1 19 | , beam-core 20 | , beam-migrate 21 | , beam-sqlite 22 | , bytestring >= 0.10.8 && < 0.11 23 | , cases >= 0.1 && < 0.2 24 | , common 25 | , containers >= 0.5 && < 0.7 26 | , dependent-sum 27 | , directory >= 1.3.0 && < 1.4 28 | , ed25519 29 | , errors >= 2.3.0 && < 2.4 30 | , filepath 31 | , foldl 32 | , frontend 33 | , github >= 0.21 && < 0.27 34 | , github-webhooks >= 0.10 && < 0.11 35 | , http-client 36 | , http-client-tls >= 0.3.5 && < 0.4 37 | , http-types >= 0.12.1 && < 0.13 38 | , lens 39 | , lens-aeson >= 1.0.2 && < 1.1 40 | , mtl >= 2.2.2 && < 2.3 41 | , network 42 | , obelisk-backend 43 | , obelisk-executable-config-lookup 44 | , obelisk-route 45 | , process 46 | , readable >= 0.3.1 && < 0.4 47 | , rng-utils >= 0.3 && < 0.4 48 | , scrub 49 | , shelly 50 | , snap-core >= 1.0 && < 1.1 51 | , snap-server >= 1.1 && < 1.2 52 | , sqlite-simple >= 0.4.16 && < 0.5 53 | , stm 54 | , string-conv >= 0.1.2 && < 0.2 55 | , template-haskell 56 | , text >= 1.2.3 && < 1.3 57 | , tasty 58 | , tasty-hunit 59 | , time >= 1.8.0 && < 1.9 60 | , transformers >= 0.5.2 && < 0.6 61 | , turtle 62 | , uri-bytestring >= 0.3 && < 0.4 63 | , vector >= 0.12.0 && < 0.13 64 | , websockets 65 | , websockets-snap 66 | , which 67 | exposed-modules: 68 | Backend 69 | Backend.Build 70 | Backend.Cache 71 | Backend.CacheServer 72 | Backend.Common 73 | Backend.Db 74 | Backend.DbLib 75 | Backend.ExecutablePaths 76 | Backend.Github 77 | Backend.Gitlab 78 | -- Backend.Gitlab.Request 79 | Backend.Gitlab.Schema 80 | Backend.NixBase32 81 | Backend.Process 82 | Backend.Schedule 83 | Backend.Types.BackendSettings 84 | Backend.Types.ConnRepo 85 | Backend.Types.NixCacheKeyPair 86 | Backend.Types.ServerEnv 87 | Backend.WsCmds 88 | Backend.WsUtils 89 | Nix.Types 90 | ghc-options: -Wall 91 | 92 | executable backend 93 | main-is: main.hs 94 | hs-source-dirs: src-bin 95 | if impl(ghcjs) 96 | buildable: False 97 | ghc-options: -threaded -Wall -O 98 | build-depends: 99 | aeson, 100 | ansi-wl-pprint, 101 | backend, 102 | base, 103 | beam-core, 104 | beam-sqlite, 105 | bytestring, 106 | common, 107 | directory, 108 | frontend, 109 | github, 110 | lens, 111 | mtl, 112 | obelisk-backend, 113 | optparse-applicative, 114 | rng-utils, 115 | snap-core, 116 | snap-server, 117 | sqlite-simple, 118 | stm, 119 | string-conv, 120 | tasty, 121 | tasty-hunit, 122 | text, 123 | time, 124 | transformers 125 | -------------------------------------------------------------------------------- /backend/frontend.jsexe: -------------------------------------------------------------------------------- 1 | ../frontend-js/bin/frontend.jsexe -------------------------------------------------------------------------------- /backend/frontendJs/frontend.jsexe: -------------------------------------------------------------------------------- 1 | ../../frontend-js/bin/frontend.jsexe -------------------------------------------------------------------------------- /backend/src-bin/main.hs: -------------------------------------------------------------------------------- 1 | import Backend 2 | import Frontend 3 | import Obelisk.Backend 4 | 5 | main :: IO () 6 | main = runBackend backend frontend 7 | -------------------------------------------------------------------------------- /backend/src/Backend/CacheServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module Backend.CacheServer where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Control.Monad 10 | import Control.Monad.Trans 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Base16 as Base16 13 | import Data.List 14 | import Data.Maybe 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | import qualified Data.Text.Encoding as T 18 | import qualified Data.Text.IO as T 19 | import Database.SQLite.Simple 20 | import Snap.Core 21 | import System.Process 22 | import Text.Printf 23 | import qualified Turtle.Bytes as T 24 | ------------------------------------------------------------------------------ 25 | import Backend.Common 26 | import Backend.ExecutablePaths 27 | import qualified Backend.NixBase32 as Base32 28 | import Backend.Types.NixCacheKeyPair 29 | import Backend.Types.ServerEnv 30 | import Nix.Types 31 | ------------------------------------------------------------------------------ 32 | 33 | fingerprintPath :: Text -> Text -> Int -> [Text] -> Either String Text 34 | fingerprintPath storePath narHash narSize refs = do 35 | (hashType,hash) <- mkBase32 narHash 36 | pure $ "1;" <> T.intercalate ";" 37 | [ storePath, hashType <> ":" <> hash, T.pack (show narSize) 38 | , T.intercalate "," refs 39 | ] 40 | 41 | fingerprintVP :: ValidPath -> [Text] -> Either String Text 42 | fingerprintVP (ValidPath _ p h _ _ (Just s) _ _ _) refs = 43 | fingerprintPath p h s refs 44 | fingerprintVP _ _ = Left "NarSize not available" 45 | 46 | ------------------------------------------------------------------------------ 47 | -- | Similar to queryPathInfo / queryPathInfoUncached in the Nix C++ code. 48 | queryStorePathInfo :: Connection -> FilePath -> IO (Maybe ValidPath) 49 | queryStorePathInfo conn storePath = do 50 | vpRes <- query conn "select * from ValidPaths where path = ? limit 1" (Only storePath) 51 | return $ listToMaybe vpRes 52 | 53 | mkBase32 :: Text -> Either String (Text,Text) 54 | mkBase32 narHash = (hashType,) <$> base32hash 55 | where 56 | (hashType,hash) = T.breakOn ":" narHash 57 | hashBS = T.encodeUtf8 $ T.drop 1 hash 58 | base32hash = 59 | case T.length narHash of 60 | 71 -> let (bs,rest) = Base16.decode hashBS 61 | in if B.length rest > 0 62 | then Left $ printf "Hash didn't decode completely (%s), rest=%s\n" 63 | (T.decodeUtf8 hashBS) (T.decodeUtf8 rest) 64 | else Right (Base32.encode bs) 65 | 59 -> Right $ T.decodeUtf8 hashBS 66 | _ -> Left $ printf "Hash had unexpected length (%s)\n" (T.decodeUtf8 hashBS) 67 | 68 | nixCacheRoutes :: ServerEnv -> [Text] -> Snap () 69 | nixCacheRoutes se ps = do 70 | case ps of 71 | ["nix-cache-info"] -> cacheInfoHandler 72 | ["nar", nar] -> narHandler nar 73 | [p] -> otherHandler se p 74 | _ -> notFound "File not found." 75 | 76 | stripPath :: Text -> Text 77 | stripPath = T.takeWhileEnd (/= '/') 78 | 79 | storePathHash :: Text -> Text 80 | storePathHash = T.takeWhile (/= '-') . T.takeWhileEnd (/= '/') 81 | 82 | otherHandler :: ServerEnv -> Text -> Snap () 83 | otherHandler se file = do 84 | case T.breakOn ".narinfo" file of 85 | (hash, ".narinfo") -> do 86 | sd <- read <$> liftIO (getNixConfigAttr "nixStoreDir") 87 | bracketSnap (open nixSqliteDb) close $ \conn -> do 88 | let prefix = sd <> "/" <> hash 89 | vpRes <- liftIO $ query conn "select * from ValidPaths where path >= ? limit 1" (Only prefix) 90 | case vpRes of 91 | [vp] -> do 92 | refs <- fmap (sort . fmap fromOnly) $ liftIO $ query conn 93 | "select path from Refs join ValidPaths on reference = id where referrer = ?" 94 | (Only $ _validPath_id vp) 95 | case fingerprintVP vp refs of 96 | Left e -> do 97 | liftIO $ putStrLn $ "otherHandler in Left: " <> e 98 | modifyResponse $ setResponseStatus 500 "Error constructing fingerprint" 99 | writeText $ T.pack e 100 | getResponse >>= finishWith 101 | Right fingerprint -> do 102 | modifyResponse (setContentType "text/x-nix-narinfo") 103 | writeText $ T.pack $ printf "StorePath: %s\n" (_validPath_path vp) 104 | writeText $ T.pack $ printf "URL: nar/%s.nar\n" hash 105 | writeText $ T.pack $ printf "Compression: none\n" 106 | (hashType, base32hash) <- case mkBase32 (_validPath_hash vp) of 107 | Left e -> error $ "Bad hash in nix sqlite DB: " <> e 108 | Right h -> return h 109 | writeText $ T.pack $ printf "NarHash: %s:%s\n" hashType base32hash 110 | writeText $ T.pack $ printf "NarSize: %s\n" (maybe "NULL" show $ _validPath_narSize vp) 111 | when (length refs > 0) $ 112 | writeText $ T.pack $ printf "References: %s\n" 113 | (T.unwords $ map stripPath refs) 114 | case _validPath_deriver vp of 115 | Nothing -> return () 116 | Just deriver -> 117 | writeText $ T.pack $ printf "Deriver: %s\n" (stripPath deriver) 118 | 119 | let secret = _nixCacheKey_secret $ _serverEnv_cacheKey se 120 | liftIO $ T.putStrLn $ "fingerprint: " <> fingerprint 121 | let sig = mkNixSig secret (T.encodeUtf8 fingerprint) 122 | writeText $ "Sig: " <> sig <> "\n" 123 | _ -> notFound "No such path." 124 | _ -> notFound "Cache server" 125 | 126 | getNixConfigAttr :: String -> IO String 127 | getNixConfigAttr attr = do 128 | let args = [ "--eval" 129 | , "--strict" 130 | , "" 131 | , "-A" 132 | , attr 133 | ] 134 | -- TODO Suppress warning going to stderr 135 | readCreateProcess (proc nixInstantiate args) "" 136 | 137 | cacheInfoHandler :: MonadSnap m => m () 138 | cacheInfoHandler = do 139 | modifyResponse (setContentType "text/plain") 140 | writeText =<< liftIO getCacheInfo 141 | 142 | getCacheInfo :: IO Text 143 | getCacheInfo = do 144 | sd <- read <$> getNixConfigAttr "nixStoreDir" 145 | return $ cacheInfo sd 146 | 147 | cacheInfo :: Text -> Text 148 | cacheInfo storeDir = T.unlines 149 | [ "StoreDir: " <> storeDir 150 | , "WantMassQuery: 1" 151 | , "Priority: 30" 152 | ] 153 | 154 | 155 | storePathForHash :: Text -> Text -> IO (Maybe Text) 156 | storePathForHash storeDir hash = withConnection nixSqliteDb $ \conn -> do 157 | let prefix = storeDir <> "/" <> hash 158 | res <- query conn "select path from ValidPaths where path >= ? limit 1" (Only prefix) 159 | case res of 160 | [Only storePath] -> return $ Just storePath 161 | _ -> return Nothing 162 | 163 | data NarType = NarZipped | NarPlain 164 | 165 | narHandler :: MonadSnap m => Text -> m () 166 | narHandler file = do 167 | sd <- read <$> liftIO (getNixConfigAttr "nixStoreDir") 168 | let (hash, extension) = T.breakOn "." file 169 | mnt = case extension of 170 | ".nar.bz2" -> Just NarZipped 171 | ".nar" -> Just NarPlain 172 | _ -> Nothing 173 | msp <- liftIO $ storePathForHash sd hash 174 | case msp of 175 | Nothing -> notFound "No such path." 176 | Just sp -> do 177 | case mnt of 178 | Nothing -> notFound "File not found." 179 | Just nt -> do 180 | modifyResponse (setContentType "text/plain") 181 | let dumpCmd = T.pack $ printf "%s --dump '%s'" nixStore sp 182 | let cmd = case nt of 183 | NarZipped -> dumpCmd <> " | " <> T.pack bzip2 <> " --fast" 184 | NarPlain -> dumpCmd 185 | (_, out) <- T.shellStrict cmd "" 186 | writeBS out 187 | -------------------------------------------------------------------------------- /backend/src/Backend/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Backend.Common where 3 | 4 | import Data.ByteString (ByteString) 5 | import Snap.Core 6 | 7 | ------------------------------------------------------------------------------- 8 | -- | Discard anything after this and return given status code to HTTP 9 | -- client immediately. 10 | finishEarly :: MonadSnap m => Int -> ByteString -> m b 11 | finishEarly code str = do 12 | modifyResponse $ setResponseStatus code str 13 | modifyResponse $ addHeader "Content-Type" "text/plain" 14 | writeBS str 15 | getResponse >>= finishWith 16 | 17 | 18 | ------------------------------------------------------------------------------- 19 | -- | Finish early with error code 400 20 | badReq :: MonadSnap m => ByteString -> m b 21 | badReq = finishEarly 400 22 | 23 | 24 | ------------------------------------------------------------------------------- 25 | -- | Finish early with error code 404 26 | notFound :: MonadSnap m => ByteString -> m b 27 | notFound = finishEarly 404 28 | 29 | 30 | ------------------------------------------------------------------------------- 31 | -- | Finish early with error code 500 32 | serverError :: MonadSnap m => ByteString -> m b 33 | serverError = finishEarly 500 34 | -------------------------------------------------------------------------------- /backend/src/Backend/Db.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NoMonomorphismRestriction #-} 10 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE TypeApplications #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# LANGUAGE TypeSynonymInstances #-} 19 | {-# LANGUAGE UndecidableInstances #-} 20 | 21 | module Backend.Db where 22 | 23 | ------------------------------------------------------------------------------ 24 | import Data.Time 25 | import Database.Beam 26 | import Database.Beam.Migrate.Generics 27 | import Database.Beam.Migrate.Simple 28 | import Database.Beam.Sqlite.Connection 29 | import Database.SQLite.Simple 30 | ------------------------------------------------------------------------------ 31 | import Common.Types.BinaryCache 32 | import Common.Types.CacheJob 33 | import Common.Types.CachedHash 34 | import Common.Types.CiSettings 35 | import Common.Types.ConnectedAccount 36 | import Common.Types.Builder 37 | import Common.Types.BuildJob 38 | import Common.Types.JobStatus 39 | import Common.Types.Repo 40 | import Common.Types.RepoBuildInfo 41 | ------------------------------------------------------------------------------ 42 | 43 | ------------------------------------------------------------------------------ 44 | data CiDb f = CiDb 45 | { _ciDb_connectedAccounts :: f (TableEntity ConnectedAccountT) 46 | , _ciDb_repos :: f (TableEntity RepoT) 47 | , _ciDb_builders :: f (TableEntity BuilderT) 48 | , _ciDb_buildJobs :: f (TableEntity BuildJobT) 49 | , _ciDb_ciSettings :: f (TableEntity CiSettingsT) 50 | , _ciDb_cacheJobs :: f (TableEntity CacheJobT) 51 | , _ciDb_binaryCaches :: f (TableEntity BinaryCacheT) 52 | , _ciDb_cachedHashes :: f (TableEntity CachedHashT) 53 | } deriving (Generic, Database be) 54 | 55 | --ciDbChecked :: BeamMigrateSqlBackend be => CheckedDatabaseSettings be CiDb 56 | --ciDbChecked = defaultMigratableDbSettings @_ @CiDb 57 | ciDbChecked :: CheckedDatabaseSettings Sqlite CiDb 58 | ciDbChecked = defaultMigratableDbSettings 59 | 60 | --ciDb :: DatabaseSettings be CiDb 61 | ciDb :: DatabaseSettings Sqlite CiDb 62 | ciDb = unCheckDatabase ciDbChecked 63 | -- `withDbModification` 64 | -- renamingFields (snakify . T.takeWhileEnd (/= '_') . defaultFieldName) 65 | 66 | CiDb (TableLens ciDb_connectedAccounts) 67 | (TableLens ciDb_repos) 68 | (TableLens ciDb_builders) 69 | (TableLens ciDb_buildJobs) 70 | (TableLens ciDb_ciSettings) 71 | (TableLens ciDb_cacheJobs) 72 | (TableLens ciDb_binaryCache) 73 | (TableLens ciDb_cachedHash) 74 | = dbLenses 75 | 76 | populateDb :: Connection -> IO () 77 | populateDb conn = do 78 | now <- getCurrentTime 79 | -- let accounts = 80 | -- [ ConnectedAccount default_ (val_ "mightybyte") (val_ "0000000000000000000000000000000000000000") ] 81 | let rbi = RepoBuildInfo 82 | "dummy" "mightybyte/dummy" RepoPush "ssh://..." "https://..." "1234" 83 | "a8cd23" "Dummy commit" "Alice Coder" 84 | (Just "https://secure.gravatar.com/avatar/0cece5abd2f9ad9056f5ac3830ac0bfe?s=80&d=identicon") 85 | start = addUTCTime (-82) now 86 | runBeamSqlite conn $ do 87 | runInsert $ insert (_ciDb_buildJobs ciDb) $ insertExpressions 88 | [ BuildJob default_ (val_ rbi) (val_ start) (val_ $ Just start) (val_ $ Just now) (val_ JobSucceeded) 89 | ] 90 | -------------------------------------------------------------------------------- /backend/src/Backend/DbLib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Backend.DbLib where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Control.Lens 7 | import Data.Int 8 | import Database.Beam 9 | import Database.SQLite.Simple 10 | ------------------------------------------------------------------------------ 11 | import Backend.Db 12 | import Backend.Types.ServerEnv 13 | import Common.Types.CiSettings 14 | ------------------------------------------------------------------------------ 15 | 16 | globalCiSettingsKey :: Int32 17 | globalCiSettingsKey = 0 18 | 19 | defCiSettings :: CiSettings 20 | defCiSettings = CiSettings globalCiSettingsKey "nixpkgs=/nix/var/nix/profiles/per-user/root/channels/nixos" True 21 | 22 | getCiSettings :: Connection -> IO (Maybe CiSettings) 23 | getCiSettings dbConn = do 24 | beamQueryConn dbConn $ 25 | runSelectReturningOne $ select $ do 26 | ci <- all_ (_ciDb_ciSettings ciDb) 27 | guard_ (ci ^. ciSettings_id ==. (val_ globalCiSettingsKey)) 28 | return ci 29 | 30 | setCiSettings :: Connection -> CiSettings -> IO () 31 | setCiSettings dbConn (CiSettings _ np slc) = do 32 | beamQueryConn dbConn $ do 33 | --ms <- runSelectReturningOne $ select $ do 34 | -- ci <- all_ (_ciDb_ciSettings ciDb) 35 | -- guard_ (ci ^. ciSettings_id ==. (val_ 1)) 36 | -- return ci 37 | runUpdate $ 38 | update (_ciDb_ciSettings ciDb) 39 | (\ci -> mconcat 40 | [ ci ^. ciSettings_nixPath <-. val_ np 41 | , ci ^. ciSettings_serveLocalCache <-. val_ slc 42 | ]) 43 | (\ci -> _ciSettings_id ci ==. val_ 1) 44 | 45 | initCiSettings :: Connection -> CiSettings -> IO () 46 | initCiSettings dbConn (CiSettings i a slc) = do 47 | beamQueryConn dbConn $ runInsert $ insert (_ciDb_ciSettings ciDb) $ 48 | insertExpressions [CiSettings (val_ i) (val_ a) (val_ slc)] 49 | -------------------------------------------------------------------------------- /backend/src/Backend/ExecutablePaths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Backend.ExecutablePaths where 4 | 5 | import System.Which 6 | 7 | gitBinary :: String 8 | gitBinary = $(staticWhich "git") 9 | 10 | nixBinary :: String 11 | nixBinary = $(staticWhich "nix") 12 | 13 | nixBuildBinary :: String 14 | nixBuildBinary = $(staticWhich "nix-build") 15 | 16 | nixInstantiate :: String 17 | nixInstantiate = $(staticWhich "nix-instantiate") 18 | 19 | nixStore :: String 20 | nixStore = $(staticWhich "nix-store") 21 | 22 | bzip2 :: String 23 | bzip2 = $(staticWhich "bzip2") 24 | 25 | xzBinary :: String 26 | xzBinary = $(staticWhich "xz") 27 | 28 | awsBinary :: String 29 | awsBinary = $(staticWhich "aws") 30 | -------------------------------------------------------------------------------- /backend/src/Backend/Github.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Backend.Github where 10 | 11 | ------------------------------------------------------------------------------ 12 | import Control.Error 13 | import Control.Monad.Trans 14 | import Data.Aeson 15 | import Data.ByteString (ByteString) 16 | import qualified Data.ByteString.Lazy.Char8 as LB 17 | import qualified Data.Map as M 18 | import Data.String.Conv 19 | import Data.Text (Text) 20 | import qualified Data.Text as T 21 | import Data.Text.Encoding 22 | import qualified Data.Vector as V 23 | import GitHub.Data 24 | import GitHub.Data.Definitions 25 | import GitHub.Data.Name 26 | import qualified GitHub.Data.Webhooks.Events as GW 27 | import qualified GitHub.Data.Webhooks.Payload as GW 28 | import GitHub.Data.Webhooks.Validate 29 | import GitHub.Endpoints.Repos.Statuses 30 | import GitHub.Endpoints.Repos.Webhooks 31 | import GitHub.Request 32 | import Snap.Core 33 | import Text.Printf 34 | ------------------------------------------------------------------------------ 35 | import Backend.Schedule 36 | import Backend.Types.ServerEnv 37 | import Common.Route 38 | import Common.Types.GitHash 39 | import Common.Types.RepoBuildInfo 40 | ------------------------------------------------------------------------------ 41 | 42 | githubHandler :: ServerEnv -> Snap () 43 | githubHandler env = do 44 | req <- getRequest 45 | body <- readRequestBody 1000000 46 | let event = getHeader "X-GitHub-Event" req 47 | sig = getHeader "X-Hub-Signature" req 48 | let isValid = isValidPayload (_serverEnv_secretToken env) 49 | (decodeUtf8 <$> sig) (toS body) 50 | if isValid 51 | then do 52 | liftIO $ putStrLn $ "Payload successfully validated: event=" ++ maybe "" toS event 53 | liftIO $ handleValidatedHook env event body 54 | else liftIO $ putStrLn "Payload not valid!" 55 | 56 | handleValidatedHook :: ServerEnv -> Maybe ByteString -> LB.ByteString -> IO () 57 | handleValidatedHook env event body = do 58 | res <- runExceptT $ do 59 | rbi <- hoistEither $ case event of 60 | Just "pull_request" -> do 61 | let decodeErr e = Left $ "Error decoding push message: " ++ e 62 | mkPrMsg rbi = Left $ 63 | printf "Ignoring pull request message on %s/%s commit %s" 64 | (_rbi_repoNamespace rbi) (_rbi_repoName rbi) 65 | (_rbi_commitHash rbi) 66 | either decodeErr (mkPrMsg . handlePR) $ eitherDecodeStrict (toS body) 67 | Just "push" -> mkPushRBI =<< eitherDecodeStrict (toS body) 68 | _ -> Left "Event not supported" 69 | 70 | lift $ scheduleBuild env rbi 71 | case res of 72 | Left e -> putStrLn e 73 | Right _ -> return () 74 | 75 | handlePR :: GW.PullRequestEvent -> RepoBuildInfo 76 | handlePR pre = do 77 | RepoBuildInfo 78 | (GW.whRepoName repo) 79 | (either GW.whSimplUserName GW.whUserLogin $ GW.whRepoOwner repo) 80 | RepoPullRequest (GW.getUrl $ GW.whRepoSshUrl repo) 81 | (GW.getUrl $ GW.whRepoCloneUrl repo) 82 | (GW.whPullReqTargetRef prHead) 83 | (GW.whPullReqTargetSha prHead) 84 | "" -- TODO Haven't found how to get the commit message from github yet 85 | (GW.whUserLogin $ GW.evPullReqSender pre) 86 | (Just $ GW.getUrl $ GW.whUserAvatarUrl $ GW.evPullReqSender pre) 87 | where 88 | pr = GW.evPullReqPayload pre 89 | repo = GW.evPullReqRepo pre 90 | prHead = GW.whPullReqHead pr 91 | 92 | 93 | mkPushRBI :: GW.PushEvent -> Either String RepoBuildInfo 94 | mkPushRBI pe = do 95 | sha <- note ("PushEvent didn't have git hash:\n" ++ show pe) $ 96 | GW.evPushHeadSha pe 97 | if sha == "0000000000000000000000000000000000000000" 98 | then Left "Push deleted a branch, doing nothing" 99 | else pure $ RepoBuildInfo 100 | (GW.whRepoName repo) 101 | (either GW.whSimplUserName GW.whUserLogin $ GW.whRepoOwner repo) 102 | RepoPush 103 | (GW.getUrl $ GW.whRepoSshUrl repo) 104 | (GW.getUrl $ GW.whRepoCloneUrl repo) 105 | (GW.evPushRef pe) 106 | sha 107 | "" -- TODO Haven't found how to get the commit message from github yet 108 | (GW.whUserLogin $ GW.evPushSender pe) 109 | (Just $ GW.getUrl $ GW.whUserAvatarUrl $ GW.evPushSender pe) 110 | where 111 | repo = GW.evPushRepository pe 112 | 113 | data SslSettings 114 | = AllowInsecure 115 | -- ^ Allow github to connect to this server insecurely 116 | | ForceSSL 117 | -- ^ Force github to use SSL. (Requires setting up a certificate.) 118 | deriving (Eq,Ord,Show,Read,Enum,Bounded) 119 | 120 | ------------------------------------------------------------------------------ 121 | -- | Adds the GitHub webhook necessary for allowing this server to do CI for a 122 | -- particular repo. 123 | setupGithubWebhook 124 | :: Text 125 | -- ^ Domain (optionally with port) that your hook will be served on 126 | -> Auth 127 | -- ^ Token authenticating you with GitHub so the webhook can be created. 128 | -- This can be a personal access token created at: 129 | -- https://github.com/settings/tokens 130 | -> Text 131 | -- ^ Owner of the repo (username or organization) 132 | -> Text 133 | -- ^ Name of the repo 134 | -> Text 135 | -- ^ Secret that github will use to authenticate with this CI server 136 | -> SslSettings 137 | -> IO (Either Error RepoWebhook) 138 | setupGithubWebhook domain auth owner repo secret sslSettings = do 139 | let url = domain <> "/" <> githubHookPath 140 | let cfg = M.fromList 141 | [ ("url", url) 142 | , ("content_type", "json") 143 | , ("secret", secret) 144 | 145 | -- TODO FIXME Change this once done debugging 146 | , ("insecure_ssl", ssl) 147 | ] 148 | events = Just $ V.fromList 149 | [ WebhookPushEvent 150 | , WebhookPullRequestEvent 151 | , WebhookStatusEvent 152 | ] 153 | eh <- executeRequest auth $ webhooksForR (N owner) (N repo) FetchAll 154 | case eh of 155 | Left e -> return $ Left e 156 | Right hooks -> do 157 | mapM_ print hooks 158 | case filter (\h -> hookUrl h == Just url) (V.toList hooks) of 159 | (h:_) -> return $ Right h 160 | _ -> do 161 | executeRequest auth $ createRepoWebhookR (N owner) (N repo) $ 162 | NewRepoWebhook "web" cfg events (Just True) 163 | where 164 | ssl = case sslSettings of 165 | AllowInsecure -> "1" 166 | ForceSSL -> "0" 167 | 168 | hookUrl :: RepoWebhook -> Maybe Text 169 | hookUrl hook = M.lookup "url" m 170 | where 171 | m = repoWebhookConfig hook 172 | 173 | simpleStatus :: StatusState -> NewStatus 174 | simpleStatus s = NewStatus s Nothing Nothing Nothing 175 | 176 | statusPending :: NewStatus 177 | statusPending = simpleStatus StatusPending 178 | 179 | statusError :: NewStatus 180 | statusError = simpleStatus StatusError 181 | 182 | statusSuccess :: NewStatus 183 | statusSuccess = simpleStatus StatusSuccess 184 | 185 | newStatus 186 | :: MonadIO m 187 | => Auth 188 | -> Text -- ^ owner 189 | -> Text -- ^ repo 190 | -> GitHash 191 | -> NewStatus 192 | -> m (Either Text Status) 193 | newStatus auth owner repo hash s = do 194 | result <- liftIO $ github auth createStatusR (N owner) (N repo) (N $ unGitHash hash) s 195 | case result of 196 | Left err -> return $ Left $ mconcat 197 | [ "Backend.Github.newStatus: Could not create status for " 198 | , owner 199 | , "/" 200 | , repo 201 | , ": " 202 | , T.pack (show err) 203 | ] 204 | Right s -> return $ Right s 205 | -------------------------------------------------------------------------------- /backend/src/Backend/Gitlab.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Backend.Gitlab where 6 | 7 | ------------------------------------------------------------------------------ 8 | import Control.Lens hiding ((.=)) 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Data.Aeson 12 | import Data.Aeson.Lens 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString.Lazy as LB 15 | import Data.String.Conv 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import Network.HTTP.Client 20 | import qualified Network.HTTP.Client as HC 21 | import Network.HTTP.Client.TLS 22 | import Snap.Core 23 | ------------------------------------------------------------------------------ 24 | import Backend.Common 25 | import Backend.Gitlab.Schema 26 | import Backend.Schedule 27 | import Backend.Types.ServerEnv 28 | import Common.Route 29 | import Common.Types.RepoBuildInfo 30 | ------------------------------------------------------------------------------ 31 | 32 | gitlabHandler :: ServerEnv -> Snap () 33 | gitlabHandler env = do 34 | checkToken $ _serverEnv_secretToken env 35 | eventHeader <- getHeader "X-Gitlab-Event" <$> getRequest 36 | body <- readRequestBody 1048576 -- TODO what should this number be? 37 | case eventHeader of 38 | Just "Merge Request Hook" -> gitlabMergeRequestHandler env $ eitherDecode body 39 | Just "Push Hook" -> do 40 | let mp :: Maybe Push = decode body 41 | forM_ mp $ \p -> liftIO $ do 42 | --liftIO $ print p 43 | let proj = _push_project p 44 | let fullpath = _project_path_with_namespace proj 45 | ns = T.dropEnd 1 $ T.dropWhileEnd (/= '/') fullpath 46 | let rbi = RepoBuildInfo 47 | (_project_name proj) 48 | ns 49 | RepoPush 50 | (_project_git_ssh_url proj) 51 | (_project_git_http_url proj) 52 | (_push_ref p) 53 | (unGitHash $ _push_checkout_sha p) 54 | (_commit_message $ head $ _push_commits p) 55 | (_push_user_name p) 56 | (_push_user_avatar p) 57 | 58 | scheduleBuild env rbi 59 | --checkOutstandingMergeRequests env p 60 | _ -> notFound "gitlab event" 61 | 62 | checkToken :: Text -> Snap () 63 | checkToken secret = do 64 | let secret' = T.encodeUtf8 secret 65 | tokenHeaders <- getHeader "X-Gitlab-Token" <$> getRequest 66 | guard (Just secret' == tokenHeaders) 67 | 68 | pushMessage :: Push -> Text 69 | pushMessage p = 70 | let num = _push_total_commits_count p 71 | maxCommitMessages = 10 72 | commits = take maxCommitMessages $ _push_commits p 73 | commitMessages = concatMap (\c -> ["—", _commit_message c]) commits 74 | extraCommits = if num > maxCommitMessages 75 | then ["...and " <> T.pack (show (num - maxCommitMessages)) <> " more."] 76 | else [] 77 | content = [ _push_user_name p 78 | , " pushed " 79 | , T.pack (show num) 80 | , " commit" 81 | , if num == 1 then "" else "s" 82 | , " to " 83 | , _push_ref p 84 | , " of " 85 | , _repository_name (_push_repository p) 86 | ] 87 | 88 | hash = [ "Hash: " 89 | , unGitHash $ _push_after p 90 | ] 91 | in T.unlines $ (mconcat <$> 92 | [ content 93 | , hash 94 | , commitMessages 95 | , extraCommits 96 | ]) ++ map _commit_url commits 97 | 98 | gitlabMergeRequestHandler :: ServerEnv -> Either String MergeRequest -> Snap () 99 | gitlabMergeRequestHandler _ _ = liftIO $ putStrLn "Got gitlab merge request" 100 | --case mmr of 101 | -- Left parseErr -> error $ "MR: Couldn't parse merge request payload: " <> parseErr 102 | -- Right mr | mergeRequestIsActionable mr -> do 103 | -- (obsolete, mrid) <- dbTransaction (_ci_db env) $ insertMergeRequest mr 104 | -- dbTransaction (_ci_db env) $ scheduleMerge mrid 105 | -- liftIO $ forM_ (NE.nonEmpty obsolete) $ unapproveMergeRequests env 106 | -- Right mr | _objectAttributes_state (_mergeRequest_object_attributes mr) `elem` ["merged", "closed"] -> 107 | -- void $ dbTransaction (_ci_db env) $ insertMergeRequest mr -- Insert this so that we know not to try to build this MR anymore 108 | -- Right mr -> liftIO $ putStrLn $ unwords 109 | -- [ "MR: Merge request update not actionable:" 110 | -- , "IID:" 111 | -- , show (_objectAttributes_iid $ _mergeRequest_object_attributes mr) 112 | -- , "State:" 113 | -- , show (_objectAttributes_state $ _mergeRequest_object_attributes mr) 114 | -- , "Action:" 115 | -- , show (_objectAttributes_action $ _mergeRequest_object_attributes mr) 116 | -- ] 117 | 118 | mkProjId :: Text -> Text -> Text 119 | mkProjId ns n = T.replace "/" "%2F" $ ns <> "/" <> n 120 | 121 | setupGitlabWebhook :: Text -> Text -> Text -> Text -> Text -> IO (Maybe Integer) 122 | setupGitlabWebhook domain gitlabNamespace gitlabProjectName gitlabSecret zeusAccessToken = do 123 | let projId = mkProjId gitlabNamespace gitlabProjectName 124 | o = object 125 | [ "id" .= projId 126 | , "url" .= (toS domain <> "/" <> gitlabHookPath) 127 | , "push_events" .= True 128 | -- , "push_events_branch_filter" .= "" 129 | , "merge_requests_events" .= True 130 | , "token" .= zeusAccessToken 131 | ] 132 | apiPath = "projects/" <> projId <> "/hooks" 133 | resp <- sendToGitlab "POST" apiPath gitlabSecret o 134 | return (responseBody resp ^? _Value . key "id" . _Integer) 135 | 136 | deleteGitlabWebhook :: Text -> Text -> Text -> Int -> IO () 137 | deleteGitlabWebhook gitlabNamespace gitlabProjectName gitlabSecret hookId = do 138 | -- TODO Use proper url encoding instead of this janky replace 139 | let projId = mkProjId gitlabNamespace gitlabProjectName 140 | apiPath = "projects/" <> projId <> "/hooks/" <> T.pack (show hookId) 141 | _ <- sendToGitlab "DELETE" apiPath gitlabSecret $ object 142 | [ "id" .= projId 143 | , "hook_id" .= hookId 144 | ] 145 | 146 | return () 147 | 148 | 149 | sendToGitlab :: ByteString -> Text -> Text -> Value -> IO (HC.Response LB.ByteString) 150 | sendToGitlab meth apiPath secret o = do 151 | m <- newTlsManager 152 | initReq <- parseRequest $ "https://gitlab.com/api/v4/" <> T.unpack apiPath 153 | let req = initReq 154 | { HC.method = meth 155 | , requestBody = RequestBodyLBS $ encode o 156 | , requestHeaders = [ ("Private-Token", T.encodeUtf8 secret) 157 | , ("Content-Type", "application/json") 158 | ] 159 | } 160 | httpLbs req m 161 | 162 | --Response {responseStatus = Status {statusCode = 401, statusMessage = "Unauthorized"}, 163 | -- responseVersion = HTTP/1.1, 164 | -- responseHeaders = [ 165 | -- ("Server","nginx"), 166 | -- ("Date","Tue, 04 Jun 2019 05:52:02 GMT"), 167 | -- ("Content-Type","application/json"), 168 | -- ("Content-Length","30"), 169 | -- ("Cache-Control","no-cache"), 170 | -- ("Vary","Origin"), 171 | -- ("X-Content-Type-Options","nosniff"), 172 | -- ("X-Frame-Options","SAMEORIGIN"), 173 | -- ("X-Request-Id","tcRqbrWquB7"), 174 | -- ("X-Runtime","0.019759"), 175 | -- ("RateLimit-Limit","600"), 176 | -- ("RateLimit-Observed","1"), 177 | -- ("RateLimit-Remaining","599"), 178 | -- ("RateLimit-Reset","1559627582"), 179 | -- ("RateLimit-ResetTime","Tue, 04 Jun 2019 05:53:02 GMT")], 180 | -- responseBody = "{\"message\":\"401 Unauthorized\"}", 181 | -- responseCookieJar = CJ {expose = []}, 182 | -- responseClose' = ResponseClose} 183 | -------------------------------------------------------------------------------- /backend/src/Backend/Gitlab/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module Backend.Gitlab.Request where 6 | 7 | ------------------------------------------------------------------------------ 8 | import Control.Lens 9 | import Data.Aeson 10 | import Data.Aeson.Lens 11 | import Data.List.NonEmpty (NonEmpty) 12 | import qualified Data.List.NonEmpty as NE 13 | import Data.Maybe (maybeToList) 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import qualified Data.Text.Encoding as T 17 | import Network.HTTP.Client 18 | import Reflex.FunctorMaybe 19 | ------------------------------------------------------------------------------ 20 | import Backend.Gitlab.Schema 21 | ------------------------------------------------------------------------------ 22 | 23 | getLabels 24 | :: Manager 25 | -> Text -- ^ Gitlab Token 26 | -> GitlabId -- ^ Project 27 | -> IO (Either String [Label]) 28 | getLabels mgr token pid = do 29 | req <- parseRequest $ projectApi pid "/labels" 30 | rsp <- httpLbs (applyAuth token req) mgr 31 | return $ eitherDecode $ responseBody rsp 32 | 33 | gitlabApi :: String -> String 34 | gitlabApi = (<>) "https://gitlab.com/api/v4" 35 | 36 | projectsApi :: String -> String 37 | projectsApi = gitlabApi . (<>) "/projects" 38 | 39 | projectApi :: GitlabId -> String -> String 40 | projectApi g = projectsApi . ("/" <>) . (show (unGitlabId g) <>) 41 | 42 | applyAuth :: Text -> Request -> Request 43 | applyAuth token req = req { requestHeaders = ("Private-Token", T.encodeUtf8 token) : requestHeaders req } 44 | 45 | addPostData :: Request -> Value -> Request 46 | addPostData r v = r { method = "POST", requestBody = RequestBodyLBS $ encode v } 47 | 48 | createLabel 49 | :: Manager 50 | -> Text 51 | -> GitlabId 52 | -> Text 53 | -> Text 54 | -> IO (Either String Label) 55 | createLabel mgr token gid name color = do 56 | req <- parseRequest $ projectApi gid "/labels" 57 | rsp <- flip httpLbs mgr $ applyAuth token $ flip urlEncodedBody req $ fmap (fmap T.encodeUtf8) 58 | [ ("name", name) 59 | , ("color", color) 60 | ] 61 | return $ eitherDecode $ responseBody rsp 62 | 63 | modifyMergeRequestApproval 64 | :: Bool -- ^ approve 65 | -> Manager -- ^ HTTP client manager 66 | -> Text -- ^ Gitlab token 67 | -> GitlabId -- ^ Project id 68 | -> Int -- ^ MR number/iid 69 | -> Maybe GitHash -- ^ Hash to specifically approve 70 | -> IO (Either String Value) 71 | modifyMergeRequestApproval approve mgr token gid mr hash = do 72 | req <- parseRequest $ projectApi gid $ "/merge_requests/" <> show mr <> (if approve then "/approve" else "/unapprove") 73 | rsp <- flip httpLbs mgr $ applyAuth token $ 74 | urlEncodedBody (maybeToList $ fmap (("sha",) . T.encodeUtf8 . unGitHash) hash) req 75 | return $ eitherDecode $ responseBody rsp 76 | 77 | approveMergeRequest 78 | :: Manager 79 | -> Text 80 | -> GitlabId 81 | -> Int 82 | -> GitHash 83 | -> IO (Either String Value) 84 | approveMergeRequest mgr a b c d = modifyMergeRequestApproval True mgr a b c (Just d) 85 | 86 | unapproveMergeRequest 87 | :: Manager 88 | -> Text 89 | -> GitlabId 90 | -> Int 91 | -> Maybe GitHash 92 | -> IO (Either String Value) 93 | unapproveMergeRequest = modifyMergeRequestApproval False 94 | 95 | getMergeRequest 96 | :: Manager 97 | -> Text -- ^ Token 98 | -> GitlabId -- ^ Project ID 99 | -> Int -- ^ Merge Request IID 100 | -> IO (Either String Value) 101 | getMergeRequest mgr token pid iid = do 102 | req <- parseRequest $ projectApi pid $ "/merge_requests/" <> show iid 103 | rsp <- flip httpLbs mgr $ applyAuth token req 104 | return $ eitherDecode $ responseBody rsp 105 | 106 | getMergeRequestStatus 107 | :: Manager 108 | -> Text -- ^ Token 109 | -> GitlabId -- ^ Project ID 110 | -> Int -- ^ Merge Request IID 111 | -> IO (Either String Text) 112 | getMergeRequestStatus mgr token pid iid = do 113 | rsp <- getMergeRequest mgr token pid iid 114 | case rsp of 115 | Left err -> return $ Left err 116 | Right v -> case v ^? key "state" . _String of 117 | Nothing -> return $ Left "getMergeRequestStatus: Couldn't parse merge request object" 118 | Just state -> return $ Right state 119 | 120 | getOpenMergeRequestSubset 121 | :: Manager 122 | -> Text -- ^ Token 123 | -> GitlabId -- ^ Project ID 124 | -> NonEmpty Int -- ^ Merge Request IIDs 125 | -> IO (Either String [Int]) 126 | getOpenMergeRequestSubset mgr token pid iids = do 127 | req <- parseRequest $ projectApi pid "/merge_requests" 128 | rsp <- flip httpLbs mgr $ applyAuth token req 129 | { queryString = T.encodeUtf8 $ T.pack $ mconcat $ 130 | "?state=opened" : fmap (\x -> "&iids[]=" <> show x) (NE.toList iids) 131 | } 132 | return $ case eitherDecode $ responseBody rsp of 133 | Left err -> Left err 134 | Right (vs :: [Value]) -> Right $ fmapMaybe iid vs -- TODO: What should we do on parse errors here? 135 | where 136 | iid :: Value -> Maybe Int 137 | iid v = fmap ((floor :: Double -> Int) . realToFrac) $ v ^? key "iid" . _Number 138 | -------------------------------------------------------------------------------- /backend/src/Backend/Gitlab/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Backend.Gitlab.Schema where 3 | 4 | import Data.Aeson 5 | import Data.Aeson.TH 6 | import Data.Int 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | 10 | newtype GitlabId = GitlabId { unGitlabId :: Int64 } 11 | deriving (Show, Read, Eq, Ord) 12 | 13 | instance FromJSON GitlabId where 14 | parseJSON a = GitlabId <$> parseJSON a 15 | 16 | instance ToJSON GitlabId where 17 | toJSON (GitlabId a) = toJSON a 18 | 19 | newtype GitHash = GitHash { unGitHash :: Text } 20 | deriving (Show, Read, Eq, Ord) 21 | 22 | instance FromJSON GitHash where 23 | parseJSON a = GitHash <$> parseJSON a 24 | 25 | instance ToJSON GitHash where 26 | toJSON (GitHash a) = toJSON a 27 | 28 | shortHash :: GitHash -> Text 29 | shortHash = T.take 8 . unGitHash 30 | 31 | data Project = Project 32 | { _project_id :: Maybe GitlabId 33 | , _project_name :: Text 34 | , _project_description :: Maybe Text 35 | , _project_web_url ::Maybe Text 36 | , _project_avatar_url ::Maybe Text 37 | , _project_git_ssh_url :: Text 38 | , _project_git_http_url :: Text 39 | , _project_namespace :: Text 40 | , _project_visibility_level :: Int 41 | , _project_path_with_namespace :: Text 42 | , _project_default_branch :: Text 43 | , _project_homepage ::Maybe Text 44 | , _project_url :: Text 45 | , _project_ssh_url :: Text 46 | , _project_http_url :: Text 47 | } 48 | deriving (Show, Read, Eq, Ord) 49 | 50 | deriveJSON defaultOptions 51 | { fieldLabelModifier = drop 9 52 | , omitNothingFields = True 53 | } ''Project 54 | 55 | data Repository = Repository 56 | { _repository_name :: Text 57 | , _repository_url :: Text 58 | , _repository_description :: Maybe Text 59 | , _repository_homepage ::Maybe Text 60 | , _repository_git_http_url :: Maybe Text 61 | , _repository_git_ssh_url :: Maybe Text 62 | , _repository_visibility_level :: Maybe Int 63 | } 64 | deriving (Show, Read, Eq, Ord) 65 | 66 | deriveJSON defaultOptions 67 | { fieldLabelModifier = drop 12 68 | , omitNothingFields = True 69 | } ''Repository 70 | 71 | data Author = Author 72 | { _author_name :: Text 73 | , _author_email :: Maybe Text 74 | } 75 | deriving (Show, Read, Eq, Ord) 76 | 77 | deriveJSON defaultOptions { fieldLabelModifier = drop 8 } ''Author 78 | 79 | data Commit = Commit 80 | { _commit_id :: GitHash 81 | , _commit_message :: Text 82 | , _commit_timestamp :: Text 83 | , _commit_url :: Text 84 | , _commit_author :: Author 85 | , _commit_added :: [Text] 86 | , _commit_modified :: [Text] 87 | , _commit_removed :: [Text] 88 | } 89 | deriving (Show, Read, Eq, Ord) 90 | 91 | deriveJSON defaultOptions 92 | { fieldLabelModifier = drop 8 93 | , omitNothingFields = True 94 | } ''Commit 95 | 96 | data CommitSummary = CommitSummary 97 | { _commitSummary_id :: GitHash 98 | , _commitSummary_message :: Text 99 | , _commitSummary_timestamp :: Text 100 | , _commitSummary_url :: Text 101 | , _commitSummary_author :: Author 102 | } 103 | deriving (Show, Read, Eq, Ord) 104 | 105 | deriveJSON defaultOptions 106 | { fieldLabelModifier = drop 15 107 | } ''CommitSummary 108 | 109 | 110 | data Push = Push 111 | { _push_object_kind :: Text 112 | , _push_before :: GitHash 113 | , _push_after :: GitHash 114 | , _push_ref :: Text 115 | , _push_checkout_sha :: GitHash 116 | , _push_user_id :: GitlabId 117 | , _push_user_name :: Text 118 | , _push_user_email :: Maybe Text 119 | , _push_user_avatar :: Maybe Text 120 | , _push_project_id :: GitlabId 121 | , _push_project :: Project 122 | , _push_repository :: Repository 123 | , _push_commits :: [Commit] 124 | , _push_total_commits_count :: Int 125 | } 126 | deriving (Show, Read, Eq, Ord) 127 | 128 | deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''Push 129 | 130 | data User = User 131 | { _user_name :: Text 132 | , _user_username :: Text 133 | , _user_avatar_url :: Text 134 | } 135 | deriving (Show, Read, Eq, Ord) 136 | 137 | deriveJSON defaultOptions 138 | { fieldLabelModifier = drop 6 139 | } ''User 140 | 141 | data ObjectAttributes = ObjectAttributes 142 | { _objectAttributes_id :: GitlabId 143 | , _objectAttributes_target_branch :: Text 144 | , _objectAttributes_source_branch :: Text 145 | , _objectAttributes_source_project_id :: GitlabId 146 | , _objectAttributes_author_id :: GitlabId 147 | , _objectAttributes_assignee_id :: Maybe GitlabId 148 | , _objectAttributes_title :: Text 149 | , _objectAttributes_created_at :: Text 150 | , _objectAttributes_updated_at :: Text 151 | , _objectAttributes_milestone_id :: Maybe GitlabId 152 | , _objectAttributes_state :: Text 153 | , _objectAttributes_merge_error :: Maybe Text 154 | , _objectAttributes_merge_status :: Text 155 | , _objectAttributes_target_project_id :: GitlabId 156 | , _objectAttributes_iid :: Int 157 | , _objectAttributes_description :: Text 158 | , _objectAttributes_source :: Project 159 | , _objectAttributes_target :: Project 160 | , _objectAttributes_last_commit :: CommitSummary 161 | , _objectAttributes_work_in_progress :: Bool 162 | , _objectAttributes_url :: Text 163 | , _objectAttributes_action :: Maybe Text 164 | } 165 | deriving (Show, Read, Eq, Ord) 166 | 167 | deriveJSON defaultOptions 168 | { fieldLabelModifier = drop 18 169 | } '' ObjectAttributes 170 | 171 | data Label = Label 172 | { _label_id :: GitlabId 173 | , _label_name :: Text 174 | , _label_color :: Text 175 | , _label_description :: Maybe Text 176 | , _label_open_issues_count :: Int 177 | , _label_closed_issues_count :: Int 178 | , _label_open_merge_requests_count :: Int 179 | , _label_subscribed :: Bool 180 | , _label_priority :: Maybe Bool 181 | } 182 | deriving (Show, Read, Eq, Ord) 183 | 184 | deriveJSON defaultOptions 185 | { fieldLabelModifier = drop 7 186 | } ''Label 187 | 188 | data MergeRequest = MergeRequest 189 | { _mergeRequest_object_kind :: Text 190 | , _mergeRequest_user :: User 191 | , _mergeRequest_project :: Project 192 | , _mergeRequest_repository :: Repository 193 | , _mergeRequest_object_attributes :: ObjectAttributes 194 | , _mergeRequest_labels :: [Label] 195 | } 196 | deriving (Show, Read, Eq, Ord) 197 | 198 | deriveJSON defaultOptions 199 | { fieldLabelModifier = drop 14 200 | } ''MergeRequest 201 | -------------------------------------------------------------------------------- /backend/src/Backend/NixBase32.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description: Implementation of Nix's base32 encoding. 3 | 4 | This code taken from https://github.com/haskell-nix/hnix-store 5 | -} 6 | module Backend.NixBase32 where 7 | 8 | import qualified Data.ByteString as BS 9 | import qualified Data.Text as T 10 | import qualified Data.Vector as V 11 | 12 | -- | Encode a 'BS.ByteString' in Nix's base32 encoding 13 | encode :: BS.ByteString -> T.Text 14 | encode c = T.pack $ map char32 [nChar - 1, nChar - 2 .. 0] 15 | where 16 | digits32 = V.fromList "0123456789abcdfghijklmnpqrsvwxyz" 17 | -- Each base32 character gives us 5 bits of information, while 18 | -- each byte gives is 8. Because 'div' rounds down, we need to add 19 | -- one extra character to the result, and because of that extra 1 20 | -- we need to subtract one from the number of bits in the 21 | -- bytestring to cover for the case where the number of bits is 22 | -- already a factor of 5. Thus, the + 1 outside of the 'div' and 23 | -- the - 1 inside of it. 24 | nChar = fromIntegral $ ((BS.length c * 8 - 1) `div` 5) + 1 25 | 26 | byte = BS.index c . fromIntegral 27 | 28 | -- May need to switch to a more efficient calculation at some 29 | -- point. 30 | bAsInteger :: Integer 31 | bAsInteger = sum [fromIntegral (byte j) * (256 ^ j) 32 | | j <- [0 .. BS.length c - 1] 33 | ] 34 | 35 | char32 :: Integer -> Char 36 | char32 i = digits32 V.! digitInd 37 | where 38 | digitInd = fromIntegral $ 39 | bAsInteger 40 | `div` (32^i) 41 | `mod` 32 42 | -------------------------------------------------------------------------------- /backend/src/Backend/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Backend.Process where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Control.Error 7 | import qualified Control.Exception as C 8 | import Control.Monad.Except 9 | import Data.ByteString (ByteString) 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import Data.Text.Encoding 13 | import Data.Text.Encoding.Error 14 | import Data.Time 15 | import System.Exit 16 | import System.IO 17 | import System.Process 18 | import qualified Turtle as Turtle 19 | import qualified Turtle.Bytes as TurtleB 20 | ------------------------------------------------------------------------------ 21 | import Common.Types.JobStatus 22 | import Common.Types.ProcMsg 23 | ------------------------------------------------------------------------------ 24 | 25 | 26 | exitCodeToStatus :: ExitCode -> JobStatus 27 | exitCodeToStatus ExitSuccess = JobSucceeded 28 | exitCodeToStatus (ExitFailure _) = JobFailed 29 | 30 | withLogHandle :: FilePath -> (Handle -> IO a) -> IO a 31 | withLogHandle fp action = withFile fp AppendMode $ \h -> do 32 | hSetBuffering h NoBuffering 33 | action h 34 | 35 | withCreateProcess_ 36 | :: String 37 | -> CreateProcess 38 | -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) 39 | -> IO a 40 | withCreateProcess_ fun c action = 41 | C.bracket (createProcess_ fun c) cleanup 42 | (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) 43 | where 44 | cleanup (_, _, _, ph) = terminateProcess ph 45 | 46 | runCmd2 47 | :: String 48 | -> FilePath 49 | -> Maybe [(String, String)] 50 | -> (ProcMsg -> IO ()) 51 | -> ExceptT ExitCode IO () 52 | runCmd2 cmd dir envVars action = do 53 | let cp = (shell cmd) 54 | { cwd = Just dir 55 | , env = envVars 56 | } 57 | runCP cp action 58 | 59 | runProc 60 | :: String 61 | -> [String] 62 | -> FilePath 63 | -> Maybe [(String, String)] 64 | -> (ProcMsg -> IO ()) 65 | -> ExceptT ExitCode IO () 66 | runProc cmd args dir envVars action = do 67 | let cp = (proc cmd args) 68 | { cwd = Just dir 69 | , env = envVars 70 | } 71 | runCP cp action 72 | 73 | runCP 74 | :: CreateProcess 75 | -> (ProcMsg -> IO ()) 76 | -> ExceptT ExitCode IO () 77 | runCP cp action = do 78 | t <- liftIO getCurrentTime 79 | liftIO $ action $ ProcMsg t BuildCommandMsg (cmdSpecToText $ cmdspec cp) 80 | res <- liftIO $ C.try 81 | (Turtle.foldShell (TurtleB.streamWithErr cp (return mempty)) (shellHandler action)) 82 | case res of 83 | Left e -> ExceptT $ return $ Left e 84 | Right _ -> return () 85 | 86 | runCPStr 87 | :: CreateProcess 88 | -> (ProcMsg -> IO ()) 89 | -> ExceptT String IO () 90 | runCPStr cp action = do 91 | res <- lift $ runExceptT $ runCP cp action 92 | case res of 93 | Left ec -> throwError $ "runCPStr failed with exit code " <> show ec 94 | Right _ -> return () 95 | 96 | cmdSpecToText :: CmdSpec -> Text 97 | cmdSpecToText (ShellCommand s) = T.pack s 98 | cmdSpecToText (RawCommand cmd args) = T.unwords $ T.pack cmd : map doArg args 99 | where 100 | doArg s = "\"" <> T.pack s <> "\"" 101 | 102 | shellHandler 103 | :: (ProcMsg -> IO ()) 104 | -> Turtle.FoldShell (Either ByteString ByteString) () 105 | shellHandler action = Turtle.FoldShell step () return 106 | where 107 | decoder = decodeUtf8With lenientDecode 108 | step _ a = do 109 | t <- getCurrentTime 110 | let pm = case a of 111 | Left m -> ProcMsg t StderrMsg $ decoder m 112 | Right m -> ProcMsg t StdoutMsg $ decoder m 113 | action pm 114 | -------------------------------------------------------------------------------- /backend/src/Backend/Schedule.hs: -------------------------------------------------------------------------------- 1 | module Backend.Schedule where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Time 5 | import Database.Beam 6 | import Database.Beam.Sqlite 7 | ------------------------------------------------------------------------------ 8 | import Backend.Db 9 | import Backend.Types.ServerEnv 10 | import Common.Types.BuildJob 11 | import Common.Types.JobStatus 12 | import Common.Types.RepoBuildInfo 13 | ------------------------------------------------------------------------------ 14 | 15 | scheduleBuild :: ServerEnv -> RepoBuildInfo -> IO () 16 | scheduleBuild env rbi = do 17 | t <- getCurrentTime 18 | _ <- runBeamSqlite (_serverEnv_db env) $ do 19 | runInsertReturningList $ insert (_ciDb_buildJobs ciDb) $ insertExpressions 20 | [ BuildJob default_ (val_ rbi) (val_ t) (val_ Nothing) (val_ Nothing) (val_ JobPending) ] 21 | return () 22 | -------------------------------------------------------------------------------- /backend/src/Backend/Types/BackendSettings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Backend.Types.BackendSettings where 5 | 6 | ------------------------------------------------------------------------------ 7 | import Control.Error 8 | import Data.Aeson 9 | import Data.Bits 10 | import Data.List 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Data.Word 14 | import Database.Beam 15 | import Network.Socket 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | import Text.Printf 19 | ------------------------------------------------------------------------------ 20 | 21 | aesonOpts :: Int -> Options 22 | aesonOpts n = defaultOptions 23 | { fieldLabelModifier = drop n 24 | } 25 | 26 | data Cidr = Cidr 27 | { _cidrIp :: Word32 28 | , _cidrMask :: Int 29 | } deriving (Eq,Ord,Show,Read,Generic) 30 | 31 | parseOctet :: Text -> Maybe Word8 32 | parseOctet t = do 33 | val :: Int <- readMay $ T.unpack t 34 | if val < 256 then pure (fromIntegral val) else Nothing 35 | 36 | parseIp :: Text -> Either String Word32 37 | parseIp t = 38 | case T.splitOn "." t of 39 | [a,b,c,d] -> fmap tupleToHostAddress $ (,,,) 40 | <$> note "Error: 'a' component of IP must be an int" (parseOctet a) 41 | <*> note "Error: 'b' component of IP must be an int" (parseOctet b) 42 | <*> note "Error: 'c' component of IP must be an int" (parseOctet c) 43 | <*> note "Error: 'd' component of IP must be an int" (parseOctet d) 44 | _ -> Left "IP must have the form a.b.c.d" 45 | 46 | parseCidr :: Text -> Either String Cidr 47 | parseCidr t = 48 | case T.breakOn "/" t of 49 | (ip,"") -> Cidr <$> parseIp ip <*> pure 32 50 | (ip,mask) -> Cidr <$> parseIp ip 51 | <*> note "CIDR mask must be an int" (readMay $ T.unpack $ T.drop 1 mask) 52 | 53 | showIp :: Word32 -> String 54 | showIp ip = intercalate "." [show a, show b, show c, show d] 55 | where 56 | (a,b,c,d) = hostAddressToTuple ip 57 | 58 | showCidr :: Cidr -> String 59 | showCidr (Cidr i m) = showIp i <> "/" <> show m 60 | 61 | numOnesToMask :: Int -> Word32 62 | numOnesToMask n = shift (2 ^ n - 1) (32 - n) 63 | 64 | matchesCidr :: Word32 -> Cidr -> Bool 65 | matchesCidr ip cidr = (ip .&. mask) == (_cidrIp cidr .&. mask) 66 | where 67 | mask = numOnesToMask (_cidrMask cidr) 68 | 69 | ipMatchTest :: TestTree 70 | ipMatchTest = 71 | testGroup "matchesCidr" $ 72 | f "184.72.104.138" 32 ++ 73 | f "184.72.104.138" 24 ++ 74 | f "184.72.104.138" 16 ++ 75 | f "184.72.104.138" 8 76 | where 77 | f ipStr mask = 78 | let ip = either error id $ parseIp ipStr 79 | in testCase "mask matches itself" (matchesCidr ip (Cidr ip mask) @?= True) : 80 | map (twiddleCheck ip mask) [0..31] 81 | twiddleCheck ip mask n = 82 | testCase (printf "twiddle %d is correct" n) $ 83 | matchesCidr (complementBit ip n) (Cidr ip mask) @?= twiddleMatches mask n 84 | twiddleMatches mask i = i < (32 - mask) 85 | 86 | instance ToJSON Cidr where 87 | toJSON = String . T.pack . showCidr 88 | toEncoding = toEncoding . showCidr 89 | 90 | instance FromJSON Cidr where 91 | parseJSON = withText "Cidr" (either (fail "Invalid Cidr format") pure . parseCidr) 92 | 93 | ------------------------------------------------------------------------------ 94 | -- | These are settings that should not be exposed to the frontend. 95 | data BackendSettings = BackendSettings 96 | { _beSettings_webhookBaseUrl :: Maybe Text 97 | , _beSettings_ipWhitelist :: [Cidr] 98 | , _beSettings_setStatus :: Maybe Bool 99 | -- ^ Whether to set CI status lights (defaults to True) 100 | } deriving (Eq,Ord,Show,Read,Generic) 101 | 102 | instance ToJSON BackendSettings where 103 | toEncoding = genericToEncoding (aesonOpts 12) 104 | 105 | instance FromJSON BackendSettings where 106 | parseJSON = genericParseJSON (aesonOpts 12) 107 | -------------------------------------------------------------------------------- /backend/src/Backend/Types/ConnRepo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Backend.Types.ConnRepo 4 | ( ConnId 5 | , ConnRepo 6 | , newConnRepo 7 | , addConnection 8 | , removeConnection 9 | , broadcast 10 | , sendToConnId 11 | ) where 12 | 13 | ------------------------------------------------------------------------------ 14 | import Control.Monad 15 | import Data.IORef 16 | import Data.Map (Map) 17 | import qualified Data.Map as M 18 | import qualified Network.WebSockets as WS 19 | import Text.Printf 20 | ------------------------------------------------------------------------------ 21 | import Common.Api 22 | import Backend.WsUtils 23 | ------------------------------------------------------------------------------ 24 | 25 | newtype ConnId = ConnId Int 26 | deriving (Eq,Ord,Show,Read,Enum) 27 | 28 | newtype ConnRepo = ConnRepo 29 | { _connRepoIORef :: IORef (ConnId, Map ConnId WS.Connection) 30 | } 31 | 32 | newConnRepo :: IO ConnRepo 33 | newConnRepo = do 34 | ref <- newIORef (ConnId 0, mempty) 35 | return $ ConnRepo ref 36 | 37 | addConnection :: WS.Connection -> ConnRepo -> IO (ConnId) 38 | addConnection conn (ConnRepo ref) = atomicModifyIORef ref f 39 | where 40 | f (next, m) = ((succ next, M.insert next conn m), next) 41 | 42 | removeConnection :: ConnId -> ConnRepo -> IO () 43 | removeConnection cid (ConnRepo ref) = atomicModifyIORef ref f 44 | where 45 | f (next, m) = ((next, M.delete cid m), ()) 46 | 47 | broadcast :: ConnRepo -> Down -> IO () 48 | broadcast (ConnRepo cRef) cmd = do 49 | (_,conns) <- readIORef cRef 50 | forM_ (M.elems conns) $ \(conn) -> do 51 | wsSend conn cmd 52 | 53 | sendToConnId :: ConnRepo -> ConnId -> Down -> IO () 54 | sendToConnId (ConnRepo cRef) cid@(ConnId cidInt) cmd = do 55 | (_,conns) <- readIORef cRef 56 | case M.lookup cid conns of 57 | Nothing -> printf "WARN: Trying to send to non-existent connection %d\n" cidInt 58 | Just conn -> wsSend conn cmd 59 | -------------------------------------------------------------------------------- /backend/src/Backend/Types/NixCacheKeyPair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Backend.Types.NixCacheKeyPair 4 | ( NixCacheKey 5 | , _nck_name 6 | , _nck_key 7 | , readKeyFile 8 | , mkNixSig 9 | , NixCacheKeyPair(..) 10 | , signingKeyBaseName 11 | , signingKeySecretFile 12 | , signingKeyPublicFile 13 | ) where 14 | 15 | ------------------------------------------------------------------------------ 16 | import Crypto.Sign.Ed25519 17 | import Data.ByteString (ByteString) 18 | import qualified Data.ByteString.Base64 as Base64 19 | import Data.Text (Text) 20 | import qualified Data.Text.Encoding as T 21 | ------------------------------------------------------------------------------ 22 | import Common.Types.NixCacheKeyPair 23 | ------------------------------------------------------------------------------ 24 | 25 | mkNixSig :: NixCacheKey -> ByteString -> Text 26 | mkNixSig secret msg = _nck_name secret <> ":" <> sig 27 | where 28 | sig = T.decodeUtf8 $ Base64.encode $ unSignature $ 29 | dsign (SecretKey $ _nck_key secret) msg 30 | 31 | signingKeyBaseName :: String 32 | signingKeyBaseName = "zeus-cache-key" 33 | 34 | -- Would like to put these files in config/backend and config/common 35 | -- respectively but when deployed with obelisk the backend does not have 36 | -- permission to write to those directories. 37 | signingKeySecretFile :: String 38 | --signingKeySecretFile = "config/backend/" <> signingKeyBaseName <> ".sec" 39 | signingKeySecretFile = signingKeyBaseName <> ".sec" 40 | signingKeyPublicFile :: String 41 | --signingKeyPublicFile = "config/common/" <> signingKeyBaseName <> ".pub" 42 | signingKeyPublicFile = signingKeyBaseName <> ".pub" 43 | -------------------------------------------------------------------------------- /backend/src/Backend/Types/ServerEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Backend.Types.ServerEnv where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Control.Concurrent 7 | import Data.IORef 8 | import Data.Int 9 | import Data.Map (Map) 10 | import Data.Set (Set) 11 | import Data.Text (Text) 12 | import Database.Beam.Sqlite 13 | import Database.SQLite.Simple 14 | import System.Mem.Weak 15 | ------------------------------------------------------------------------------ 16 | import Backend.Types.BackendSettings 17 | import Backend.Types.ConnRepo 18 | import Backend.Types.NixCacheKeyPair 19 | ------------------------------------------------------------------------------ 20 | 21 | data ServerEnv = ServerEnv 22 | { _serverEnv_publicUrl :: Text 23 | -- ^ The public URL at which this CI server can be reached 24 | , _serverEnv_settings :: BackendSettings 25 | -- ^ Sometimes this needs to be different from publicUrl, for instance when 26 | -- doing local development behind NAT and you want to test the webhooks via 27 | -- reverse port forwarding or similar. This field defaults to be the same 28 | -- as publicUrl unless an override is found in a particular file in the cwd. 29 | -- See Backend.hs for more information. 30 | , _serverEnv_secretToken :: Text 31 | -- ^ The secret token this server requires to determine legitimacy of 32 | -- incoming requests 33 | , _serverEnv_db :: Connection 34 | , _serverEnv_connRepo :: ConnRepo 35 | -- ^ Websocket connection repo that allows job updates to be pushed 36 | , _serverEnv_buildThreads :: IORef (Map Int32 (Weak ThreadId)) 37 | , _serverEnv_buildListeners :: IORef (Map Int32 (Set ConnId)) 38 | , _serverEnv_cacheKey :: NixCacheKeyPair 39 | } 40 | 41 | beamQuery :: ServerEnv -> SqliteM a -> IO a 42 | beamQuery env = beamQueryConn (_serverEnv_db env) 43 | 44 | beamQueryConn :: Connection -> SqliteM a -> IO a 45 | beamQueryConn conn f = runBeamSqlite conn f 46 | -------------------------------------------------------------------------------- /backend/src/Backend/WsCmds.hs: -------------------------------------------------------------------------------- 1 | module Backend.WsCmds where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Database.Beam 5 | import Database.SQLite.Simple 6 | ------------------------------------------------------------------------------ 7 | import Backend.Db 8 | import Backend.Types.ConnRepo 9 | import Backend.Types.ServerEnv 10 | import Common.Api 11 | import Common.Types.BuildJob 12 | ------------------------------------------------------------------------------ 13 | 14 | getJobsFromDb :: Connection -> Integer -> Integer -> IO [BuildJob] 15 | getJobsFromDb conn lim off = do 16 | beamQueryConn conn $ 17 | runSelectReturningList $ select $ limit_ lim $ offset_ off $ do 18 | orderBy_ (desc_ . _buildJob_id) $ 19 | all_ (_ciDb_buildJobs ciDb) 20 | 21 | broadcastJobs :: Connection -> ConnRepo -> IO () 22 | broadcastJobs conn connRepo = do 23 | jobs <- getJobsFromDb conn 20 0 24 | broadcast connRepo $ Down_Jobs jobs 25 | -------------------------------------------------------------------------------- /backend/src/Backend/WsUtils.hs: -------------------------------------------------------------------------------- 1 | module Backend.WsUtils where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Aeson 5 | import qualified Data.ByteString.Lazy as BSL 6 | import qualified Network.WebSockets as WS 7 | import qualified Network.WebSockets.Snap as WS 8 | import Snap.Core 9 | ------------------------------------------------------------------------------ 10 | 11 | wsHandler :: MonadSnap m => (WS.Connection -> IO ()) -> m () 12 | wsHandler m = do 13 | WS.runWebSocketsSnap $ \pc -> do 14 | conn <- WS.acceptRequest pc 15 | WS.forkPingThread conn 10 16 | m conn 17 | 18 | wsReceive :: FromJSON a => WS.Connection -> IO (Either String a) 19 | wsReceive conn = do 20 | dm <- WS.receiveDataMessage conn 21 | return $ eitherDecode' $ dataToBs dm 22 | 23 | wsSend :: ToJSON a => WS.Connection -> a -> IO () 24 | wsSend conn v = WS.sendTextData conn $ encode v 25 | 26 | dataToBs :: WS.DataMessage -> BSL.ByteString 27 | dataToBs (WS.Text bs _) = bs 28 | dataToBs (WS.Binary bs) = bs 29 | -------------------------------------------------------------------------------- /backend/src/Nix/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Nix.Types where 3 | 4 | ------------------------------------------------------------------------------ 5 | import Control.Monad 6 | import Data.Readable 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import Data.Word 10 | import Database.SQLite.Simple 11 | ------------------------------------------------------------------------------ 12 | import Backend.Types.ServerEnv 13 | ------------------------------------------------------------------------------ 14 | 15 | nixSqliteDb :: String 16 | nixSqliteDb = "/nix/var/nix/db/db.sqlite" 17 | 18 | data ValidPath = ValidPath 19 | { _validPath_id :: Int 20 | , _validPath_path :: Text 21 | , _validPath_hash :: Text 22 | , _validPath_registrationTime :: Int 23 | , _validPath_deriver :: Maybe Text 24 | , _validPath_narSize :: Maybe Int 25 | , _validPath_ultimate :: Maybe Int 26 | , _validPath_sigs :: Maybe [Text] 27 | , _validPath_ca :: Maybe Text 28 | } deriving (Eq,Ord,Show,Read) 29 | 30 | instance FromRow ValidPath where 31 | fromRow = ValidPath <$> field <*> field <*> field 32 | <*> field <*> field <*> field 33 | <*> field <*> (fmap T.words <$> field) <*> field 34 | 35 | newtype StorePath = StorePath { unStorePath :: FilePath } 36 | deriving (Eq,Ord,Show,Read) 37 | 38 | data CacheEnv = CacheEnv 39 | { _cacheEnv_nixSqliteConn :: Connection 40 | , _cacheEnv_se :: ServerEnv 41 | } 42 | 43 | data NarCompression = NoCompression | Xz | Bzip2 44 | deriving (Eq,Ord,Enum,Bounded) 45 | 46 | instance Show NarCompression where 47 | show NoCompression = "none" 48 | show Xz = "xz" 49 | show Bzip2 = "bzip2" 50 | 51 | instance Readable NarCompression where 52 | fromText "none" = pure NoCompression 53 | fromText "xz" = pure Xz 54 | fromText "bzip2" = pure Bzip2 55 | fromText _ = mzero 56 | 57 | data NarInfo = NarInfo 58 | { _narInfo_storePath :: StorePath 59 | , _narInfo_urlHash :: Text 60 | , _narInfo_compression :: NarCompression 61 | , _narInfo_narHash :: Text 62 | , _narInfo_narSize :: Word64 63 | , _narInfo_references :: [Text] 64 | , _narInfo_deriver :: Maybe Text 65 | , _narInfo_sigs :: [Text] 66 | } deriving (Eq,Ord) 67 | -------------------------------------------------------------------------------- /backend/static: -------------------------------------------------------------------------------- 1 | ../static -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | optional-packages: 2 | * 3 | -------------------------------------------------------------------------------- /common/common.cabal: -------------------------------------------------------------------------------- 1 | name: common 2 | version: 0.1 3 | cabal-version: >= 1.2 4 | build-type: Simple 5 | 6 | library 7 | hs-source-dirs: src 8 | build-depends: 9 | aeson 10 | , base 11 | , base64-bytestring 12 | , beam-core 13 | , beam-migrate 14 | , bytestring 15 | , data-default 16 | , dependent-sum 17 | , directory 18 | , errors 19 | , lens 20 | , mtl 21 | , obelisk-executable-config-lookup 22 | , obelisk-route 23 | , readable 24 | , reflex-dom 25 | , scrub 26 | , string-conv 27 | , text 28 | , time 29 | default-extensions: 30 | TypeFamilies 31 | PolyKinds 32 | exposed-modules: 33 | Common.Api 34 | Common.Route 35 | Common.Types.BinaryCache 36 | Common.Types.CacheJob 37 | Common.Types.CachedHash 38 | Common.Types.CiSettings 39 | Common.Types.ConnectedAccount 40 | Common.Types.BuildJob 41 | Common.Types.Builder 42 | Common.Types.GitHash 43 | Common.Types.JobStatus 44 | Common.Types.NixCacheKeyPair 45 | Common.Types.ProcMsg 46 | Common.Types.Repo 47 | Common.Types.RepoBuildInfo 48 | Common.Types.S3Cache 49 | Humanizable 50 | -------------------------------------------------------------------------------- /common/src/Common/Api.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE DeriveGeneric#-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Common.Api where 6 | 7 | ------------------------------------------------------------------------------ 8 | import Control.Lens 9 | import Data.Aeson 10 | import Data.Text (Text) 11 | import Database.Beam 12 | import Scrub 13 | ------------------------------------------------------------------------------ 14 | import Common.Types.BinaryCache 15 | import Common.Types.BuildJob 16 | import Common.Types.CiSettings 17 | import Common.Types.ConnectedAccount 18 | import Common.Types.ProcMsg 19 | import Common.Types.Repo 20 | ------------------------------------------------------------------------------ 21 | 22 | type Batch a = [a] 23 | 24 | batchOne :: a -> Batch a 25 | batchOne a = [a] 26 | 27 | instance ToJSON a => ToJSON (Scrubbed a) where 28 | toJSON = toJSON . getScrubbed 29 | 30 | instance FromJSON a => FromJSON (Scrubbed a) where 31 | parseJSON = fmap Scrubbed . parseJSON 32 | 33 | --batchMaybe :: FunctorMaybe f => (a -> Batch b) -> f a -> f b 34 | --batchMaybe f = fmapMaybe (listToMaybe . f) 35 | 36 | -- WIP 37 | -- data CrudAction itemT 38 | -- = CrudCreate (Batch (itemT Maybe)) 39 | -- | CrudRead (Batch (PrimaryKey itemT)) 40 | -- -- | CrudUpdate 41 | -- | 42 | -- | CrudDelete (Batch (PrimaryKey itemT)) 43 | -- | CrudList 44 | 45 | data Up 46 | = Up_ListAccounts 47 | | Up_ConnectAccount (Batch (ConnectedAccountT Maybe)) 48 | | Up_DelAccounts (Batch ConnectedAccountId) 49 | | Up_ListRepos 50 | | Up_AddRepo (Batch (RepoT Maybe)) 51 | | Up_DelRepos (Batch RepoId) 52 | | Up_GetJobs 53 | | Up_SubscribeJobOutput (Batch BuildJobId) 54 | | Up_UnsubscribeJobOutput (Batch BuildJobId) 55 | | Up_CancelJobs (Batch BuildJobId) 56 | | Up_RerunJobs (Batch BuildJobId) 57 | | Up_GetCiSettings 58 | | Up_UpdateCiSettings CiSettings 59 | | Up_GetCiInfo 60 | 61 | | Up_ListCaches 62 | | Up_AddCache (Batch (BinaryCacheT Maybe)) 63 | | Up_DelCaches (Batch BinaryCacheId) 64 | deriving (Show,Generic) 65 | 66 | data Down 67 | = Down_Alert Text 68 | | Down_ConnectedAccounts [ConnectedAccount] 69 | | Down_Repos [Repo] 70 | | Down_Jobs [BuildJob] 71 | | Down_JobOutput (BuildJobId, Text) 72 | | Down_JobNewOutput (BuildJobId, [ProcMsg]) 73 | | Down_CiSettings (Scrubbed CiSettings) 74 | | Down_CiInfo Text 75 | | Down_Caches [BinaryCache] 76 | deriving (Generic) 77 | 78 | instance ToJSON Up where 79 | toEncoding = genericToEncoding defaultOptions 80 | 81 | instance FromJSON Up 82 | 83 | instance ToJSON Down where 84 | toEncoding = genericToEncoding defaultOptions 85 | 86 | instance FromJSON Down 87 | 88 | makePrisms ''Up 89 | makePrisms ''Down 90 | -------------------------------------------------------------------------------- /common/src/Common/Route.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | 12 | module Common.Route where 13 | 14 | {- -- You will probably want these imports for composing Encoders. 15 | import Prelude hiding (id, (.)) 16 | import Control.Category 17 | -} 18 | 19 | ------------------------------------------------------------------------------ 20 | import Prelude hiding (id, (.)) 21 | import Control.Category 22 | import Control.Lens 23 | import Data.Int 24 | import Data.Some (Some) 25 | import qualified Data.Some as Some 26 | import Data.Text (Text) 27 | import qualified Data.Text as T 28 | import Data.Text.Encoding 29 | import Data.Functor.Sum 30 | import Obelisk.Configs 31 | import Obelisk.Route 32 | import Obelisk.Route.TH 33 | import Reflex.Dom 34 | ------------------------------------------------------------------------------ 35 | 36 | -- This needs to match the BackendRoute_GithubHook line below. Will figure out 37 | -- how to make it DRY later. 38 | githubHookPath :: Text 39 | githubHookPath = "hook/github" 40 | 41 | gitlabHookPath :: Text 42 | gitlabHookPath = "hook/gitlab" 43 | 44 | data HookRoute :: * -> * where 45 | Hook_GitHub :: HookRoute () 46 | Hook_GitLab :: HookRoute () 47 | 48 | deriveRouteComponent ''HookRoute 49 | 50 | data CrudRoute :: * -> * where 51 | Crud_List :: CrudRoute () 52 | Crud_Create :: CrudRoute () 53 | --Crud_Update :: CrudRoute Int 54 | --Crud_Delete :: CrudRoute Int 55 | 56 | deriveRouteComponent ''CrudRoute 57 | 58 | data JobRoute :: * -> * where 59 | Job_List :: JobRoute () 60 | Job_Output :: JobRoute Int32 61 | 62 | deriveRouteComponent ''JobRoute 63 | 64 | data BackendRoute :: * -> * where 65 | -- | Used to handle unparseable routes. 66 | BackendRoute_Cache :: BackendRoute [Text] 67 | BackendRoute_Missing :: BackendRoute () 68 | BackendRoute_Hook :: BackendRoute (R HookRoute) 69 | BackendRoute_Ping :: BackendRoute () 70 | BackendRoute_RawBuildOut :: BackendRoute Text 71 | BackendRoute_Websocket :: BackendRoute () 72 | 73 | data FrontendRoute :: * -> * where 74 | FR_Home :: FrontendRoute () 75 | FR_Jobs :: FrontendRoute (R JobRoute) 76 | FR_Repos :: FrontendRoute (R CrudRoute) 77 | FR_Accounts :: FrontendRoute (R CrudRoute) 78 | FR_Caches :: FrontendRoute (R CrudRoute) 79 | FR_Settings :: FrontendRoute () 80 | 81 | hookRouteEncoder 82 | :: Encoder (Either Text) (Either Text) (R HookRoute) PageName 83 | hookRouteEncoder = pathComponentEncoder $ \case 84 | Hook_GitHub -> PathSegment "github" $ unitEncoder mempty 85 | Hook_GitLab -> PathSegment "gitlab" $ unitEncoder mempty 86 | 87 | crudRouteEncoder 88 | :: Encoder (Either Text) (Either Text) (R CrudRoute) PageName 89 | crudRouteEncoder = pathComponentEncoder $ \case 90 | Crud_List -> PathEnd $ unitEncoder mempty 91 | Crud_Create -> PathSegment "new" $ unitEncoder mempty 92 | 93 | jobRouteEncoder 94 | :: Encoder (Either Text) (Either Text) (R JobRoute) PageName 95 | jobRouteEncoder = pathComponentEncoder $ \case 96 | Job_List -> PathEnd $ unitEncoder mempty 97 | Job_Output -> PathSegment "output" (singlePathSegmentEncoder . unsafeTshowEncoder) 98 | 99 | landingPageRoute :: R FrontendRoute 100 | landingPageRoute = FR_Home :/ () 101 | 102 | backendRouteEncoder 103 | :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName 104 | backendRouteEncoder = handleEncoder (\_ -> hoistR (FullRoute_Frontend . ObeliskRoute_App) landingPageRoute) $ 105 | pathComponentEncoder $ \case 106 | FullRoute_Backend backendRoute -> case backendRoute of 107 | BackendRoute_Cache -> PathSegment "cache" pathOnlyEncoder 108 | BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty 109 | BackendRoute_Hook -> PathSegment "hook" hookRouteEncoder 110 | BackendRoute_Ping -> PathSegment "ping" $ unitEncoder mempty 111 | BackendRoute_RawBuildOut -> PathSegment "raw" singlePathSegmentEncoder 112 | BackendRoute_Websocket -> PathSegment "ws" $ unitEncoder mempty 113 | FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case 114 | -- The encoder given to PathEnd determines how to parse query parameters, 115 | -- in this example, we have none, so we insist on it. 116 | FR_Home -> PathEnd $ unitEncoder mempty 117 | FR_Jobs -> PathSegment "jobs" jobRouteEncoder 118 | FR_Repos -> PathSegment "repos" crudRouteEncoder 119 | FR_Accounts -> PathSegment "accounts" crudRouteEncoder 120 | FR_Caches -> PathSegment "caches" crudRouteEncoder 121 | FR_Settings -> PathSegment "settings" $ unitEncoder mempty 122 | 123 | concat <$> mapM deriveRouteComponent 124 | [ ''BackendRoute 125 | , ''FrontendRoute 126 | ] 127 | 128 | getAppRoute :: HasConfigs m => m Text 129 | getAppRoute = do 130 | mroute <- getConfig "common/route" 131 | case mroute of 132 | Nothing -> fail "Error getAppRoute: config/common/route not defined" 133 | Just r -> return $ T.dropWhileEnd (== '/') $ T.strip $ decodeUtf8 r 134 | 135 | -- | Provide a human-readable name for a given section 136 | tabTitle :: DomBuilder t m => Some FrontendRoute -> m () 137 | tabTitle sfr@(Some.Some sec) = case sec of 138 | FR_Home -> text $ frToText sfr 139 | FR_Jobs -> text $ frToText sfr 140 | FR_Repos -> text $ frToText sfr 141 | FR_Accounts -> text $ frToText sfr 142 | FR_Caches -> text $ frToText sfr 143 | FR_Settings -> text $ frToText sfr 144 | 145 | -- | Provide a human-readable name for a given section 146 | frToText :: Some FrontendRoute -> Text 147 | frToText (Some.Some sec) = case sec of 148 | FR_Home -> "Home" 149 | FR_Jobs -> "Jobs" 150 | FR_Repos -> "Repos" 151 | FR_Accounts -> "Accounts" 152 | FR_Caches -> "Caches" 153 | FR_Settings -> "Settings" 154 | 155 | 156 | tabHomepage :: Some FrontendRoute -> R FrontendRoute 157 | tabHomepage (Some.Some sec) = sec :/ case sec of 158 | FR_Home -> () 159 | FR_Jobs -> Job_List :/ () 160 | FR_Repos -> Crud_List :/ () 161 | FR_Accounts -> Crud_List :/ () 162 | FR_Caches -> Crud_List :/ () 163 | FR_Settings -> () 164 | -------------------------------------------------------------------------------- /common/src/Common/Types/BinaryCache.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Common.Types.BinaryCache where 18 | 19 | ------------------------------------------------------------------------------ 20 | import Data.Aeson 21 | import Data.Int 22 | --import Data.Text (Text) 23 | import Database.Beam 24 | ------------------------------------------------------------------------------ 25 | import Common.Types.S3Cache 26 | ------------------------------------------------------------------------------ 27 | 28 | 29 | ------------------------------------------------------------------------------ 30 | data BinaryCacheT f = BinaryCache 31 | { _binaryCache_id :: C f Int32 32 | -- , _binaryCache_url :: C f Text 33 | -- , _binaryCache_storeDir :: C f Text 34 | , _binaryCache_s3Cache :: C f S3Cache 35 | } deriving Generic 36 | 37 | BinaryCache 38 | (LensFor binaryCache_id) 39 | -- (LensFor binaryCache_url) 40 | -- (LensFor binaryCache_storeDir) 41 | (LensFor binaryCache_s3Cache) 42 | = tableLenses 43 | 44 | bcToMaybe :: BinaryCacheT Identity -> BinaryCacheT Maybe 45 | bcToMaybe (BinaryCache i c) = BinaryCache (Just i) (Just c) 46 | 47 | type BinaryCache = BinaryCacheT Identity 48 | type BinaryCacheId = PrimaryKey BinaryCacheT Identity 49 | 50 | deriving instance Eq (PrimaryKey BinaryCacheT (Nullable Identity)) 51 | deriving instance Eq (PrimaryKey BinaryCacheT (Nullable Maybe)) 52 | deriving instance Eq (PrimaryKey BinaryCacheT Identity) 53 | deriving instance Eq (PrimaryKey BinaryCacheT Maybe) 54 | deriving instance Eq BinaryCache 55 | deriving instance Show (PrimaryKey BinaryCacheT (Nullable Identity)) 56 | deriving instance Show (PrimaryKey BinaryCacheT (Nullable Maybe)) 57 | deriving instance Show (PrimaryKey BinaryCacheT Identity) 58 | deriving instance Show (PrimaryKey BinaryCacheT Maybe) 59 | deriving instance Show BinaryCache 60 | deriving instance Show (BinaryCacheT Maybe) 61 | deriving instance Ord (PrimaryKey BinaryCacheT (Nullable Identity)) 62 | deriving instance Ord (PrimaryKey BinaryCacheT (Nullable Maybe)) 63 | deriving instance Ord (PrimaryKey BinaryCacheT Identity) 64 | deriving instance Ord (PrimaryKey BinaryCacheT Maybe) 65 | deriving instance Ord BinaryCache 66 | 67 | 68 | instance ToJSON (PrimaryKey BinaryCacheT (Nullable Identity)) where 69 | toEncoding = genericToEncoding defaultOptions 70 | 71 | instance FromJSON (PrimaryKey BinaryCacheT (Nullable Identity)) 72 | 73 | instance ToJSON (PrimaryKey BinaryCacheT Identity) where 74 | toEncoding = genericToEncoding defaultOptions 75 | 76 | instance FromJSON (PrimaryKey BinaryCacheT Identity) 77 | 78 | instance ToJSON (PrimaryKey BinaryCacheT (Nullable Maybe)) where 79 | toEncoding = genericToEncoding defaultOptions 80 | 81 | instance FromJSON (PrimaryKey BinaryCacheT (Nullable Maybe)) 82 | 83 | instance ToJSON (PrimaryKey BinaryCacheT Maybe) where 84 | toEncoding = genericToEncoding defaultOptions 85 | 86 | instance FromJSON (PrimaryKey BinaryCacheT Maybe) 87 | 88 | instance ToJSON (BinaryCacheT Identity) where 89 | toEncoding = genericToEncoding defaultOptions 90 | 91 | instance FromJSON (BinaryCacheT Identity) 92 | 93 | instance ToJSON (BinaryCacheT Maybe) where 94 | toEncoding = genericToEncoding defaultOptions 95 | 96 | instance FromJSON (BinaryCacheT Maybe) 97 | 98 | instance Beamable BinaryCacheT 99 | 100 | instance Table BinaryCacheT where 101 | data PrimaryKey BinaryCacheT f = BinaryCacheId (Columnar f Int32) 102 | deriving (Generic, Beamable) 103 | primaryKey = BinaryCacheId . _binaryCache_id 104 | 105 | binaryCacheKeyToInt :: PrimaryKey BinaryCacheT Identity -> Int32 106 | binaryCacheKeyToInt (BinaryCacheId k) = k 107 | -------------------------------------------------------------------------------- /common/src/Common/Types/BuildJob.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE ImpredicativeTypes #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Common.Types.BuildJob where 19 | 20 | ------------------------------------------------------------------------------ 21 | import Control.Lens 22 | import Data.Aeson 23 | import Data.Int 24 | import Data.Time 25 | import Database.Beam 26 | import Database.Beam.Backend.SQL 27 | import Database.Beam.Migrate.Generics 28 | import Database.Beam.Migrate.SQL 29 | ------------------------------------------------------------------------------ 30 | import Common.Types.JobStatus 31 | import Common.Types.RepoBuildInfo 32 | ------------------------------------------------------------------------------ 33 | 34 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be UTCTime where 35 | defaultSqlDataType _ _ _ = timestampType Nothing True 36 | 37 | 38 | ------------------------------------------------------------------------------ 39 | data BuildJobT f = BuildJob 40 | { _buildJob_id :: C f Int32 41 | , _buildJob_repoBuildInfo :: RepoBuildInfoT f 42 | -- ^ Denormalizing this and putting it inline instead of using a foreign key 43 | -- to the repos table allows us to delete repos without violating foreign 44 | -- key constraints here. 45 | , _buildJob_receivedAt :: C f UTCTime 46 | , _buildJob_startedAt :: C f (Maybe UTCTime) 47 | , _buildJob_endedAt :: C f (Maybe UTCTime) 48 | , _buildJob_status :: C f JobStatus 49 | } deriving Generic 50 | 51 | makeLenses 'BuildJob 52 | 53 | type BuildJob = BuildJobT Identity 54 | type BuildJobId = PrimaryKey BuildJobT Identity 55 | 56 | deriving instance Eq (PrimaryKey BuildJobT Identity) 57 | deriving instance Eq BuildJob 58 | deriving instance Ord (PrimaryKey BuildJobT Identity) 59 | deriving instance Ord BuildJob 60 | deriving instance Show (PrimaryKey BuildJobT Identity) 61 | deriving instance Show BuildJob 62 | 63 | instance ToJSON (PrimaryKey BuildJobT Identity) where 64 | toEncoding = genericToEncoding defaultOptions 65 | instance FromJSON (PrimaryKey BuildJobT Identity) 66 | 67 | instance ToJSON (BuildJobT Identity) where 68 | toEncoding = genericToEncoding defaultOptions 69 | instance FromJSON (BuildJobT Identity) 70 | 71 | bjKeyToInt :: PrimaryKey BuildJobT Identity -> Int32 72 | bjKeyToInt (BuildJobId k) = k 73 | 74 | bjKeyIdToMaybe :: PrimaryKey BuildJobT Identity -> PrimaryKey BuildJobT Maybe 75 | bjKeyIdToMaybe (BuildJobId k) = BuildJobId (Just k) 76 | 77 | bjKeyMaybeToId :: PrimaryKey BuildJobT Maybe -> Maybe (PrimaryKey BuildJobT Identity) 78 | bjKeyMaybeToId (BuildJobId (Just k)) = Just (BuildJobId k) 79 | bjKeyMaybeToId (BuildJobId Nothing) = Nothing 80 | 81 | instance Beamable BuildJobT 82 | 83 | instance Table BuildJobT where 84 | data PrimaryKey BuildJobT f = BuildJobId (Columnar f Int32) 85 | deriving (Generic, Beamable) 86 | primaryKey = BuildJobId . _buildJob_id 87 | -------------------------------------------------------------------------------- /common/src/Common/Types/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE ImpredicativeTypes #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeSynonymInstances #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | module Common.Types.Builder where 17 | 18 | ------------------------------------------------------------------------------ 19 | import Control.Monad 20 | import Data.Int 21 | import Data.Readable 22 | import Data.Text (Text) 23 | import Database.Beam 24 | import Database.Beam.Backend.SQL 25 | import Database.Beam.Backend.Types 26 | import Database.Beam.Migrate 27 | ------------------------------------------------------------------------------ 28 | 29 | ------------------------------------------------------------------------------ 30 | 31 | data Platform = X86_64_Darwin | X86_64_Linux | I686_Linux 32 | deriving (Eq,Ord,Enum,Bounded) 33 | 34 | instance Show Platform where 35 | show X86_64_Darwin = "x86_64-darwin" 36 | show X86_64_Linux = "x86_64-linux" 37 | show I686_Linux = "i686-linux" 38 | 39 | instance Readable Platform where 40 | fromText "x86_64-darwin" = return X86_64_Darwin 41 | fromText "x86_64-linux" = return X86_64_Linux 42 | fromText "i686-linux" = return I686_Linux 43 | fromText _ = mzero 44 | 45 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Platform where 46 | defaultSqlDataType _ _ _ = varCharType Nothing Nothing 47 | 48 | instance HasSqlValueSyntax be String => HasSqlValueSyntax be Platform where 49 | sqlValueSyntax = autoSqlValueSyntax 50 | 51 | instance (BeamBackend be, FromBackendRow be Text) => FromBackendRow be Platform where 52 | fromBackendRow = maybe (error "BeamRowParseError") id . fromText <$> fromBackendRow 53 | 54 | data BuilderT f = Builder 55 | { _builder_id :: C f Int32 56 | , _builder_ip :: C f Text 57 | , _builder_platform :: C f Platform 58 | , _builder_maxBuilds :: C f Int32 59 | , _builder_speedFactor :: C f Int32 60 | } deriving Generic 61 | 62 | type Builder = BuilderT Identity 63 | type BuilderId = PrimaryKey BuilderT Identity 64 | 65 | deriving instance Eq (PrimaryKey BuilderT Identity) 66 | deriving instance Eq Builder 67 | deriving instance Show (PrimaryKey BuilderT Identity) 68 | deriving instance Show Builder 69 | 70 | instance Beamable BuilderT 71 | 72 | instance Table BuilderT where 73 | data PrimaryKey BuilderT f = BuilderId (Columnar f Int32) 74 | deriving (Generic, Beamable) 75 | primaryKey = BuilderId . _builder_id 76 | -------------------------------------------------------------------------------- /common/src/Common/Types/CacheJob.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Common.Types.CacheJob where 18 | 19 | ------------------------------------------------------------------------------ 20 | import Control.Lens 21 | import Data.Aeson 22 | import Data.Int 23 | import Data.Text (Text) 24 | import Data.Time 25 | import Database.Beam 26 | ------------------------------------------------------------------------------ 27 | import Common.Types.BinaryCache 28 | import Common.Types.JobStatus 29 | ------------------------------------------------------------------------------ 30 | 31 | ------------------------------------------------------------------------------ 32 | data CacheJobT f = CacheJob 33 | { _cacheJob_id :: C f Int32 34 | , _cacheJob_storePath :: C f Text 35 | , _cacheJob_cache :: PrimaryKey BinaryCacheT (Nullable f) 36 | , _cacheJob_startedAt :: C f (Maybe UTCTime) 37 | , _cacheJob_endedAt :: C f (Maybe UTCTime) 38 | , _cacheJob_status :: C f JobStatus 39 | } deriving (Generic) 40 | 41 | CacheJob 42 | (LensFor cacheJob_id) 43 | (LensFor cacheJob_nixPath) 44 | (BinaryCacheId (LensFor cacheJob_cache)) 45 | (LensFor cacheJob_startedAt) 46 | (LensFor cacheJob_endedAt) 47 | (LensFor cacheJob_status) 48 | = tableLenses 49 | 50 | type CacheJob = CacheJobT Identity 51 | type CacheJobId = PrimaryKey CacheJobT Identity 52 | 53 | deriving instance Eq (PrimaryKey CacheJobT Identity) 54 | deriving instance Eq CacheJob 55 | deriving instance Ord (PrimaryKey CacheJobT Identity) 56 | deriving instance Ord CacheJob 57 | deriving instance Show (PrimaryKey CacheJobT Identity) 58 | deriving instance Show CacheJob 59 | 60 | instance ToJSON (PrimaryKey CacheJobT Identity) where 61 | toEncoding = genericToEncoding defaultOptions 62 | instance FromJSON (PrimaryKey CacheJobT Identity) 63 | 64 | instance ToJSON CacheJob where 65 | toEncoding = genericToEncoding defaultOptions 66 | instance FromJSON CacheJob 67 | 68 | instance Beamable CacheJobT 69 | 70 | instance Table CacheJobT where 71 | data PrimaryKey CacheJobT f = CacheJobId (Columnar f Int32) 72 | deriving (Generic, Beamable) 73 | primaryKey = CacheJobId . _cacheJob_id 74 | -------------------------------------------------------------------------------- /common/src/Common/Types/CachedHash.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Common.Types.CachedHash where 18 | 19 | ------------------------------------------------------------------------------ 20 | import Data.Aeson 21 | import Data.Text (Text) 22 | import Data.Time 23 | import Database.Beam 24 | ------------------------------------------------------------------------------ 25 | import Common.Types.BinaryCache 26 | ------------------------------------------------------------------------------ 27 | 28 | 29 | ------------------------------------------------------------------------------ 30 | data CachedHashT f = CachedHash 31 | { _cachedHash_hash :: C f Text 32 | , _cachedHash_cache :: PrimaryKey BinaryCacheT f 33 | , _cachedHash_time :: C f UTCTime 34 | } deriving Generic 35 | 36 | CachedHash 37 | (LensFor cachedHash_hash) 38 | (BinaryCacheId (LensFor cachedHash_cache)) 39 | (LensFor cachedHash_time) 40 | = tableLenses 41 | 42 | type CachedHash = CachedHashT Identity 43 | 44 | deriving instance Eq (PrimaryKey CachedHashT Identity) 45 | deriving instance Eq (PrimaryKey CachedHashT Maybe) 46 | deriving instance Eq CachedHash 47 | deriving instance Show (PrimaryKey CachedHashT Identity) 48 | deriving instance Show (PrimaryKey CachedHashT Maybe) 49 | deriving instance Show CachedHash 50 | deriving instance Show (CachedHashT Maybe) 51 | deriving instance Ord (PrimaryKey CachedHashT Identity) 52 | deriving instance Ord (PrimaryKey CachedHashT Maybe) 53 | deriving instance Ord CachedHash 54 | 55 | instance ToJSON (CachedHashT Identity) where 56 | toEncoding = genericToEncoding defaultOptions 57 | 58 | instance FromJSON (CachedHashT Identity) 59 | 60 | instance ToJSON (CachedHashT Maybe) where 61 | toEncoding = genericToEncoding defaultOptions 62 | 63 | instance FromJSON (CachedHashT Maybe) 64 | 65 | instance Beamable CachedHashT 66 | 67 | --instance Table CachedHashT where 68 | -- data PrimaryKey CachedHashT f = CachedHashId (Columnar f Text) 69 | -- deriving (Generic, Beamable) 70 | -- primaryKey = CachedHashId . _cachedHash_hash 71 | 72 | instance Table CachedHashT where 73 | data PrimaryKey CachedHashT f = CachedHashId (PrimaryKey BinaryCacheT f) (Columnar f Text) 74 | deriving (Generic, Beamable) 75 | primaryKey ch = CachedHashId (_cachedHash_cache ch) (_cachedHash_hash ch) 76 | 77 | -------------------------------------------------------------------------------- /common/src/Common/Types/CiSettings.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Common.Types.CiSettings where 19 | 20 | ------------------------------------------------------------------------------ 21 | import Control.Lens 22 | import Data.Aeson 23 | import Data.Int 24 | import Data.Text (Text) 25 | import Database.Beam 26 | ------------------------------------------------------------------------------ 27 | 28 | ------------------------------------------------------------------------------ 29 | data CiSettingsT f = CiSettings 30 | { _ciSettings_id :: C f Int32 31 | , _ciSettings_nixPath :: C f Text 32 | , _ciSettings_serveLocalCache :: C f Bool 33 | } deriving (Generic) 34 | 35 | CiSettings 36 | (LensFor ciSettings_id) 37 | (LensFor ciSettings_nixPath) 38 | (LensFor ciSettings_serveLocalCache) 39 | = tableLenses 40 | 41 | type CiSettings = CiSettingsT Identity 42 | type CiSettingsId = PrimaryKey CiSettingsT Identity 43 | 44 | deriving instance Eq (PrimaryKey CiSettingsT Identity) 45 | deriving instance Eq CiSettings 46 | deriving instance Ord (PrimaryKey CiSettingsT Identity) 47 | deriving instance Ord CiSettings 48 | deriving instance Show (PrimaryKey CiSettingsT Identity) 49 | deriving instance Show CiSettings 50 | 51 | instance ToJSON (PrimaryKey CiSettingsT Identity) where 52 | toEncoding = genericToEncoding defaultOptions 53 | instance FromJSON (PrimaryKey CiSettingsT Identity) 54 | 55 | instance ToJSON CiSettings where 56 | toEncoding = genericToEncoding defaultOptions 57 | instance FromJSON CiSettings 58 | 59 | instance Beamable CiSettingsT 60 | 61 | instance Table CiSettingsT where 62 | data PrimaryKey CiSettingsT f = CiSettingsId (Columnar f Int32) 63 | deriving (Generic, Beamable) 64 | primaryKey = CiSettingsId . _ciSettings_id 65 | -------------------------------------------------------------------------------- /common/src/Common/Types/ConnectedAccount.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE ImpredicativeTypes #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeSynonymInstances #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | module Common.Types.ConnectedAccount where 20 | 21 | ------------------------------------------------------------------------------ 22 | import Data.Aeson 23 | import Data.Default 24 | import Data.Int 25 | import Data.Text (Text) 26 | import qualified Data.Text as T 27 | import Database.Beam 28 | import Database.Beam.Backend.SQL 29 | import Database.Beam.Backend.Types 30 | import Database.Beam.Migrate.Generics 31 | import Database.Beam.Migrate.SQL 32 | import Scrub 33 | ------------------------------------------------------------------------------ 34 | 35 | data AccountProvider = GitHub | GitLab 36 | deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) 37 | 38 | providerUrl :: AccountProvider -> Text 39 | providerUrl GitHub = "https://github.com" 40 | providerUrl GitLab = "https://gitlab.com" 41 | 42 | instance ToJSON AccountProvider where 43 | toEncoding = genericToEncoding defaultOptions 44 | 45 | instance FromJSON AccountProvider 46 | 47 | instance HasSqlValueSyntax be String => HasSqlValueSyntax be AccountProvider where 48 | sqlValueSyntax = autoSqlValueSyntax 49 | 50 | instance (BeamBackend be, FromBackendRow be Text) => FromBackendRow be AccountProvider where 51 | fromBackendRow = read . T.unpack <$> fromBackendRow 52 | 53 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be AccountProvider where 54 | defaultSqlDataType _ _ _ = varCharType Nothing Nothing 55 | 56 | --data WebhookInfo f = WebhookInfo 57 | -- { _webhookInfo_url :: C f Text 58 | -- , _webhookInfo_testUrl :: C f Text 59 | -- , _webhookInfo_id :: C f Int32 60 | -- , _webhookInfo_name :: C f Text 61 | -- , _webhookInfo_active :: C f Bool 62 | -- } deriving Generic 63 | 64 | ------------------------------------------------------------------------------ 65 | data ConnectedAccountT f = ConnectedAccount 66 | { _connectedAccount_id :: C f Int32 67 | , _connectedAccount_name :: C f Text 68 | -- ^ Name of the account (or organization) that owns the repositories that 69 | -- you are connecting to. This should NOT be the username of the account 70 | -- you authenticate to github with. 71 | , _connectedAccount_accessToken :: C f Text 72 | -- ^ The access token to the account that grants you access to the repo 73 | -- (even if it is different from the owner of the repo). 74 | , _connectedAccount_provider :: C f AccountProvider 75 | } deriving (Generic) 76 | 77 | --deriving anyclass (FunctorB, TraversableB, ProductB, ConstraintsB, ProductBC) 78 | 79 | --deriving instance AllBF Show f Barbie => Show (Barbie f) 80 | --deriving instance AllBF Eq f Barbie => Eq (Barbie f) 81 | 82 | caToMaybe :: ConnectedAccountT Identity -> ConnectedAccountT Maybe 83 | caToMaybe (ConnectedAccount i n a p) = ConnectedAccount (Just i) (Just n) (Just a) (Just p) 84 | 85 | instance Scrub (ConnectedAccountT Maybe) where 86 | scrub ca = Scrubbed $ ca { _connectedAccount_accessToken = Nothing } 87 | 88 | ConnectedAccount (LensFor connectedAccount_id) (LensFor connectedAccount_name) 89 | (LensFor connectedAccount_accessToken) (LensFor connectedAccount_provider) 90 | = tableLenses 91 | 92 | type ConnectedAccount = ConnectedAccountT Identity 93 | type ConnectedAccountId = PrimaryKey ConnectedAccountT Identity 94 | 95 | deriving instance Eq (PrimaryKey ConnectedAccountT Identity) 96 | deriving instance Eq (PrimaryKey ConnectedAccountT Maybe) 97 | deriving instance Eq ConnectedAccount 98 | deriving instance Show (PrimaryKey ConnectedAccountT Identity) 99 | deriving instance Show (PrimaryKey ConnectedAccountT Maybe) 100 | deriving instance Show ConnectedAccount 101 | deriving instance Show (ConnectedAccountT Maybe) 102 | deriving instance Default (ConnectedAccountT Maybe) 103 | 104 | deriving instance Ord ConnectedAccount 105 | deriving instance Ord (PrimaryKey ConnectedAccountT Identity) 106 | deriving instance Ord (PrimaryKey ConnectedAccountT Maybe) 107 | 108 | instance ToJSON (PrimaryKey ConnectedAccountT Identity) where 109 | toEncoding = genericToEncoding defaultOptions 110 | 111 | instance FromJSON (PrimaryKey ConnectedAccountT Identity) 112 | 113 | instance ToJSON (PrimaryKey ConnectedAccountT Maybe) where 114 | toEncoding = genericToEncoding defaultOptions 115 | 116 | instance FromJSON (PrimaryKey ConnectedAccountT Maybe) 117 | 118 | instance ToJSON (ConnectedAccountT Identity) where 119 | toEncoding = genericToEncoding defaultOptions 120 | 121 | instance FromJSON (ConnectedAccountT Identity) 122 | 123 | instance ToJSON (ConnectedAccountT Maybe) where 124 | toEncoding = genericToEncoding defaultOptions 125 | 126 | instance FromJSON (ConnectedAccountT Maybe) 127 | 128 | instance Beamable ConnectedAccountT 129 | 130 | instance Table ConnectedAccountT where 131 | data PrimaryKey ConnectedAccountT f = ConnectedAccountId (Columnar f Int32) 132 | deriving (Generic, Beamable) 133 | primaryKey = ConnectedAccountId . _connectedAccount_id 134 | 135 | caKeyToInt :: PrimaryKey ConnectedAccountT Identity -> Int32 136 | caKeyToInt (ConnectedAccountId k) = k 137 | 138 | intToCaKey :: Int32 -> PrimaryKey ConnectedAccountT Identity 139 | intToCaKey k = ConnectedAccountId k 140 | 141 | caKeyIdToMaybe :: PrimaryKey ConnectedAccountT Identity -> PrimaryKey ConnectedAccountT Maybe 142 | caKeyIdToMaybe (ConnectedAccountId k) = ConnectedAccountId (Just k) 143 | 144 | caKeyMaybeToId :: PrimaryKey ConnectedAccountT Maybe -> Maybe (PrimaryKey ConnectedAccountT Identity) 145 | caKeyMaybeToId (ConnectedAccountId (Just k)) = Just (ConnectedAccountId k) 146 | caKeyMaybeToId (ConnectedAccountId Nothing) = Nothing 147 | -------------------------------------------------------------------------------- /common/src/Common/Types/GitHash.hs: -------------------------------------------------------------------------------- 1 | module Common.Types.GitHash where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Aeson 5 | import Data.Text (Text) 6 | import qualified Data.Text as T 7 | ------------------------------------------------------------------------------ 8 | 9 | newtype GitHash = GitHash { unGitHash :: Text } 10 | deriving (Show, Read, Eq, Ord) 11 | 12 | instance FromJSON GitHash where 13 | parseJSON a = GitHash <$> parseJSON a 14 | 15 | instance ToJSON GitHash where 16 | toJSON (GitHash a) = toJSON a 17 | 18 | shortHash :: GitHash -> Text 19 | shortHash = T.take 8 . unGitHash 20 | 21 | -------------------------------------------------------------------------------- /common/src/Common/Types/JobStatus.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE ImpredicativeTypes #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Common.Types.JobStatus where 19 | 20 | ------------------------------------------------------------------------------ 21 | import Data.Aeson 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import Database.Beam 25 | import Database.Beam.Backend.SQL 26 | import Database.Beam.Backend.Types 27 | import Database.Beam.Migrate.Generics 28 | import Database.Beam.Migrate.SQL 29 | ------------------------------------------------------------------------------ 30 | 31 | data JobStatus 32 | = JobPending 33 | | JobInProgress 34 | | JobCanceled 35 | | JobTimedOut 36 | | JobVanished 37 | | JobFailed 38 | | JobSucceeded 39 | deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) 40 | 41 | instance BeamMigrateSqlBackend be => HasSqlEqualityCheck be JobStatus 42 | 43 | instance HasSqlValueSyntax be String => HasSqlValueSyntax be JobStatus where 44 | sqlValueSyntax = autoSqlValueSyntax 45 | 46 | instance (BeamBackend be, FromBackendRow be Text) => FromBackendRow be JobStatus where 47 | fromBackendRow = read . T.unpack <$> fromBackendRow 48 | 49 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be JobStatus where 50 | defaultSqlDataType _ _ _ = varCharType Nothing Nothing 51 | 52 | instance ToJSON JobStatus where 53 | toEncoding = genericToEncoding defaultOptions 54 | 55 | instance FromJSON JobStatus 56 | -------------------------------------------------------------------------------- /common/src/Common/Types/NixCacheKeyPair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Common.Types.NixCacheKeyPair 5 | ( NixCacheKey 6 | , _nck_name 7 | , _nck_key 8 | , readKeyFile 9 | , nckToText 10 | , NixCacheKeyPair(..) 11 | ) where 12 | 13 | ------------------------------------------------------------------------------ 14 | import Data.ByteString (ByteString) 15 | import qualified Data.ByteString.Base64 as Base64 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import qualified Data.Text.IO as T 20 | import GHC.Generics 21 | import System.Directory 22 | ------------------------------------------------------------------------------ 23 | 24 | data NixCacheKey = NixCacheKey 25 | { _nck_name :: Text 26 | , _nck_key :: ByteString 27 | } deriving (Eq,Ord,Show,Generic) 28 | 29 | readKeyFile :: FilePath -> IO (Either String NixCacheKey) 30 | readKeyFile fp = do 31 | exists <- doesFileExist fp 32 | if not exists 33 | then return $ Left $ "File " <> fp <> " does not exist" 34 | else do 35 | t <- T.strip <$> T.readFile fp 36 | let (n,k) = T.breakOn ":" t 37 | return $ NixCacheKey n <$> Base64.decode (T.encodeUtf8 $ T.drop 1 k) 38 | 39 | nckToText :: NixCacheKey -> Text 40 | nckToText (NixCacheKey n k) = n <> ":" <> (T.decodeUtf8 $ Base64.encode k) 41 | 42 | data NixCacheKeyPair = NixCacheKeyPair 43 | { _nixCacheKey_secret :: NixCacheKey 44 | , _nixCacheKey_public :: NixCacheKey 45 | } deriving (Eq,Ord,Show,Generic) 46 | -------------------------------------------------------------------------------- /common/src/Common/Types/ProcMsg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Common.Types.ProcMsg where 5 | 6 | ------------------------------------------------------------------------------ 7 | import Control.Error 8 | import Control.Monad 9 | import Data.Aeson 10 | import Data.Readable 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Data.Time 14 | import GHC.Generics 15 | import Text.Printf 16 | ------------------------------------------------------------------------------ 17 | 18 | data ProcMsgSource = CiMsg | BuildCommandMsg | StdoutMsg | StderrMsg 19 | deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) 20 | 21 | instance ToJSON ProcMsgSource where 22 | toEncoding = genericToEncoding defaultOptions 23 | 24 | instance FromJSON ProcMsgSource 25 | 26 | instance Readable ProcMsgSource where 27 | fromText "CI" = return CiMsg 28 | fromText "CMD" = return BuildCommandMsg 29 | fromText "OUT" = return StdoutMsg 30 | fromText "ERR" = return StderrMsg 31 | fromText _ = mzero 32 | 33 | prettyProcMsgSource :: ProcMsgSource -> Text 34 | prettyProcMsgSource CiMsg = "CI" 35 | prettyProcMsgSource BuildCommandMsg = "CMD" 36 | prettyProcMsgSource StdoutMsg = "OUT" 37 | prettyProcMsgSource StderrMsg = "ERR" 38 | 39 | data ProcMsg = ProcMsg 40 | { _procMsg_timestamp :: UTCTime 41 | , _procMsg_source :: ProcMsgSource 42 | , _procMsg_msg :: Text 43 | } deriving (Eq,Ord,Show,Read,Generic) 44 | 45 | prettyProcMsg :: ProcMsg -> Text 46 | prettyProcMsg (ProcMsg t s m) = 47 | prettyProcMsgSource s <> " [" <> T.pack (show t) <> "] " <> m 48 | 49 | parseProcMsg :: Text -> Either String ProcMsg 50 | parseProcMsg msg = do 51 | ts <- note ("parseProcMsg: Error parsing timestamp: " <> t) $ readMay t 52 | src <- note ("parseProcMsg: Error parsing source: " <> t) $ fromText srcText 53 | return $ ProcMsg ts src $ T.drop 2 msg2 54 | where 55 | (a,msg2) = T.breakOn "] " msg 56 | (srcText, time) = T.breakOn " [" a 57 | t = T.unpack $ T.drop 2 time 58 | 59 | textProcMsg :: Text -> IO ProcMsg 60 | textProcMsg msg = do 61 | t <- getCurrentTime 62 | return $ ProcMsg t CiMsg msg 63 | 64 | instance ToJSON ProcMsg where 65 | toEncoding = genericToEncoding defaultOptions 66 | 67 | instance FromJSON ProcMsg 68 | -------------------------------------------------------------------------------- /common/src/Common/Types/Repo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Common.Types.Repo where 18 | 19 | ------------------------------------------------------------------------------ 20 | import Data.Aeson 21 | import Data.Int 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import Database.Beam 25 | import Database.Beam.Backend.SQL 26 | import Database.Beam.Backend.Types 27 | import Database.Beam.Migrate.Generics 28 | import Database.Beam.Migrate.SQL 29 | ------------------------------------------------------------------------------ 30 | import Common.Types.BinaryCache 31 | import Common.Types.ConnectedAccount 32 | ------------------------------------------------------------------------------ 33 | 34 | 35 | newtype AttrList = AttrList { unAttrList :: [Text] } 36 | deriving (Eq,Ord,Show,Read,Generic) 37 | 38 | instance Semigroup AttrList where 39 | AttrList a <> AttrList b = AttrList (a <> b) 40 | 41 | instance Monoid AttrList where 42 | mempty = AttrList mempty 43 | 44 | instance ToJSON AttrList where 45 | toEncoding = genericToEncoding defaultOptions 46 | 47 | instance FromJSON AttrList 48 | 49 | instance HasSqlValueSyntax be String => HasSqlValueSyntax be AttrList where 50 | sqlValueSyntax = sqlValueSyntax . show . unAttrList 51 | 52 | instance (BeamBackend be, FromBackendRow be Text) => FromBackendRow be AttrList where 53 | fromBackendRow = AttrList . read . T.unpack <$> fromBackendRow 54 | 55 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be AttrList where 56 | defaultSqlDataType _ _ _ = varCharType Nothing Nothing 57 | 58 | 59 | ------------------------------------------------------------------------------ 60 | data RepoT f = Repo 61 | { _repo_id :: C f Int32 62 | -- ^ For GitHub this is "owner/name". 63 | , _repo_accessAccount :: PrimaryKey ConnectedAccountT f 64 | , _repo_name :: C f Text 65 | , _repo_namespace :: C f Text 66 | -- ^ With GitHub repos this is always the repository name. With gitlab it 67 | -- can be a deeper nested path of groups /foo/bar/baz/repo 68 | , _repo_buildNixFile :: C f Text 69 | , _repo_attributesToBuild :: C f AttrList 70 | , _repo_timeout :: C f Int32 71 | -- ^ Build timeout in seconds 72 | , _repo_cache :: PrimaryKey BinaryCacheT (Nullable f) 73 | , _repo_hookId :: C f Int32 74 | -- ^ Allows us to delete the webhook 75 | } deriving Generic 76 | 77 | repoFullName :: Repo -> Text 78 | repoFullName r = _repo_namespace r <> "/" <> _repo_name r 79 | 80 | repoToMaybe :: RepoT Identity -> RepoT Maybe 81 | repoToMaybe (Repo i (ConnectedAccountId o) on rn bf as t (BinaryCacheId c) h) = Repo (Just i) 82 | (ConnectedAccountId $ Just o) (Just on) (Just rn) (Just bf) (Just as) (Just t) (BinaryCacheId $ Just c) (Just h) 83 | -- where 84 | -- f (BinaryCacheId i) = BinaryCacheId $ Just i 85 | 86 | Repo 87 | (LensFor repo_id) 88 | (ConnectedAccountId (LensFor repo_accessAccount)) 89 | (LensFor repo_name) 90 | (LensFor repo_namespace) 91 | (LensFor repo_buildNixFile) 92 | (LensFor repo_attributesToBuild) 93 | (LensFor repo_timeout) 94 | (BinaryCacheId (LensFor repo_cache)) 95 | (LensFor repo_hookId) 96 | = tableLenses 97 | 98 | type Repo = RepoT Identity 99 | type RepoId = PrimaryKey RepoT Identity 100 | 101 | deriving instance Eq (PrimaryKey RepoT Identity) 102 | deriving instance Eq (PrimaryKey RepoT Maybe) 103 | deriving instance Eq Repo 104 | deriving instance Show (PrimaryKey RepoT Identity) 105 | deriving instance Show (PrimaryKey RepoT Maybe) 106 | deriving instance Show Repo 107 | deriving instance Show (RepoT Maybe) 108 | deriving instance Ord (PrimaryKey RepoT Identity) 109 | deriving instance Ord (PrimaryKey RepoT Maybe) 110 | 111 | instance ToJSON (PrimaryKey RepoT Identity) where 112 | toEncoding = genericToEncoding defaultOptions 113 | 114 | instance FromJSON (PrimaryKey RepoT Identity) 115 | 116 | instance ToJSON (PrimaryKey RepoT Maybe) where 117 | toEncoding = genericToEncoding defaultOptions 118 | 119 | instance FromJSON (PrimaryKey RepoT Maybe) 120 | 121 | instance ToJSON (RepoT Identity) where 122 | toEncoding = genericToEncoding defaultOptions 123 | 124 | instance FromJSON (RepoT Identity) 125 | 126 | instance ToJSON (RepoT Maybe) where 127 | toEncoding = genericToEncoding defaultOptions 128 | 129 | instance FromJSON (RepoT Maybe) 130 | 131 | instance Beamable RepoT 132 | 133 | instance Table RepoT where 134 | data PrimaryKey RepoT f = RepoId (Columnar f Int32) 135 | deriving (Generic, Beamable) 136 | primaryKey = RepoId . _repo_id 137 | 138 | repoKeyToInt :: PrimaryKey RepoT Identity -> Int32 139 | repoKeyToInt (RepoId k) = k 140 | -------------------------------------------------------------------------------- /common/src/Common/Types/RepoBuildInfo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE EmptyCase #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Common.Types.RepoBuildInfo where 19 | 20 | ------------------------------------------------------------------------------ 21 | import Data.Aeson 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import Database.Beam 25 | import Database.Beam.Backend.SQL 26 | import Database.Beam.Backend.Types 27 | import Database.Beam.Migrate.Generics 28 | import Database.Beam.Migrate.SQL 29 | ------------------------------------------------------------------------------ 30 | 31 | data RepoEvent = RepoPush | RepoPullRequest 32 | deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) 33 | 34 | instance HasSqlValueSyntax be String => HasSqlValueSyntax be RepoEvent where 35 | sqlValueSyntax = autoSqlValueSyntax 36 | 37 | instance (BeamBackend be, FromBackendRow be Text) => FromBackendRow be RepoEvent where 38 | fromBackendRow = read . T.unpack <$> fromBackendRow 39 | 40 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be RepoEvent where 41 | defaultSqlDataType _ _ _ = varCharType Nothing Nothing 42 | 43 | instance ToJSON RepoEvent where 44 | toEncoding = genericToEncoding defaultOptions 45 | 46 | instance FromJSON RepoEvent 47 | 48 | data RepoBuildInfoT f = RepoBuildInfo 49 | { _rbi_repoName :: C f Text 50 | , _rbi_repoNamespace :: C f Text 51 | , _rbi_repoEvent :: C f RepoEvent 52 | , _rbi_cloneUrlSsh :: C f Text 53 | , _rbi_cloneUrlHttp :: C f Text 54 | , _rbi_gitRef :: C f Text 55 | , _rbi_commitHash :: C f Text 56 | , _rbi_commitMsg :: C f Text 57 | , _rbi_pushUser :: C f Text 58 | , _rbi_pushAvatar :: C f (Maybe Text) 59 | } deriving (Generic) 60 | 61 | rbiRepoFullName :: RepoBuildInfo -> Text 62 | rbiRepoFullName RepoBuildInfo{..} = 63 | _rbi_repoNamespace <> "/" <> _rbi_repoName 64 | 65 | -- TODO Handle links appropriately for github and gitlab 66 | rbiRepoLink :: RepoBuildInfo -> Text 67 | rbiRepoLink rbi = 68 | "https://github.com/" <> rbiRepoFullName rbi 69 | 70 | -- TODO Handle links appropriately for github and gitlab 71 | rbiCommitLink :: RepoBuildInfo -> Text 72 | rbiCommitLink rbi = 73 | rbiRepoLink rbi <> "/commit/" <> _rbi_commitHash rbi 74 | 75 | RepoBuildInfo 76 | (LensFor rbi_repoName) 77 | (LensFor rbi_repoFullName) 78 | (LensFor rbi_repoEvent) 79 | (LensFor rbi_cloneUrlSsh) 80 | (LensFor rbi_cloneUrlHttp) 81 | (LensFor rbi_gitRef) 82 | (LensFor rbi_commitHash) 83 | (LensFor rbi_commitMsg) 84 | (LensFor rbi_pushUser) 85 | (LensFor rbi_pushAvatar) 86 | = tableLenses 87 | 88 | type RepoBuildInfo = RepoBuildInfoT Identity 89 | 90 | deriving instance Eq RepoBuildInfo 91 | deriving instance Ord RepoBuildInfo 92 | deriving instance Show RepoBuildInfo 93 | 94 | instance ToJSON (RepoBuildInfoT Identity) where 95 | toEncoding = genericToEncoding defaultOptions 96 | 97 | instance FromJSON (RepoBuildInfoT Identity) 98 | 99 | instance Beamable RepoBuildInfoT 100 | 101 | prettyRBI ::RepoBuildInfo -> Text 102 | prettyRBI rbi = T.unlines 103 | [ _rbi_repoNamespace rbi 104 | , _rbi_repoName rbi 105 | , _rbi_cloneUrlSsh rbi 106 | , _rbi_cloneUrlHttp rbi 107 | , _rbi_commitHash rbi 108 | ] 109 | -------------------------------------------------------------------------------- /common/src/Common/Types/S3Cache.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Common.Types.S3Cache where 19 | 20 | ------------------------------------------------------------------------------ 21 | import Control.Monad 22 | import Data.Aeson 23 | import Data.Readable 24 | import Data.String.Conv 25 | import Data.Text (Text) 26 | import Data.Text.Encoding 27 | import Database.Beam 28 | import Database.Beam.Backend.SQL 29 | import Database.Beam.Backend.Types 30 | import Database.Beam.Migrate.Generics 31 | import Database.Beam.Migrate.SQL 32 | import Scrub 33 | ------------------------------------------------------------------------------ 34 | 35 | -- Copying this code from amazonka to avoid the dep in GHCJS 36 | data Region 37 | = NorthVirginia -- ^ US East ('us-east-1'). 38 | | Ohio -- ^ US East ('us-east-2'). 39 | | NorthCalifornia -- ^ US West ('us-west-1'). 40 | | Oregon -- ^ US West ('us-west-2'). 41 | | Montreal -- ^ Canada ('ca-central-1'). 42 | | Tokyo -- ^ Asia Pacific ('ap-northeast-1'). 43 | | Seoul -- ^ Asia Pacific ('ap-northeast-2'). 44 | | Mumbai -- ^ Asia Pacific ('ap-south-1'). 45 | | Singapore -- ^ Asia Pacific ('ap-southeast-1'). 46 | | Sydney -- ^ Asia Pacific ('ap-southeast-2'). 47 | | SaoPaulo -- ^ South America ('sa-east-1'). 48 | | Ireland -- ^ EU ('eu-west-1'). 49 | | London -- ^ EU ('eu-west-2'). 50 | | Frankfurt -- ^ EU ('eu-central-1'). 51 | | GovCloud -- ^ US GovCloud ('us-gov-west-1'). 52 | | GovCloudFIPS -- ^ US GovCloud FIPS (S3 Only, 'fips-us-gov-west-1'). 53 | | Beijing -- ^ China ('cn-north-1'). 54 | deriving (Eq, Ord, Show, Read, Enum, Bounded) 55 | 56 | instance Readable Region where 57 | fromText = \case 58 | "us-east-1" -> pure NorthVirginia 59 | "us-east-2" -> pure Ohio 60 | "us-west-1" -> pure NorthCalifornia 61 | "us-west-2" -> pure Oregon 62 | "ca-central-1" -> pure Montreal 63 | "ap-northeast-1" -> pure Tokyo 64 | "ap-northeast-2" -> pure Seoul 65 | "ap-south-1" -> pure Mumbai 66 | "ap-southeast-1" -> pure Singapore 67 | "ap-southeast-2" -> pure Sydney 68 | "sa-east-1" -> pure SaoPaulo 69 | "eu-west-1" -> pure Ireland 70 | "eu-west-2" -> pure London 71 | "eu-central-1" -> pure Frankfurt 72 | "us-gov-west-1" -> pure GovCloud 73 | "fips-us-gov-west-1" -> pure GovCloudFIPS 74 | "cn-north-1" -> pure Beijing 75 | _ -> mzero 76 | 77 | regionText :: Region -> Text 78 | regionText = \case 79 | NorthVirginia -> "us-east-1" 80 | Ohio -> "us-east-2" 81 | NorthCalifornia -> "us-west-1" 82 | Oregon -> "us-west-2" 83 | Montreal -> "ca-central-1" 84 | Tokyo -> "ap-northeast-1" 85 | Seoul -> "ap-northeast-2" 86 | Mumbai -> "ap-south-1" 87 | Singapore -> "ap-southeast-1" 88 | Sydney -> "ap-southeast-2" 89 | SaoPaulo -> "sa-east-1" 90 | Ireland -> "eu-west-1" 91 | London -> "eu-west-2" 92 | Frankfurt -> "eu-central-1" 93 | GovCloud -> "us-gov-west-1" 94 | GovCloudFIPS -> "fips-us-gov-west-1" 95 | Beijing -> "cn-north-1" 96 | 97 | instance ToJSON Region where 98 | toJSON = String . regionText 99 | toEncoding = toEncoding . regionText 100 | 101 | instance FromJSON Region where 102 | parseJSON = withText "Region" (maybe (fail "Invalid Region format") pure . fromText) 103 | 104 | data S3Cache = S3Cache 105 | { _s3Cache_bucket :: Text 106 | , _s3Cache_region :: Region 107 | , _s3Cache_accessKey :: Text 108 | , _s3Cache_secretKey :: Text 109 | } deriving (Eq,Ord,Show,Read,Generic) 110 | 111 | instance Scrub S3Cache where 112 | scrub c = Scrubbed $ c { _s3Cache_secretKey = "" } 113 | 114 | instance ToJSON S3Cache where 115 | toEncoding = genericToEncoding defaultOptions 116 | instance FromJSON S3Cache 117 | 118 | instance HasSqlValueSyntax be Text => HasSqlValueSyntax be S3Cache where 119 | sqlValueSyntax = sqlValueSyntax . decodeUtf8 . toS . encode 120 | 121 | instance (BeamBackend be, FromBackendRow be Text) => FromBackendRow be S3Cache where 122 | fromBackendRow = maybe (fail "Could not parse S3Cache") return . decodeStrict . encodeUtf8 =<< fromBackendRow 123 | 124 | instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be S3Cache where 125 | defaultSqlDataType _ _ _ = varCharType Nothing Nothing 126 | -------------------------------------------------------------------------------- /common/src/Humanizable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Humanizable where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | ------------------------------------------------------------------------------ 9 | import Common.Types.ConnectedAccount 10 | import Common.Types.S3Cache 11 | ------------------------------------------------------------------------------ 12 | 13 | class Humanizable a where 14 | humanize :: a -> Text 15 | 16 | instance Humanizable AccountProvider where 17 | humanize = T.pack . show 18 | 19 | instance Humanizable Region where 20 | humanize r = T.pack (show r) <> " (" <> regionText r <> ")" 21 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem # TODO: Get rid of this system cruft 2 | , iosSdkVersion ? "10.2" 3 | }: 4 | let 5 | 6 | origObelisk = import ./.obelisk/impl { 7 | inherit system iosSdkVersion; 8 | }; 9 | opkgs = origObelisk.reflex-platform.nixpkgs; 10 | ignorePaths = 11 | [ ".git" "tags" "TAGS" "README.md" "dist" "dist-newstyle" 12 | "frontend.jsexe.assets" "static.assets" "result-exe" 13 | "zeus-access-token" "zeus-cache-key.pub" 14 | "zeus-cache-key.sec" "zeus.db" "migrations.md" 15 | ]; 16 | 17 | 18 | myMkObeliskApp = 19 | { exe 20 | , routeHost 21 | , enableHttps 22 | , name ? "backend" 23 | , user ? name 24 | , group ? user 25 | , baseUrl ? "/" 26 | , internalPort ? 8000 27 | , backendArgs ? "--port=${toString internalPort}" 28 | , ... 29 | }: {...}: { 30 | services.nginx = { 31 | enable = true; 32 | virtualHosts."${routeHost}" = { 33 | enableACME = enableHttps; 34 | forceSSL = enableHttps; 35 | locations.${baseUrl} = { 36 | proxyPass = "http://localhost:" + toString internalPort; 37 | proxyWebsockets = true; 38 | }; 39 | }; 40 | }; 41 | systemd.services.${name} = { 42 | wantedBy = [ "multi-user.target" ]; 43 | after = [ "network.target" ]; 44 | restartIfChanged = true; 45 | path = [ 46 | opkgs.awscli 47 | opkgs.git 48 | opkgs.gnutar 49 | opkgs.gzip 50 | opkgs.nix 51 | ]; 52 | script = '' 53 | ln -sft . '${exe}'/* 54 | mkdir -p log 55 | exec ./backend ${backendArgs} >>backend.output 2>&1 {}).fetchFromGitHub { 6 | inherit owner repo rev sha256 fetchSubmodules private; 7 | }; 8 | json = builtins.fromJSON (builtins.readFile ./github.json); 9 | in fetch json -------------------------------------------------------------------------------- /deps/reflex-dom-contrib/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import (import ./thunk.nix) -------------------------------------------------------------------------------- /deps/reflex-dom-contrib/github.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "reflex-frp", 3 | "repo": "reflex-dom-contrib", 4 | "branch": "master", 5 | "private": false, 6 | "rev": "11db20865fd275362be9ea099ef88ded425789e7", 7 | "sha256": "1rmcqg97hr87blp1vl15rnvsxp836c2dh89lwpyb7lvh86d7jwaf" 8 | } 9 | -------------------------------------------------------------------------------- /deps/reflex-dom-contrib/thunk.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: 3 | if !fetchSubmodules && !private then builtins.fetchTarball { 4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; 5 | } else (import {}).fetchFromGitHub { 6 | inherit owner repo rev sha256 fetchSubmodules private; 7 | }; 8 | json = builtins.fromJSON (builtins.readFile ./github.json); 9 | in fetch json -------------------------------------------------------------------------------- /frontend.jsexe.assets: -------------------------------------------------------------------------------- 1 | result-exe/frontend.jsexe.assets -------------------------------------------------------------------------------- /frontend/frontend.cabal: -------------------------------------------------------------------------------- 1 | name: frontend 2 | version: 0.1 3 | cabal-version: >= 1.8 4 | build-type: Simple 5 | 6 | library 7 | hs-source-dirs: src 8 | build-depends: 9 | aeson 10 | , base 11 | , beam-core 12 | , bytestring 13 | , common 14 | , containers 15 | , data-default 16 | , dependent-sum 17 | , errors 18 | , ghcjs-dom 19 | , jsaddle 20 | , lens 21 | , lens-aeson 22 | , mtl 23 | , obelisk-executable-config-lookup 24 | , obelisk-frontend 25 | , obelisk-generated-static 26 | , obelisk-route 27 | , readable 28 | , ref-tf 29 | , reflex 30 | , reflex-dom 31 | , reflex-dom-contrib 32 | , scrub 33 | , semantic-reflex 34 | , text 35 | , time 36 | , transformers 37 | , universe 38 | , witherable 39 | exposed-modules: 40 | Frontend 41 | Frontend.App 42 | Frontend.AppState 43 | Frontend.Common 44 | Frontend.Nav 45 | Frontend.Widgets.Accounts 46 | Frontend.Widgets.Caches 47 | Frontend.Widgets.Common 48 | Frontend.Widgets.Jobs 49 | Frontend.Widgets.Form 50 | Frontend.Widgets.Repos 51 | Frontend.Widgets.Settings 52 | ghc-options: -Wall 53 | 54 | executable frontend 55 | main-is: main.hs 56 | hs-source-dirs: src-bin 57 | build-depends: base 58 | , common 59 | , obelisk-frontend 60 | , obelisk-route 61 | , reflex-dom 62 | , obelisk-generated-static 63 | , frontend 64 | --TODO: Make these ghc-options optional 65 | ghc-options: -threaded 66 | if os(darwin) 67 | ghc-options: -dynamic 68 | -------------------------------------------------------------------------------- /frontend/src-bin/main.hs: -------------------------------------------------------------------------------- 1 | import Frontend 2 | import Common.Route 3 | import Obelisk.Frontend 4 | import Obelisk.Route.Frontend 5 | import Reflex.Dom 6 | 7 | main :: IO () 8 | main = do 9 | let Right validFullEncoder = checkEncoder backendRouteEncoder 10 | run $ runFrontend validFullEncoder frontend 11 | -------------------------------------------------------------------------------- /frontend/src/Frontend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecursiveDo #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TupleSections #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | module Frontend where 15 | 16 | ------------------------------------------------------------------------------ 17 | import Control.Monad.Identity 18 | import Control.Monad.Reader 19 | import Control.Monad.Ref 20 | import Data.Maybe 21 | import Data.Text (Text) 22 | import Obelisk.Configs 23 | import Obelisk.Frontend 24 | import Obelisk.Generated.Static 25 | import Obelisk.Route 26 | import Obelisk.Route.Frontend 27 | import Reflex.Dom.Core 28 | import Reflex.Dom.Contrib.CssClass 29 | ------------------------------------------------------------------------------ 30 | import Common.Route 31 | import Frontend.App 32 | import Frontend.AppState 33 | import Frontend.Common 34 | import Frontend.Nav 35 | import Frontend.Widgets.Accounts 36 | import Frontend.Widgets.Caches 37 | import Frontend.Widgets.Jobs 38 | import Frontend.Widgets.Repos 39 | import Frontend.Widgets.Settings 40 | ------------------------------------------------------------------------------ 41 | 42 | 43 | frontend :: Frontend (R FrontendRoute) 44 | frontend = Frontend 45 | { _frontend_head = appHead 46 | , _frontend_body = do 47 | route <- getAppRoute 48 | runApp route appBody 49 | } 50 | 51 | 52 | appHead :: DomBuilder t m => m () 53 | appHead = do 54 | el "title" $ text "Zeus CI" 55 | elAttr "link" ("rel" =: "shortcut icon" <> 56 | "href" =: "/static/favicon.svg" <> 57 | "type" =: "image/svg+xml" 58 | ) blank 59 | 60 | css (static @"semantic.min.css") 61 | css (static @"css/custom.css") 62 | --jsScript "https://cdnjs.cloudflare.com/ajax/libs/jquery/2.2.3/jquery.min.js" 63 | jsScript (static @"jquery-3.1.1.min.js") 64 | jsScript (static @"semantic.min.js") 65 | 66 | css :: DomBuilder t m => Text -> m () 67 | css url = elAttr "link" ("rel" =: "stylesheet" <> "type" =: "text/css" <> "href" =: url) blank 68 | 69 | jsScript :: DomBuilder t m => Text -> m () 70 | jsScript url = elAttr "script" ("src" =: url <> "type" =: "text/javascript") blank 71 | 72 | script :: DomBuilder t m => Text -> m () 73 | script code = elAttr "script" ("type" =: "text/javascript") $ text code 74 | 75 | appBody 76 | :: forall js t m. (PostBuild t m, DomBuilder t m, MonadHold t m, MonadFix m, 77 | TriggerEvent t m, PerformEvent t m, MonadRef m, 78 | MonadSample t (Performable m), RouteToUrl (R FrontendRoute) m, 79 | SetRoute t (R FrontendRoute) m, Prerender js t m, HasConfigs m 80 | ) 81 | => App (R FrontendRoute) t m () 82 | appBody = do 83 | pb <- getPostBuild 84 | divClass "ui fixed menu" $ do 85 | elAttr "div" ("class" =: "inverted header item") $ text "Zeus CI" 86 | nav 87 | divClass "ui main container" $ do 88 | subRoute_ $ \case 89 | FR_Home -> setRoute ((FR_Jobs :/ Job_List :/ ()) <$ pb) 90 | FR_Jobs -> jobsWidget 91 | FR_Repos -> reposWidget 92 | FR_Accounts -> accountsWidget 93 | FR_Caches -> cachesWidget 94 | FR_Settings -> settingsWidget 95 | serverAlert <- asks _as_serverAlert 96 | modalExample serverAlert 97 | return () 98 | 99 | --wizard :: (MonadApp r t m, SetRoute t (R FrontendRoute) m) => m () 100 | --wizard = do 101 | -- repos <- asks _as_repos 102 | -- accounts <- asks _as_accounts 103 | -- pb <- getPostBuild 104 | -- let action = ffor ((,) <$> accounts <*> repos) $ \(as,rs) -> return $ 105 | -- if M.null as 106 | -- then setRoute $ (FR_Accounts :/ ()) <$ pb 107 | -- else if M.null rs 108 | -- then setRoute $ (FR_Repos :/ ()) <$ pb 109 | -- else setRoute $ (FR_Jobs :/ ()) <$ pb 110 | -- _ <- networkView action 111 | -- return () 112 | 113 | modal 114 | :: MonadApp r t m 115 | => Dynamic t Bool 116 | -> m a 117 | -> m a 118 | modal isActive m = do 119 | let dclass = addClassWhen (singleClass "active") isActive (manyClasses ["ui", "modal"]) 120 | elDynKlass "div" dclass m 121 | 122 | modalExample 123 | :: MonadApp r t m 124 | => Event t Text 125 | -> m () 126 | modalExample showEvent = mdo 127 | modalMsg <- holdDyn Nothing $ leftmost 128 | [ Just <$> showEvent 129 | , Nothing <$ ok 130 | ] 131 | ok <- modal (isJust <$> modalMsg) $ do 132 | elClass "i" "close icon" $ text " " 133 | divClass "header" $ text "Alert from Server" 134 | divClass "scrolling content" $ 135 | el "p" $ dynText (fromMaybe "" <$> modalMsg) 136 | divClass "actions" $ do 137 | (e,_) <- el' "button" $ text "OK" 138 | return $ domEvent Click e 139 | -- TODO Deal with this 140 | --SemUI.button def $ text "OK" 141 | return () 142 | -------------------------------------------------------------------------------- /frontend/src/Frontend/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | 8 | module Frontend.App where 9 | 10 | ------------------------------------------------------------------------------ 11 | import Control.Monad.Reader 12 | import Control.Monad.Ref 13 | import Data.Text (Text) 14 | import Reflex 15 | import Reflex.Dom 16 | import Obelisk.Route.Frontend 17 | ------------------------------------------------------------------------------ 18 | import Common.Route 19 | import Frontend.AppState 20 | ------------------------------------------------------------------------------ 21 | 22 | 23 | type MonadApp r t m = 24 | ( DomBuilder t m 25 | , PostBuild t m 26 | , MonadFix m 27 | , MonadHold t m 28 | , MonadSample t (Performable m) 29 | , MonadRef m 30 | , PerformEvent t m 31 | , TriggerEvent t m 32 | , MonadReader (AppState t) m 33 | , EventWriter t AppTriggers m 34 | , SetRoute t (R FrontendRoute) m 35 | , RouteToUrl (R FrontendRoute) m 36 | ) 37 | 38 | type MonadAppIO r t m = 39 | ( MonadApp r t m 40 | , MonadIO m 41 | , MonadIO (Performable m) 42 | ) 43 | 44 | type App r t m a = 45 | RoutedT t r (ReaderT (AppState t) (EventWriterT t AppTriggers m)) a 46 | 47 | runApp 48 | :: (DomBuilder t m, Routed t (R FrontendRoute) m, MonadHold t m, MonadFix m, Prerender js t m) 49 | => Text 50 | -> RoutedT t (R FrontendRoute) (ReaderT (AppState t) (EventWriterT t AppTriggers m)) a 51 | -> m a 52 | runApp publicUrl m = mdo 53 | r <- askRoute 54 | as <- stateManager publicUrl triggers 55 | (res, triggers) <- runEventWriterT (runReaderT (runRoutedT m r) as) 56 | return res 57 | -------------------------------------------------------------------------------- /frontend/src/Frontend/AppState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE RecursiveDo #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | module Frontend.AppState where 20 | 21 | ------------------------------------------------------------------------------ 22 | import Control.Error 23 | import Control.Lens 24 | import Control.Monad.Fix 25 | import Data.Map (Map) 26 | import qualified Data.Map as M 27 | import Data.Sequence (Seq) 28 | import qualified Data.Sequence as S 29 | import Data.Text (Text) 30 | import qualified Data.Text as T 31 | import qualified Data.Witherable as W 32 | import Database.Beam (Table, primaryKey) 33 | import GHC.Generics 34 | import Reflex 35 | import Reflex.Dom 36 | import Scrub 37 | ------------------------------------------------------------------------------ 38 | import Common.Api 39 | import Common.Types.BinaryCache 40 | import Common.Types.BuildJob 41 | import Common.Types.CiSettings 42 | import Common.Types.ConnectedAccount 43 | import Common.Types.Repo 44 | import Common.Types.ProcMsg 45 | import Frontend.Common () 46 | ------------------------------------------------------------------------------ 47 | 48 | data AppTriggers = AppTriggers 49 | { _trigger_getAccounts :: Batch () 50 | , _trigger_connectAccount :: Batch (ConnectedAccountT Maybe) 51 | , _trigger_delAccounts :: Batch ConnectedAccountId 52 | , _trigger_getRepos :: Batch () 53 | , _trigger_addRepo :: Batch (RepoT Maybe) 54 | , _trigger_delRepos :: Batch RepoId 55 | , _trigger_getJobs :: Batch () 56 | , _trigger_cancelJobs :: Batch (PrimaryKey BuildJobT Identity) 57 | , _trigger_rerunJobs :: Batch (PrimaryKey BuildJobT Identity) 58 | , _trigger_subscribeOutput :: Batch BuildJobId 59 | , _trigger_getCiSettings :: Batch () 60 | , _trigger_updateCiSettings :: Batch CiSettings 61 | , _trigger_getCiInfo :: Batch () 62 | 63 | , _trigger_listCaches :: Batch () 64 | , _trigger_addCache :: Batch (BinaryCacheT Maybe) 65 | , _trigger_delCaches :: Batch BinaryCacheId 66 | } deriving Generic 67 | 68 | instance Semigroup AppTriggers where 69 | (AppTriggers ga1 ca1 da1 gr1 ar1 dr1 gj1 cj1 rj1 so1 gs1 us1 gi1 lc1 ac1 dc1) 70 | <> (AppTriggers ga2 ca2 da2 gr2 ar2 dr2 gj2 cj2 rj2 so2 gs2 us2 gi2 lc2 ac2 dc2) = AppTriggers 71 | (ga1 <> ga2) 72 | (ca1 <> ca2) 73 | (da1 <> da2) 74 | (gr1 <> gr2) 75 | (ar1 <> ar2) 76 | (dr1 <> dr2) 77 | (gj1 <> gj2) 78 | (cj1 <> cj2) 79 | (rj1 <> rj2) 80 | (so1 <> so2) 81 | (gs1 <> gs2) 82 | (us1 <> us2) 83 | (gi1 <> gi2) 84 | (lc1 <> lc2) 85 | (ac1 <> ac2) 86 | (dc1 <> dc2) 87 | 88 | instance Monoid AppTriggers where 89 | mempty = AppTriggers 90 | mempty 91 | mempty 92 | mempty 93 | mempty 94 | mempty 95 | mempty 96 | mempty 97 | mempty 98 | mempty 99 | mempty 100 | mempty 101 | mempty 102 | mempty 103 | mempty 104 | mempty 105 | mempty 106 | mappend = (<>) 107 | 108 | makeLenses ''AppTriggers 109 | 110 | trigger 111 | :: (Reflex t, EventWriter t AppTriggers m) 112 | => Lens' AppTriggers (Batch a) 113 | -> Event t a 114 | -> m () 115 | trigger l e = triggerBatch l $ batchOne <$> e 116 | 117 | triggerBatch 118 | :: (Reflex t, EventWriter t AppTriggers m) 119 | => Lens' AppTriggers (Batch a) 120 | -> Event t (Batch a) 121 | -> m () 122 | triggerBatch l e = tellEvent $ (\as -> set l as mempty) <$> e 123 | 124 | type BeamMap f a = Map (PrimaryKey a f) (a f) 125 | 126 | data AppState t = AppState 127 | { _as_accounts :: Dynamic t (BeamMap Identity ConnectedAccountT) 128 | , _as_jobs :: Dynamic t (BeamMap Identity BuildJobT) 129 | , _as_repos :: Dynamic t (BeamMap Identity RepoT) 130 | , _as_serverAlert :: Event t Text 131 | , _as_buildOutputs :: Dynamic t (Map BuildJobId (Seq ProcMsg)) 132 | , _as_ciSettings :: Dynamic t (Maybe CiSettings) 133 | , _as_ciInfo :: Dynamic t (Maybe Text) 134 | , _as_caches :: Dynamic t (BeamMap Identity BinaryCacheT) 135 | } deriving Generic 136 | 137 | squash 138 | :: (W.Filterable f, Foldable t) 139 | => (a1 -> t a2) 140 | -> f a1 141 | -> f (t a2) 142 | squash f = W.filter (not . null) . fmap f 143 | 144 | stateManager 145 | :: (DomBuilder t m, MonadHold t m, Prerender js t m, MonadFix m) 146 | => Text 147 | -> Event t AppTriggers 148 | -> m (AppState t) 149 | stateManager route ft = do 150 | let upEvent = mergeWith (++) $ map (fmap (:[])) 151 | [ Up_ListAccounts <$ fmapMaybe (listToMaybe . _trigger_getAccounts) ft 152 | , Up_ConnectAccount <$> squash _trigger_connectAccount ft 153 | , Up_DelAccounts <$> squash _trigger_delAccounts ft 154 | , Up_ListRepos <$ fmapMaybe (listToMaybe . _trigger_getRepos) ft 155 | , Up_AddRepo <$> squash _trigger_addRepo ft 156 | , Up_DelRepos <$> squash _trigger_delRepos ft 157 | , Up_GetJobs <$ fmapMaybe (listToMaybe . _trigger_getJobs) ft 158 | , Up_CancelJobs <$> squash _trigger_cancelJobs ft 159 | , Up_RerunJobs <$> squash _trigger_rerunJobs ft 160 | , Up_SubscribeJobOutput <$> squash _trigger_subscribeOutput ft 161 | , Up_GetCiSettings <$ fmapMaybe (listToMaybe . _trigger_getCiSettings) ft 162 | , Up_GetCiInfo <$ fmapMaybe (listToMaybe . _trigger_getCiInfo) ft 163 | , Up_UpdateCiSettings <$> fmapMaybe (listToMaybe . _trigger_updateCiSettings) ft 164 | 165 | , Up_ListCaches <$ fmapMaybe (listToMaybe . _trigger_listCaches) ft 166 | , Up_AddCache <$> squash _trigger_addCache ft 167 | , Up_DelCaches <$> squash _trigger_delCaches ft 168 | 169 | ] 170 | let cfg = WebSocketConfig upEvent never True [] 171 | ws <- startWebsocket route cfg 172 | let downEvent = _webSocket_recv ws 173 | accounts <- holdDyn mempty $ 174 | fmapMaybe (fmap listToBeamMap . preview _Down_ConnectedAccounts) downEvent 175 | jobs <- holdDyn mempty $ fmapMaybe (fmap listToBeamMap . preview _Down_Jobs) downEvent 176 | repos <- holdDyn mempty $ fmapMaybe (fmap listToBeamMap . preview _Down_Repos) downEvent 177 | let serverAlert = fmapMaybe (preview _Down_Alert) downEvent 178 | buildOutput <- foldDyn ($) mempty $ leftmost 179 | [ fmapMaybe (fmap startOutput . preview _Down_JobOutput) downEvent 180 | , fmapMaybe (fmap addToOutput . preview _Down_JobNewOutput) downEvent 181 | ] 182 | ciSettings <- holdDyn Nothing $ fmapMaybe id $ fmap (Just . getScrubbed) . preview _Down_CiSettings <$> downEvent 183 | ciInfo <- holdDyn Nothing $ ffilter isJust $ preview _Down_CiInfo <$> downEvent 184 | caches <- holdDyn mempty $ 185 | fmapMaybe (fmap listToBeamMap . preview _Down_Caches) downEvent 186 | 187 | return $ AppState accounts jobs repos serverAlert buildOutput ciSettings ciInfo caches 188 | 189 | startOutput :: (BuildJobId, Text) -> Map BuildJobId (Seq ProcMsg) -> Map BuildJobId (Seq ProcMsg) 190 | startOutput (jid, msgText) _ = M.singleton jid (parseMessages msgText) 191 | 192 | parseMessages :: Text -> Seq ProcMsg 193 | parseMessages t = S.fromList $ catMaybes $ map (hush . parseProcMsg) $ T.lines t 194 | 195 | addToOutput :: (BuildJobId, [ProcMsg]) -> Map BuildJobId (Seq ProcMsg) -> Map BuildJobId (Seq ProcMsg) 196 | addToOutput (jid, pms) = M.adjust (<> S.fromList pms) jid 197 | 198 | listToBeamMap :: (Table a, Ord (PrimaryKey a f)) => [a f] -> BeamMap f a 199 | listToBeamMap = M.fromList . map (\a -> (primaryKey a, a)) 200 | 201 | startWebsocket 202 | :: (DomBuilder t m, Prerender js t m) 203 | => Text 204 | -> WebSocketConfig t Up 205 | -> m (RawWebSocket t Down) 206 | startWebsocket siteRoute wsCfg = do 207 | res <- prerender (pure neverWebSocket) $ do 208 | let (scheme,rest) = T.breakOn "://" siteRoute 209 | wsScheme = case scheme of 210 | "http" -> "ws" 211 | "https" -> "wss" 212 | _ -> error $ "Invalid scheme: " ++ T.unpack scheme 213 | RawWebSocket r o e c <- jsonWebSocket (wsScheme <> rest <> "/ws") wsCfg 214 | return (RawWebSocket (fmapMaybe id r) o e c) 215 | let r = switch $ current $ _webSocket_recv <$> res 216 | let o = switch $ current $ _webSocket_open <$> res 217 | let e = switch $ current $ _webSocket_error <$> res 218 | let c = switch $ current $ _webSocket_close <$> res 219 | return $ RawWebSocket r o e c 220 | 221 | -- = RawWebSocket { _webSocket_recv :: Event t a 222 | -- , _webSocket_open :: Event t () 223 | -- , _webSocket_error :: Event t () -- eror event does not carry any data and is always 224 | -- -- followed by termination of the connection 225 | -- -- for details see the close event 226 | -- , _webSocket_close :: Event t ( Bool -- wasClean 227 | -- , Word -- code 228 | -- , Text -- reason 229 | -- ) 230 | -- } 231 | 232 | neverWebSocket :: Reflex t => RawWebSocket t a 233 | neverWebSocket = RawWebSocket never never never never 234 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Common.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | 9 | module Frontend.Common where 10 | 11 | ------------------------------------------------------------------------------ 12 | import Control.Lens hiding (element) 13 | import Data.Default 14 | import Data.Proxy 15 | import Data.Text (Text) 16 | import Obelisk.Route.Frontend 17 | import Reflex 18 | import Reflex.Dom 19 | import Reflex.Dom.Contrib.CssClass 20 | ------------------------------------------------------------------------------ 21 | 22 | 23 | instance Reflex t => Default (Event t a) where 24 | def = never 25 | 26 | infixr 8 <$$> 27 | (<$$>) :: (Functor f0, Functor f1) => (a -> b) -> f1 (f0 a) -> f1 (f0 b) 28 | (<$$>) = fmap . fmap 29 | 30 | data ListState = EmptyPlaceholder | AddForm | ListTable 31 | deriving (Eq,Ord,Show,Read) 32 | 33 | data TableAction t a = TableAction 34 | { tableAction_showAddForm :: Event t () 35 | , tableAction_showList :: Event t () 36 | } 37 | 38 | instance Reflex t => Default (TableAction t a) where 39 | def = TableAction def def 40 | 41 | addClassWhen :: Monad (Dynamic t) => CssClass -> Dynamic t Bool -> CssClass -> Dynamic t CssClass 42 | addClassWhen dynKlass dynBool staticKlass = do 43 | a <- dynBool 44 | return $ if a then dynKlass <> staticKlass else staticKlass 45 | 46 | --intLink :: DomBuilder t m => Text -> m a -> m a 47 | --intLink href m = 48 | -- elAttr "a" ("href" =: href) $ m 49 | 50 | extLink :: DomBuilder t m => Text -> m a -> m a 51 | extLink href m = 52 | elAttr "a" ("href" =: href <> "target" =: "_blank" <> "rel" =: "noopener") $ m 53 | 54 | ------------------------------------------------------------------------------ 55 | internalLink 56 | :: forall r t m a. 57 | (Monad m, DomSpace (DomBuilderSpace m), RouteToUrl r m, SetRoute t r m) 58 | => r 59 | -> (ElementConfig EventResult t (DomBuilderSpace m) -> 60 | m (Element EventResult (DomBuilderSpace m) t, a)) 61 | -- ^ Probably a call to Reflex.Dom.element 62 | -> m () 63 | internalLink r wrapper = do 64 | enc <- askRouteToUrl 65 | let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m)) 66 | & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault) 67 | & elementConfig_initialAttributes .~ "href" =: enc r 68 | (e, _) <- wrapper cfg 69 | setRoute $ r <$ domEvent Click e 70 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Nav.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecursiveDo #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | module Frontend.Nav (nav) where 9 | 10 | ------------------------------------------------------------------------------ 11 | import Control.Monad (forM_) 12 | import Data.Dependent.Sum (DSum ((:=>))) 13 | import qualified Data.Some as Some 14 | --import Data.Universe (universe) 15 | import Obelisk.Route 16 | import Obelisk.Route.Frontend 17 | import Reflex.Dom 18 | ------------------------------------------------------------------------------ 19 | import Common.Route 20 | import Frontend.App 21 | import Frontend.Common 22 | ------------------------------------------------------------------------------ 23 | 24 | leftMenuItems :: [Some.Some FrontendRoute] 25 | leftMenuItems = 26 | [ Some.Some FR_Jobs 27 | , Some.Some FR_Repos 28 | , Some.Some FR_Accounts 29 | , Some.Some FR_Caches 30 | ] 31 | 32 | nav 33 | :: forall t m. (MonadApp (R FrontendRoute) t m, Routed t (R FrontendRoute) m) 34 | => m () 35 | nav = do 36 | -- Get the current route, so that we can highlight the corresponding tab 37 | currentTab <- askRoute 38 | 39 | -- Iterate over all the top-level routes except Home 40 | -- Home is reached by clicking logo 41 | forM_ leftMenuItems $ menuItem currentTab 42 | 43 | divClass "right menu" $ do 44 | menuItem currentTab (Some.Some FR_Settings) 45 | -- _ <- elClass "span" "clickable item" $ element "a" def (text "Logout") 46 | return () 47 | 48 | 49 | -- Create a link that is highlighted if it is the current tab 50 | menuItem 51 | :: (DomBuilder t m, RouteToUrl (R FrontendRoute) m, 52 | SetRoute t (R FrontendRoute) m, PostBuild t m) 53 | => Dynamic t (DSum FrontendRoute f) 54 | -> Some.Some FrontendRoute 55 | -> m () 56 | menuItem currentTab tab = do 57 | let currentTabDemux = demux $ fmap (\(t :=> _) -> Some.Some t) currentTab 58 | let thisTabIsSelected = demuxed currentTabDemux tab 59 | highlightAttrs = ffor thisTabIsSelected $ \case 60 | True -> "class" =: "active clickable item" 61 | False -> "class" =: "clickable item" 62 | internalLink (tabHomepage tab) $ \cfg -> 63 | elDynAttr' "span" highlightAttrs $ element "a" cfg (tabTitle tab) 64 | return () 65 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Accounts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | 13 | module Frontend.Widgets.Accounts where 14 | 15 | ------------------------------------------------------------------------------ 16 | import Control.Monad 17 | import Control.Monad.Reader 18 | import qualified Data.Map as M 19 | import Data.Maybe 20 | import Database.Beam 21 | import Obelisk.Route 22 | import Obelisk.Route.Frontend 23 | import Reflex.Dom.Core 24 | import Reflex.Dom.SemanticUI 25 | ------------------------------------------------------------------------------ 26 | import Common.Route 27 | import Common.Types.ConnectedAccount 28 | import Frontend.App 29 | import Frontend.AppState 30 | import Frontend.Common 31 | import Frontend.Widgets.Common 32 | import Frontend.Widgets.Form 33 | ------------------------------------------------------------------------------ 34 | 35 | accountsWidget 36 | :: (MonadApp r t m, Prerender js t m) 37 | => RoutedT t (R CrudRoute) m () 38 | accountsWidget = mdo 39 | pb <- getPostBuild 40 | trigger trigger_getAccounts pb 41 | as <- ask 42 | subRoute_ $ \case 43 | Crud_List -> accountsList (_as_accounts as) 44 | Crud_Create -> addAccount 45 | return () 46 | 47 | addAccount 48 | :: (MonadApp r t m, Prerender js t m) 49 | => m () 50 | addAccount = do 51 | semuiForm $ do 52 | da <- newAccountForm Nothing never 53 | divClass "field" $ do 54 | (e1,_) <- elAttr' "button" ("class" =: "ui button") $ text "Connect Account" 55 | (e2,_) <- elAttr' "button" ("class" =: "ui button") $ text "Cancel" 56 | trigger trigger_connectAccount $ fmapMaybe id $ tag (current da) (domEvent Click e1) 57 | setRoute $ (FR_Accounts :/ Crud_List :/ ()) <$ leftmost 58 | [domEvent Click e1, domEvent Click e2] 59 | return () 60 | 61 | accountsList 62 | :: MonadApp r t m 63 | => Dynamic t (BeamMap Identity ConnectedAccountT) 64 | -> m () 65 | accountsList as = do 66 | let mkField f _ v = el "td" $ dynText (f <$> v) >> return never 67 | widget accountMap = 68 | if M.null accountMap 69 | then accountPlaceholder 70 | else do 71 | (e,_) <- elAttr' "button" ("class" =: "ui button") $ text "Add Account" 72 | setRoute $ (FR_Accounts :/ Crud_Create :/ ()) <$ domEvent Click e 73 | del <- genericTableG def (constDyn accountMap) 74 | [ ("ID", mkField $ tshow . _connectedAccount_id) 75 | , ("Name", mkField $ _connectedAccount_name) 76 | , ("Provider", mkField $ tshow . _connectedAccount_provider) 77 | , ("", (\k _ -> deleteColumn trigger_delAccounts k)) 78 | ] 79 | triggerBatch trigger_delAccounts $ M.keys <$> del 80 | _ <- dyn (widget <$> as) 81 | return () 82 | 83 | accountPlaceholder :: MonadApp r t m => m () 84 | accountPlaceholder = mdo 85 | divClass "ui placeholder segment" $ do 86 | divClass "ui icon header" $ do 87 | elClass "i" "dont icon" blank 88 | text "You haven't connected any accounts yet" 89 | (e,_) <- elAttr' "div" ("class" =: "ui primary button") $ text "Connect Account" 90 | setRoute $ (FR_Accounts :/ Crud_Create :/ ()) <$ domEvent Click e 91 | 92 | newAccountForm 93 | :: (MonadApp r t m, Prerender js t m) 94 | => Maybe (ConnectedAccountT Maybe) 95 | -> Event t (Maybe (ConnectedAccountT Maybe)) 96 | -> m (Dynamic t (Maybe (ConnectedAccountT Maybe))) 97 | newAccountForm iv sv = do 98 | dn <- labelledAs "Name of the account that owns the repositories to test" $ 99 | textField 100 | (fromMaybe "" $ _connectedAccount_name =<< iv) 101 | (fromMaybe "" . (_connectedAccount_name =<<) <$> sv) 102 | dat <- labelledAs "Access Token" $ textField 103 | (fromMaybe "" $ _connectedAccount_accessToken =<< iv) 104 | (fromMaybe "" . (_connectedAccount_accessToken =<<) <$> sv) 105 | dp <- labelledAs "Provider" $ filledDropdown 106 | (fromMaybe GitHub $ _connectedAccount_provider =<< iv) 107 | (fmapMaybe id $ fmap join $ _connectedAccount_provider <$$> sv) 108 | return $ do 109 | n <- dn 110 | a <- dat 111 | p <- dp 112 | pure $ Just $ ConnectedAccount Nothing (Just n) (Just a) (Just p) 113 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Caches.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | 13 | module Frontend.Widgets.Caches where 14 | 15 | ------------------------------------------------------------------------------ 16 | import Control.Monad.Reader 17 | import qualified Data.Map as M 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | import Database.Beam 21 | import Obelisk.Route 22 | import Obelisk.Route.Frontend 23 | import Reflex.Dom.Core 24 | import Reflex.Dom.SemanticUI 25 | ------------------------------------------------------------------------------ 26 | import Common.Route 27 | import Common.Types.BinaryCache 28 | import Common.Types.S3Cache 29 | import Frontend.App 30 | import Frontend.AppState 31 | import Frontend.Widgets.Common 32 | import Frontend.Widgets.Form 33 | ------------------------------------------------------------------------------ 34 | 35 | cachesWidget 36 | :: (MonadApp r t m, Prerender js t m) 37 | => RoutedT t (R CrudRoute) m () 38 | cachesWidget = mdo 39 | pb <- getPostBuild 40 | trigger trigger_listCaches pb 41 | as <- ask 42 | subRoute_ $ \case 43 | Crud_List -> cacheList (_as_caches as) 44 | Crud_Create -> addCache 45 | return () 46 | 47 | addCache 48 | :: (MonadApp r t m, Prerender js t m) 49 | => m () 50 | addCache = do 51 | semuiForm $ do 52 | dc <- newCacheForm (BinaryCache Nothing Nothing) never 53 | divClass "field" $ do 54 | (e1,_) <- elAttr' "button" ("class" =: "ui button") $ text "Connect Cache" 55 | (e2,_) <- elAttr' "button" ("class" =: "ui button") $ text "Cancel" 56 | trigger trigger_addCache $ tag (current dc) (domEvent Click e1) 57 | setRoute $ (FR_Caches :/ Crud_List :/ ()) <$ leftmost 58 | [domEvent Click e1, domEvent Click e2] 59 | return () 60 | 61 | cacheList 62 | :: MonadApp r t m 63 | => Dynamic t (BeamMap Identity BinaryCacheT) 64 | -> m () 65 | cacheList as = do 66 | let mkField f _ v = el "td" $ dynText (f <$> v) >> return never 67 | widget accountMap = 68 | if M.null accountMap 69 | then accountPlaceholder 70 | else do 71 | (e,_) <- elAttr' "button" ("class" =: "ui button") $ text "Add Account" 72 | setRoute $ (FR_Caches :/ Crud_Create :/ ()) <$ domEvent Click e 73 | del <- genericTableG def (constDyn accountMap) 74 | [ ("ID", mkField $ tshow . _binaryCache_id) 75 | , ("Bucket", mkField $ _s3Cache_bucket . _binaryCache_s3Cache) 76 | , ("Region", mkField $ regionText . _s3Cache_region . _binaryCache_s3Cache) 77 | , ("", (\k _ -> deleteColumn trigger_delCaches k)) 78 | ] 79 | triggerBatch trigger_delCaches $ M.keys <$> del 80 | _ <- dyn (widget <$> as) 81 | return () 82 | 83 | accountPlaceholder :: MonadApp r t m => m () 84 | accountPlaceholder = mdo 85 | divClass "ui placeholder segment" $ do 86 | divClass "ui icon header" $ do 87 | elClass "i" "dont icon" blank 88 | text "You haven't set up any S3 caches yet" 89 | (e,_) <- elAttr' "div" ("class" =: "ui primary button") $ text "Set Up Cache" 90 | setRoute $ (FR_Caches :/ Crud_Create :/ ()) <$ domEvent Click e 91 | 92 | newCacheForm 93 | :: (MonadApp r t m, Prerender js t m) 94 | => BinaryCacheT Maybe 95 | -> Event t (BinaryCacheT Maybe) 96 | -> m (Dynamic t (BinaryCacheT Maybe)) 97 | newCacheForm iv sv = do 98 | dc <- s3CacheWidget (_binaryCache_s3Cache iv) (_binaryCache_s3Cache <$> sv) 99 | return $ do 100 | c <- dc 101 | pure $ BinaryCache Nothing c 102 | 103 | s3CacheWidget 104 | :: (MonadApp r t m, Prerender js t m) 105 | => Maybe S3Cache 106 | -> Event t (Maybe S3Cache) 107 | -> m (Dynamic t (Maybe S3Cache)) 108 | s3CacheWidget iv sv = divClass "ui segment" $ do 109 | db :: Dynamic t Text <- divClass "field" $ do 110 | el "label" $ text "Bucket" 111 | v <- inputElement $ def 112 | & inputElementConfig_initialValue .~ maybe "" _s3Cache_bucket iv 113 | & inputElementConfig_setValue .~ (maybe "" _s3Cache_bucket <$> sv) 114 | return $ value v 115 | dr <- divClass "field" $ do 116 | el "label" $ text "Region" 117 | filledDropdown (maybe NorthVirginia _s3Cache_region iv) 118 | (maybe NorthVirginia _s3Cache_region <$> sv) 119 | dak <- divClass "field" $ do 120 | el "label" $ text "Access Key" 121 | v <- inputElement $ def 122 | & inputElementConfig_initialValue .~ maybe "" _s3Cache_accessKey iv 123 | & inputElementConfig_setValue .~ (maybe "" _s3Cache_accessKey <$> sv) 124 | return $ value v 125 | dsk <- divClass "field" $ do 126 | el "label" $ do 127 | text "Secret Key " 128 | let tip = "Secret key not shown for security. Leaving it empty will not clear it." 129 | elAttr "span" ("data-tooltip" =: tip <> "data-position" =: "top left") $ 130 | elAttr "i" ("class" =: "info circle icon") blank 131 | 132 | v <- inputElement $ def 133 | & inputElementConfig_initialValue .~ maybe "" _s3Cache_secretKey iv 134 | & inputElementConfig_setValue .~ (maybe "" _s3Cache_secretKey <$> sv) 135 | return $ value v 136 | return $ do 137 | b <- db 138 | r <- dr 139 | ak <- dak 140 | sk <- dsk 141 | if any T.null [b, ak] 142 | then pure Nothing 143 | else pure $ Just $ S3Cache b r ak sk 144 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Frontend.Widgets.Common where 12 | 13 | ------------------------------------------------------------------------------ 14 | import Control.Lens 15 | import Control.Monad 16 | import Control.Monad.Fix 17 | import Data.Default 18 | import Data.Map (Map) 19 | import Data.Text (Text) 20 | import qualified Data.Text as T 21 | import qualified GHCJS.DOM.Types as DOM 22 | import Language.Javascript.JSaddle (MonadJSM, liftJSM, JSVal) 23 | import qualified Language.Javascript.JSaddle as JS 24 | import Reflex 25 | import Reflex.Dom 26 | ------------------------------------------------------------------------------ 27 | import Common.Api 28 | import Frontend.App 29 | import Frontend.AppState 30 | import Humanizable 31 | ------------------------------------------------------------------------------ 32 | 33 | humanColumn :: (DomBuilder t m, PostBuild t m, Humanizable b) => (a -> b) -> Dynamic t a -> m () 34 | humanColumn f = dynText . fmap (humanize . f) 35 | textColumn :: (DomBuilder t m, PostBuild t m) => (a -> Text) -> Dynamic t a -> m () 36 | textColumn f = dynText . fmap f 37 | 38 | promptListViewWithKey 39 | :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) 40 | => Dynamic t (Map k v) 41 | -> (k -> Dynamic t v -> m (Event t a)) 42 | -> m (Event t (Map k a)) 43 | promptListViewWithKey vals mkChild = 44 | switchPromptlyDyn . fmap mergeMap <$> listWithKey vals mkChild 45 | 46 | genericTable 47 | :: (DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m, Ord k) 48 | => Dynamic t (Map k v) 49 | -> [(Text, k -> Dynamic t v -> m (Event t b))] 50 | -> m (Event t (Map k b)) 51 | genericTable rows cols = do 52 | elClass "table" "ui celled table" $ do 53 | el "thead" $ el "tr" $ do 54 | mapM_ (el "th" . text . fst) cols 55 | let doRow k v = el "tr" $ do 56 | es <- mapM (\(_,field) -> field k v) cols 57 | return $ leftmost es 58 | el "tbody" $ promptListViewWithKey rows doRow 59 | 60 | genericTableG 61 | :: (DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m, Ord k) 62 | => TableConfig k v t m a 63 | -> Dynamic t (Map k v) 64 | -> [(Text, k -> Dynamic t v -> m (Event t a))] 65 | -> m (Event t (Map k a)) 66 | genericTableG cfg rows cols = do 67 | _tableConfig_tableWrapper cfg $ do 68 | _tableConfig_headWrapper cfg $ do 69 | mapM_ (_tableConfig_headRowWrapper cfg) cols 70 | let doRow k v = _tableConfig_rowFunc cfg k v $ do 71 | es <- mapM (_tableConfig_cellFunc cfg k v) cols 72 | return $ leftmost es 73 | _tableConfig_bodyWrapper cfg $ 74 | promptListViewWithKey rows doRow 75 | 76 | data TableConfig k v t m a = TableConfig 77 | { _tableConfig_tableWrapper :: m (Event t (Map k a)) -> m (Event t (Map k a)) 78 | , _tableConfig_headWrapper :: m () -> m () 79 | , _tableConfig_headRowWrapper :: (Text, (k -> Dynamic t v -> m (Event t a))) -> m () 80 | , _tableConfig_bodyWrapper :: m (Event t (Map k a)) -> m (Event t (Map k a)) 81 | , _tableConfig_rowFunc :: k -> Dynamic t v -> m (Event t a) -> m (Event t a) 82 | , _tableConfig_cellFunc :: k -> Dynamic t v -> (Text, (k -> Dynamic t v -> m (Event t a))) -> m (Event t a) 83 | } 84 | 85 | instance DomBuilder t m => Default (TableConfig k v t m a) where 86 | def = TableConfig 87 | { _tableConfig_tableWrapper = elClass "table" "ui celled table" 88 | , _tableConfig_headWrapper = el "thead" . el "tr" 89 | , _tableConfig_headRowWrapper = el "th" . text . fst 90 | , _tableConfig_bodyWrapper = el "tbody" 91 | , _tableConfig_rowFunc = (\_ _ -> el "tr") 92 | , _tableConfig_cellFunc = (\k v (_,f) -> f k v) 93 | } 94 | 95 | deleteButton :: DomBuilder t m => m (Event t ()) 96 | deleteButton = do 97 | (e,_) <- elAttr' "i" ("class" =: "trash icon") blank 98 | return $ domEvent Click e 99 | 100 | deleteColumn 101 | :: MonadApp r t m 102 | => Lens' AppTriggers (Batch a) 103 | -> a 104 | -> m (Event t ()) 105 | deleteColumn trig k = do 106 | (e,_) <- elAttr' "td" ("class" =: "clickable right aligned collapsing") $ 107 | elAttr "i" ("class" =: "trash icon") blank 108 | triggerBatch trig ([k] <$ domEvent Click e) 109 | return never 110 | 111 | genericRemovableTable 112 | :: (DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m, Ord k) 113 | => Dynamic t (Map k v) 114 | -> [(Text, k -> Dynamic t v -> m ())] 115 | -> m (Event t (Map k ())) 116 | genericRemovableTable rows cols = do 117 | elClass "table" "ui celled table" $ do 118 | el "thead" $ el "tr" $ do 119 | mapM_ (el "th" . text . fst) cols 120 | el "th" blank 121 | let doRow k v = el "tr" $ do 122 | mapM_ (\(_,field) -> field k v) cols 123 | del <- elClass "td" "right aligned collapsing" deleteButton 124 | return $ traceEvent "row click" del 125 | el "tbody" $ --networkView $ mapM doRow <$> rows 126 | listViewWithKey rows doRow 127 | 128 | --genericDynTable 129 | -- :: DomBuilder t m 130 | -- => Dynamic t [a] 131 | -- -> [(Text, Dynamic t a -> m b)] 132 | -- -> m b 133 | --genericDynTable rows cols = do 134 | -- elClass "table" "ui celled table" $ do 135 | -- el "thead" $ el "tr" $ do 136 | -- mapM_ (el "th" . text . fst) cols 137 | -- el "tbody" $ simpleList rows $ \pair -> 138 | -- el "tr" $ mapM (\(_,field) -> el "td" $ field pair) cols 139 | 140 | genericPlaceholder :: DomBuilder t m => Text -> m () 141 | genericPlaceholder placeholderText = do 142 | divClass "ui placeholder segment" $ do 143 | divClass "ui icon header" $ do 144 | elClass "i" "dont icon" blank 145 | text placeholderText 146 | 147 | genericLoading :: DomBuilder t m => m () 148 | genericLoading = do 149 | elAttr "div" ("class" =: "ui segment" <> "style" =: "height: 100px") $ 150 | divClass "ui active dimmer" $ do 151 | divClass "ui text loader" $ 152 | text "Loading" 153 | 154 | -- | Copies the text content of a given node to the clipboard. 155 | copyButton 156 | :: forall t m 157 | . ( MonadJSM (Performable m), PerformEvent t m 158 | , RawElement (DomBuilderSpace m) ~ DOM.Element 159 | , DomBuilder t m 160 | ) 161 | => RawElement (DomBuilderSpace m) 162 | -> m (Event t ()) 163 | copyButton e = do 164 | onClick <- fmap (domEvent Click . fst) $ elAttr' "span" ("class" =: "clickable") $ 165 | elClass "button" "mini ui basic button" $ text "Copy" 166 | --elClass "i" "copy icon" blank 167 | performEvent_ $ jsCopy e <$ onClick 168 | pure onClick 169 | where 170 | 171 | jsCopy :: forall m1. MonadJSM m1 => RawElement (DomBuilderSpace m) -> m1 () 172 | jsCopy eL = do 173 | jsCopyFunc <- jsCopyVal 174 | void $ liftJSM $ JS.call jsCopyFunc JS.obj [DOM.unElement eL] 175 | 176 | jsCopyVal :: forall m1. MonadJSM m1 => m1 JSVal 177 | jsCopyVal = liftJSM $ JS.eval $ T.unlines 178 | [ "(function(e) {" 179 | , " try {" 180 | , " var range = document.createRange();" 181 | , " range.selectNodeContents(e);" 182 | , " var selection = window.getSelection();" 183 | , " selection.removeAllRanges();" 184 | , " selection.addRange(range);" 185 | , " document.execCommand('copy');" 186 | , " } catch(e) { console.log('Copy failed!'); return false; }" 187 | , "})" 188 | ] 189 | 190 | accordionItem 191 | :: (DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) 192 | => m () -> m () -> m () 193 | accordionItem title content = do 194 | (e,_) <- elAttr' "div" ("class" =: "title") $ do 195 | elClass "i" "dropdown icon" blank 196 | title 197 | expanded <- toggle False $ domEvent Click e 198 | let mkAttrs = \case 199 | False -> ("class" =: "content") 200 | True -> ("class" =: "active content") 201 | _ <- elDynAttr "div" (mkAttrs <$> expanded) content 202 | divClass "content" content 203 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Form.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Frontend.Widgets.Form where 9 | 10 | ------------------------------------------------------------------------------ 11 | import Control.Lens 12 | import Control.Monad 13 | import Data.Readable 14 | import qualified Data.Map as M 15 | import Data.Text (Text) 16 | import Reflex.Active 17 | import Reflex.Dom 18 | import Reflex.Dom.Contrib.Utils 19 | import qualified Reflex.Dom.SemanticUI as SemUI 20 | ------------------------------------------------------------------------------ 21 | import Humanizable 22 | ------------------------------------------------------------------------------ 23 | 24 | semuiForm :: DomBuilder t m => m a -> m a 25 | semuiForm = elClass "div" "ui form" 26 | 27 | class Formable t m a where 28 | --form :: DomBuilder t m => Maybe a -> Event t a -> m (Dynamic t (Maybe a)) 29 | --form :: DomBuilder t m => a -> Event t a -> m (Dynamic t a) 30 | aForm :: DomBuilder t m => a -> Event t a -> m (Dynamic t a) 31 | 32 | --instance Formable t m (Maybe AccountProvider) where 33 | -- aForm iv sv = do 34 | -- v <- SemUI.dropdown def iv sv $ TaggedStatic $ M.fromList $ 35 | -- map (\a -> (a, text $ tshow a)) [GitHub, GitLab] 36 | -- return $ value v 37 | 38 | instance (Ord a, Enum a, Bounded a, Humanizable a, Prerender js t m) => Formable t m (Maybe a) where 39 | aForm iv sv = do 40 | v <- prerender (pure $ pure $ Just minBound) $ fmap value $ SemUI.dropdown def iv sv $ TaggedStatic $ M.fromList $ 41 | map (\a -> (a, text $ humanize a)) [minBound..maxBound] 42 | return $ join v 43 | 44 | filledDropdown 45 | :: (Ord a, Enum a, Bounded a, Humanizable a, DomBuilder t m, Prerender js t m) 46 | => a 47 | -> Event t a 48 | -> m (Dynamic t a) 49 | filledDropdown iv sv = do 50 | v <- prerender (pure $ pure minBound) $ fmap (fmap runIdentity . value) $ SemUI.dropdown def (Identity iv) (Identity <$> sv) $ TaggedStatic $ M.fromList $ 51 | map (\a -> (a, text $ humanize a)) [minBound..maxBound] 52 | return $ join v 53 | 54 | --filledDropdown2 55 | -- :: (Ord a, Enum a, Bounded a, Humanizable a, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) 56 | -- => a 57 | -- -> Event t a 58 | -- -> m (Dynamic t a) 59 | --filledDropdown2 iv sv = do 60 | -- let pairs = M.fromList $ map (\a -> (a, humanize a)) [minBound..maxBound] 61 | -- v <- dropdown minBound (constDyn pairs) def 62 | -- return $ value v 63 | 64 | 65 | -- newtype Form t m a = Form { unForm :: Event t a -> m (Dynamic t a) } 66 | -- 67 | -- instance (Functor (Form t m), Applicative m, Reflex t) => Applicative (Form t m) where 68 | -- --pure :: a -> Form t m a 69 | -- pure a = Form $ \_ -> pure (constDyn a) 70 | -- -- (<*>) :: f (a -> b) -> f a -> f b 71 | -- Form f <$> Form a = Form $ \svb -> 72 | 73 | zoom 74 | :: (DomBuilder t m, Formable t m b) 75 | => Lens' a b 76 | -> a 77 | -> Event t a 78 | -> m (Dynamic t b) 79 | zoom theLens iv sv = aForm (view theLens iv) (view theLens <$> sv) 80 | 81 | labelledAs :: DomBuilder t m => Text -> m a -> m a 82 | labelledAs label m = divClass "field" $ do 83 | el "label" $ text label 84 | m 85 | 86 | fieldLabel :: MonadWidget t m => m a -> m a 87 | fieldLabel m = divClass "field" $ el "label" m 88 | 89 | textareaField 90 | :: (DomBuilder t m) 91 | => Text 92 | -> Event t Text 93 | -> m (Dynamic t Text) 94 | textareaField iv sv = do 95 | t <- textAreaElement $ def 96 | & textAreaElementConfig_initialValue .~ iv 97 | & textAreaElementConfig_setValue .~ sv 98 | return $ value t 99 | 100 | textField 101 | :: (DomBuilder t m) 102 | => Text 103 | -> Event t Text 104 | -> m (Dynamic t Text) 105 | textField iv sv = do 106 | t <- inputElement $ def 107 | & inputElementConfig_initialValue .~ iv 108 | & inputElementConfig_setValue .~ sv 109 | return $ value t 110 | 111 | readableField 112 | :: (DomBuilder t m, 113 | Readable a, 114 | Show a) 115 | => Maybe Text 116 | -> Maybe a 117 | -> Event t (Maybe a) 118 | -> m (Dynamic t (Maybe a)) 119 | readableField mlabel iv sv = divClass "field" $ do 120 | maybe blank (el "label" . text) mlabel 121 | let sv2 = maybe "" tshow <$> sv 122 | iv2 = maybe "" tshow iv 123 | t <- inputElement $ def 124 | & inputElementConfig_initialValue .~ iv2 125 | & inputElementConfig_setValue .~ sv2 126 | return $ fromText <$> value t 127 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Jobs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | 13 | module Frontend.Widgets.Jobs where 14 | 15 | ------------------------------------------------------------------------------ 16 | import Control.Lens 17 | import Control.Monad 18 | import Control.Monad.Reader 19 | import Data.Foldable 20 | import Data.Int 21 | import Data.Ord 22 | import qualified Data.Map as M 23 | import Data.Text (Text) 24 | import qualified Data.Text as T 25 | import Data.Time 26 | import Obelisk.Route 27 | import Obelisk.Route.Frontend 28 | import Reflex 29 | import Reflex.Network 30 | import Reflex.Dom.Core 31 | import Reflex.Dom.SemanticUI 32 | import qualified Reflex.Dom.SemanticUI as SemUI 33 | import Text.Printf 34 | ------------------------------------------------------------------------------ 35 | import Common.Route 36 | import Common.Types.BuildJob 37 | import Common.Types.JobStatus 38 | import Common.Types.ProcMsg 39 | import Common.Types.RepoBuildInfo 40 | import Frontend.App 41 | import Frontend.AppState 42 | import Frontend.Widgets.Common 43 | ------------------------------------------------------------------------------ 44 | 45 | jobsWidget 46 | :: (MonadApp (R JobRoute) t m, Prerender js t m) 47 | => RoutedT t (R JobRoute) m () 48 | jobsWidget = mdo 49 | as <- ask 50 | 51 | subRoute_ $ \case 52 | Job_List -> do 53 | let jobMap = _as_jobs as 54 | let widget m = if M.null m 55 | then genericPlaceholder "Job history empty" 56 | else jobsList jobMap 57 | _ <- dyn (widget <$> jobMap) 58 | return () 59 | Job_Output -> jobOutput 60 | 61 | jobOutput 62 | :: MonadApp Int32 t m 63 | => RoutedT t Int32 m () 64 | jobOutput = do 65 | jobId <- askRoute 66 | _ <- networkView (outputWidget <$> jobId) 67 | return () 68 | 69 | outputWidget :: MonadApp r t m => Int32 -> m () 70 | outputWidget jobId = do 71 | let bjid = BuildJobId jobId 72 | elClass "table" "ui inverted table build-output" $ do 73 | dos <- asks _as_buildOutputs 74 | _ <- simpleList (fmap (zip [1 :: Int ..] . maybe [] toList . M.lookup bjid) dos) $ \v -> do 75 | let mkTheId n = "L" <> tshow n 76 | msgClass BuildCommandMsg = "cmd-msg output-line" 77 | msgClass _ = "output-line" 78 | mkDivAttrs (n,pm) = 79 | "class" =: msgClass (_procMsg_source pm) <> 80 | "id" =: mkTheId n 81 | -- TODO Line jumping currently doesn't jump to the right place. 82 | -- This approach was working: https://css-tricks.com/hash-tag-links-padding/ 83 | -- but it stopped working after the switch to a table 84 | elDynAttr "tr" (mkDivAttrs <$> v) $ do 85 | let mkAttrs (n,_) = 86 | "href" =: ("#" <> mkTheId n) 87 | elClass "td" "linenum" $ 88 | elDynAttr "a" (mkAttrs <$> v)blank 89 | elAttr "td" ("class" =: "output") $ 90 | dynText $ showProcMsgLine . snd <$> v 91 | return () 92 | return () 93 | 94 | showProcMsgLine :: ProcMsg -> Text 95 | showProcMsgLine (ProcMsg _ s m) = 96 | case s of 97 | BuildCommandMsg -> "$ " <> m 98 | _ -> m 99 | 100 | jobDuration :: BuildJob -> Maybe NominalDiffTime 101 | jobDuration bj = do 102 | start <- _buildJob_startedAt bj 103 | end <- _buildJob_endedAt bj 104 | pure $ diffUTCTime end start 105 | 106 | jobsList 107 | :: (MonadApp r t m, Prerender js t m) 108 | => Dynamic t (BeamMap Identity BuildJobT) 109 | -> m () 110 | jobsList as = do 111 | let mkField f _ v = el "td" $ do 112 | _ <- f v 113 | return never 114 | _ <- genericTableG def (M.mapKeys Down <$> as) 115 | [ ("Status", (\_ v -> el "td" $ dynStatusWidget v)) 116 | , ("ID", mkField $ dynText . fmap (tshow . _buildJob_id)) 117 | , ("Repository", \_ v -> el "td" (repoColumnWidget v) >> return never) 118 | , ("Git Ref", mkField $ dynText . fmap (_rbi_gitRef . _buildJob_repoBuildInfo)) 119 | , ("Commit Hash", \_ v -> el "td" (commitWidget v) >> return never) 120 | , ("Author", \_ v -> el "td" (authorWidget v) >> return never) 121 | , ("Time", mkField timeWidget) 122 | , ("", (\(Down k) v -> elClass "td" "right aligned collapsing" $ 123 | cancelOrRerun k (_buildJob_status <$> v))) 124 | ] 125 | return () 126 | 127 | timeWidget 128 | :: (MonadApp r t m, Prerender js t m) 129 | => Dynamic t BuildJob 130 | -> m (Event t ()) 131 | timeWidget dj = do 132 | void $ dynJobTimeWidget dj 133 | return never 134 | 135 | cancelOrRerun :: MonadApp r t m => BuildJobId -> Dynamic t JobStatus -> m (Event t ()) 136 | cancelOrRerun k dj = do 137 | _ <- networkView $ ffor dj $ \case 138 | JobPending -> cancelButton k 139 | JobInProgress -> cancelButton k 140 | JobCanceled -> rerunButton k 141 | JobTimedOut -> rerunButton k 142 | JobVanished -> rerunButton k 143 | JobFailed -> rerunButton k 144 | JobSucceeded -> return () 145 | return never 146 | 147 | cancelButton :: MonadApp r t m => BuildJobId -> m () 148 | cancelButton k = do 149 | (e,_) <- elAttr' "span" ("class" =: "clickable" <> 150 | "data-tooltip" =: "Cancel build" <> 151 | "data-position" =: "bottom right" 152 | ) $ 153 | elAttr' "i" ("class" =: "cancel icon") blank 154 | triggerBatch trigger_cancelJobs $ [k] <$ domEvent Click e 155 | return () 156 | 157 | rerunButton :: MonadApp r t m => BuildJobId -> m () 158 | rerunButton k = do 159 | (e,_) <- elAttr' "span" ("class" =: "clickable" <> 160 | "data-tooltip" =: "Re-run build" <> 161 | "data-position" =: "bottom right" 162 | ) $ 163 | elAttr' "i" ("class" =: "redo icon") blank 164 | triggerBatch trigger_rerunJobs $ [k] <$ domEvent Click e 165 | return () 166 | 167 | repoColumnWidget 168 | :: (DomBuilder t m, PostBuild t m) 169 | => Dynamic t BuildJob 170 | -> m () 171 | repoColumnWidget dj = do 172 | let drbi = _buildJob_repoBuildInfo <$> dj 173 | let mkAttrs rbi = ("href" =: rbiRepoLink rbi <> "target" =: "_blank") 174 | elDynAttr "a" (mkAttrs <$> drbi) $ dynText (rbiRepoFullName <$> drbi) 175 | 176 | authorWidget 177 | :: (DomBuilder t m, PostBuild t m) 178 | => Dynamic t BuildJob 179 | -> m () 180 | authorWidget dj = do 181 | _ <- networkView $ mkAvatar . _rbi_pushAvatar . _buildJob_repoBuildInfo <$> dj 182 | text " " 183 | dynText $ _rbi_pushUser . _buildJob_repoBuildInfo <$> dj 184 | where 185 | mkAvatar Nothing = blank 186 | mkAvatar (Just url) = elAttr "img" ("src" =: url <> "class" =: "avatar") blank 187 | 188 | commitWidget 189 | :: (DomBuilder t m, PostBuild t m) 190 | => Dynamic t BuildJob 191 | -> m () 192 | commitWidget dj = do 193 | let drbi = _buildJob_repoBuildInfo <$> dj 194 | let mkAttrs rbi = ("href" =: rbiCommitLink rbi <> "target" =: "_blank") 195 | elDynAttr "a" (mkAttrs <$> drbi) $ dynText (T.take 7 . _rbi_commitHash <$> drbi) 196 | 197 | dynJobTimeWidget 198 | :: (DomBuilder t m, PostBuild t m, Prerender js t m) 199 | => Dynamic t BuildJob 200 | -> m () 201 | dynJobTimeWidget dj = do 202 | el "div" $ do 203 | let showElapsed ti j = 204 | case jobDuration j of 205 | Just d -> formatDiffTime d 206 | Nothing -> do 207 | if _buildJob_status j /= JobInProgress 208 | then "--:--" 209 | else 210 | maybe "--:--" formatDiffTime $ do 211 | s <- _buildJob_startedAt j 212 | return $ diffUTCTime (_tickInfo_lastUTC ti) s 213 | elClass "i" "clock icon" blank 214 | void $ prerender (el "div" $ text "--:--") $ do 215 | t <- liftIO getCurrentTime 216 | dti <- clockLossy 0.5 t 217 | dynText $ showElapsed <$> dti <*> dj 218 | let mkAttrs j = ("data-tooltip" =: maybe "" tshow (view buildJob_startedAt j) <> 219 | "data-position" =: "bottom left") 220 | elDynAttr "div" (mkAttrs <$> dj) $ do 221 | elClass "i" "calendar icon" blank 222 | let f = maybe blank pastTimeWiget . view buildJob_startedAt 223 | void $ prerender blank $ void $ dyn $ f <$> dj 224 | 225 | formatDiffTime :: NominalDiffTime -> Text 226 | formatDiffTime t = T.pack $ 227 | if h > 0 228 | then printf "%d:%02d:%02d" h m (round s :: Int) 229 | else printf "%02d:%02d" m (round s :: Int) 230 | where 231 | h :: Int 232 | h = truncate $ t / oneHour 233 | justMin = t - fromIntegral h * oneHour 234 | m :: Int 235 | m = truncate $ justMin / oneMinute 236 | s :: NominalDiffTime 237 | s = justMin - fromIntegral m * oneMinute 238 | 239 | pastTimeWiget 240 | :: (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO m, MonadIO (Performable m)) 241 | => UTCTime 242 | -> m () 243 | pastTimeWiget t = do 244 | ti <- clockLossy 5 t 245 | let calcDiff lastTick = diffUTCTime (_tickInfo_lastUTC lastTick) t 246 | dynText $ diffTimeToRelativeEnglish . calcDiff <$> ti 247 | 248 | dynPastTimeWiget 249 | :: MonadAppIO r t m 250 | => Dynamic t UTCTime 251 | -> m () 252 | dynPastTimeWiget t = void $ dyn $ pastTimeWiget <$> t 253 | 254 | showInt :: Int -> Text 255 | showInt = tshow 256 | 257 | diffTimeToRelativeEnglish :: NominalDiffTime -> Text 258 | diffTimeToRelativeEnglish delta 259 | | delta < oneMinute = "Just now" 260 | | delta < oneMinute * 2 = "1 minute ago" 261 | | delta < oneHour = showInt (round $ delta / oneMinute) <> " minutes ago" 262 | | delta < oneHour * 2 = "an hour ago" 263 | | delta < oneDay = showInt (round $ delta / oneHour) <> " hours ago" 264 | | delta < oneDay * 2 = "1 day ago" 265 | | delta < oneWeek = showInt (round $ delta / oneDay) <> " days ago" 266 | | delta < oneWeek * 2 = "1 week ago" 267 | | delta < oneMonth = showInt (round $ delta / oneWeek) <> " weeks ago" 268 | | delta < oneMonth * 2 = "1 month ago" 269 | | delta < oneYear = showInt (round $ delta / oneMonth) <> " months ago" 270 | | delta < oneYear * 2 = "a year ago" 271 | | otherwise = showInt (round $ delta / oneYear) <> " years ago" 272 | 273 | oneMinute :: NominalDiffTime 274 | oneMinute = 60 275 | oneHour :: NominalDiffTime 276 | oneHour = oneMinute * 60 277 | oneDay :: NominalDiffTime 278 | oneDay = oneHour * 24 279 | oneWeek :: NominalDiffTime 280 | oneWeek = oneDay * 7 281 | oneMonth :: NominalDiffTime 282 | oneMonth = oneDay * 30 283 | oneYear :: NominalDiffTime 284 | oneYear = oneDay * 365 285 | 286 | --dynStatusWidget :: MonadAppIO r t m => Dynamic t BuildJob -> m (Event t ()) 287 | --dynStatusWidget job = do 288 | -- let status = _buildJob_status <$> job 289 | -- let cfg = def & buttonConfig_color .~ Dyn (Just . statusColor <$> status) 290 | -- & buttonConfig_basic .~ Static True 291 | -- & buttonConfig_elConfig . classes .~ Static (Classes ["jobstatus"]) 292 | -- click <- SemUI.button cfg $ do 293 | -- icon (Dyn $ statusIcon <$> status) def 294 | -- dynText $ statusMessage <$> status 295 | -- setRoute $ (FR_Jobs :/ Job_Output :/ 0) <$ click 296 | -- return never 297 | 298 | dynStatusWidget 299 | :: (MonadApp r t m, Prerender js t m) 300 | => Dynamic t BuildJob 301 | -> m (Event t ()) 302 | dynStatusWidget djob = networkView (statusWidget <$> djob) >> return never 303 | 304 | statusWidget :: (MonadApp r t m, Prerender js t m) => BuildJob -> m (Event t ()) 305 | statusWidget job = do 306 | _ <- elAttr "a" ("href" =: ("/raw/" <> tshow (_buildJob_id job) <> ".txt") <> 307 | "target" =: "_blank") $ do 308 | prerender blank $ void $ do 309 | let status = _buildJob_status job 310 | let cfg = def & buttonConfig_color .~ Static (Just $ statusColor status) 311 | & buttonConfig_basic .~ Static True 312 | & buttonConfig_elConfig . classes .~ Static (Classes ["jobstatus"]) 313 | SemUI.button cfg $ do 314 | elClass "i" (statusIcon status <> " icon") blank 315 | text $ statusMessage status 316 | -- triggerBatch trigger_subscribeOutput $ [BuildJobId $ _buildJob_id job] <$ click 317 | -- setRoute $ (FR_Jobs :/ Job_Output :/ _buildJob_id job) <$ click 318 | return never 319 | 320 | statusColor :: JobStatus -> Color 321 | statusColor = \case 322 | JobPending -> Black 323 | JobInProgress -> Blue 324 | JobCanceled -> Grey 325 | JobTimedOut -> Grey 326 | JobVanished -> Grey 327 | JobFailed -> Red 328 | JobSucceeded -> Green 329 | 330 | statusIcon :: JobStatus -> Text 331 | statusIcon = \case 332 | JobPending -> "clock outline" 333 | JobInProgress -> "hourglass half" 334 | JobCanceled -> "x" 335 | JobTimedOut -> "x" 336 | JobVanished -> "question" 337 | JobFailed -> "ban" 338 | JobSucceeded -> "check" 339 | 340 | statusMessage :: JobStatus -> Text 341 | statusMessage = \case 342 | JobPending -> "pending" 343 | JobInProgress -> "running" 344 | JobCanceled -> "canceled" 345 | JobTimedOut -> "timed out" 346 | JobVanished -> "vanished" 347 | JobFailed -> "failed" 348 | JobSucceeded -> "passed" 349 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Repos.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | 13 | module Frontend.Widgets.Repos where 14 | 15 | ------------------------------------------------------------------------------ 16 | import Control.Monad.Reader 17 | import qualified Data.Map as M 18 | import Data.Maybe 19 | import Data.Text (Text) 20 | import qualified Data.Text as T 21 | import Database.Beam 22 | import Obelisk.Route 23 | import Obelisk.Route.Frontend 24 | import Reflex.Dom.Contrib.CssClass 25 | import Reflex.Dom.Contrib.Utils 26 | import Reflex.Dom.Core 27 | ------------------------------------------------------------------------------ 28 | import Common.Route 29 | import Common.Types.BinaryCache 30 | import Common.Types.ConnectedAccount 31 | import Common.Types.Repo 32 | import Common.Types.S3Cache 33 | import Frontend.App 34 | import Frontend.AppState 35 | import Frontend.Common 36 | import Frontend.Widgets.Common 37 | import Frontend.Widgets.Form 38 | ------------------------------------------------------------------------------ 39 | 40 | reposWidget 41 | :: MonadApp (R CrudRoute) t m 42 | => RoutedT t (R CrudRoute) m () 43 | reposWidget = mdo 44 | pb <- getPostBuild 45 | trigger trigger_getRepos pb 46 | as <- ask 47 | subRoute_ $ \case 48 | Crud_List -> reposList (_as_repos as) 49 | Crud_Create -> addRepo 50 | return () 51 | 52 | textDynColumn 53 | :: MonadApp r t m 54 | => (a f -> Text) 55 | -> PrimaryKey a f 56 | -> Dynamic t (a f) 57 | -> m (Event t ()) 58 | textDynColumn f _ v = el "td" $ do 59 | dynText (f <$> v) 60 | return never 61 | 62 | reposList 63 | :: (MonadApp r t m) 64 | => Dynamic t (BeamMap Identity RepoT) 65 | -> m () 66 | reposList as = do 67 | (e,_) <- elAttr' "button" ("class" =: "ui button") $ text "Add Repository" 68 | setRoute $ (FR_Repos :/ Crud_Create :/ ()) <$ domEvent Click e 69 | 70 | _ <- genericTableG def as 71 | [ ("ID", textDynColumn (tshow . _repo_id)) 72 | , ("Full Name", textDynColumn $ repoFullName) 73 | , ("Nix File", textDynColumn $ _repo_buildNixFile) 74 | , ("Timeout", textDynColumn (tshow . _repo_timeout)) 75 | , ("", \k _ -> deleteColumn trigger_delRepos k) 76 | ] 77 | return () 78 | 79 | addRepo :: MonadApp r t m => m () 80 | addRepo = do 81 | semuiForm $ do 82 | dr <- newRepoForm unfilledRepo never 83 | divClass "field" $ do 84 | let as = addClassWhen "disabled" (not . isValidRepo <$> dr) 85 | (manyClasses ["ui", "button"]) 86 | (e1,_) <- elDynKlass' "button" as $ text "Add Repo" 87 | (e2,_) <- elAttr' "button" ("class" =: "ui button") $ text "Cancel" 88 | trigger trigger_addRepo $ tag (current dr) (domEvent Click e1) 89 | setRoute $ (FR_Repos :/ Crud_List :/ ()) <$ leftmost 90 | [domEvent Click e1, domEvent Click e2] 91 | return () 92 | 93 | unfilledRepo :: RepoT Maybe 94 | unfilledRepo = Repo Nothing (ConnectedAccountId Nothing) Nothing Nothing Nothing (Just mempty) Nothing (BinaryCacheId Nothing) Nothing 95 | 96 | newRepoForm 97 | :: MonadApp r t m 98 | => RepoT Maybe 99 | -> Event t (RepoT Maybe) 100 | -> m (Dynamic t (RepoT Maybe)) 101 | newRepoForm iv sv = do 102 | accounts <- asks _as_accounts 103 | dmca <- labelledAs "Access Account" $ 104 | accountDropdown accounts Nothing never 105 | drns <- divClass "field" $ do 106 | el "label" $ do 107 | text "Repo Namespace " 108 | let tip = "Everything after the domain but before the repository name. In GitHub, this is just the user/org name. In GitLab, this can be multiple nested subgroups." 109 | elAttr "span" ("data-tooltip" =: tip <> "data-position" =: "top left") $ 110 | elAttr "i" ("class" =: "info circle icon") blank 111 | textField 112 | (fromMaybe "" $ _repo_namespace iv) 113 | (fromMaybe "" . _repo_namespace <$> sv) 114 | drn <- divClass "field" $ do 115 | el "label" $ do 116 | text "Repo Name " 117 | let tip = "The repository name (the last component of the project's root URL)" 118 | elAttr "span" ("data-tooltip" =: tip <> "data-position" =: "top left") $ 119 | elAttr "i" ("class" =: "info circle icon") blank 120 | textField 121 | (fromMaybe "" $ _repo_name iv) 122 | (fromMaybe "" . _repo_name <$> sv) 123 | let tip = "Path to .nix file in your repo that describes the build (default.nix, release.nix, etc)" 124 | let bnfLabel = do 125 | text "Build Nix File " 126 | elAttr "span" ("data-tooltip" =: tip <> "data-position" =: "top left") $ 127 | elAttr "i" ("class" =: "info circle icon") blank 128 | 129 | caches <- asks _as_caches 130 | dcache <- labelledAs "S3 Cache" $ 131 | cacheDropdown caches Nothing never 132 | 133 | dnf <- divClass "field" $ do 134 | el "label" $ bnfLabel 135 | ie <- inputElement $ def 136 | & inputElementConfig_initialValue .~ (fromMaybe "default.nix" $ _repo_buildNixFile iv) 137 | & inputElementConfig_setValue .~ (fromMaybe "default.nix" . _repo_buildNixFile <$> sv) 138 | return $ value ie 139 | 140 | let attrsTip = "Optional space-separated list of attributes to build" 141 | let attrsLabel = do 142 | text "Attributes to build" 143 | elAttr "span" ("data-tooltip" =: attrsTip <> "data-position" =: "top left") $ 144 | elAttr "i" ("class" =: "info circle icon") blank 145 | das <- divClass "field" $ do 146 | el "label" $ attrsLabel 147 | ie <- inputElement $ def 148 | & inputElementConfig_initialValue .~ (maybe "" (T.unwords . unAttrList) $ _repo_attributesToBuild iv) 149 | & inputElementConfig_setValue .~ (maybe "" (T.unwords . unAttrList) . _repo_attributesToBuild <$> sv) 150 | return $ fmap (AttrList . T.words) $ value ie 151 | 152 | dt <- labelledAs "Timeout (in seconds)" $ readableField Nothing 153 | (maybe (Just 3600) Just $ _repo_timeout iv) 154 | (_repo_timeout <$> sv) 155 | return $ do 156 | rns <- drns 157 | rn <- drn 158 | nf <- dnf 159 | --cm <- dcm 160 | t <- dt 161 | mca <- dmca 162 | c <- dcache 163 | as <- das 164 | pure $ case mca of 165 | Nothing -> unfilledRepo 166 | Just a -> do 167 | let aid = _connectedAccount_id a 168 | maid = ConnectedAccountId $ Just aid 169 | in Repo Nothing maid (Just rn) (Just rns) (Just nf) (Just as) t (cachePrimaryKey c) Nothing 170 | 171 | cachePrimaryKey :: Maybe BinaryCache -> PrimaryKey BinaryCacheT (Nullable Maybe) 172 | cachePrimaryKey Nothing = BinaryCacheId Nothing 173 | cachePrimaryKey (Just (BinaryCache i _)) = BinaryCacheId (Just $ Just i) 174 | 175 | accountDropdown 176 | :: forall r t m. MonadApp r t m 177 | => Dynamic t (BeamMap Identity ConnectedAccountT) 178 | -> Maybe ConnectedAccount 179 | -> Event t (Maybe ConnectedAccount) 180 | -> m (Dynamic t (Maybe ConnectedAccount)) 181 | accountDropdown accounts iv sv = do 182 | let vals = M.fromList . map mkPair . (Nothing:) . map Just . M.elems <$> accounts 183 | mkPair Nothing = (Nothing,"") 184 | mkPair (Just a) = (Just a, providerUrl (_connectedAccount_provider a) <> "/" <> _connectedAccount_name a) 185 | d <- dropdown iv vals $ def 186 | & setValue .~ sv 187 | & attributes .~ constDyn ("class" =: "ui dropdown selection") 188 | 189 | return $ value d 190 | 191 | cacheDropdown 192 | :: forall r t m. MonadApp r t m 193 | => Dynamic t (BeamMap Identity BinaryCacheT) 194 | -> Maybe BinaryCache 195 | -> Event t (Maybe BinaryCache) 196 | -> m (Dynamic t (Maybe BinaryCache)) 197 | cacheDropdown caches iv sv = do 198 | let vals = M.fromList . map mkPair . (Nothing:) . map Just . M.elems <$> caches 199 | mkPair Nothing = (Nothing,"") 200 | mkPair (Just a) = (Just a, "s3://" <> _s3Cache_bucket (_binaryCache_s3Cache a)) 201 | d <- dropdown iv vals $ def 202 | & setValue .~ sv 203 | & attributes .~ constDyn ("class" =: "ui dropdown selection") 204 | 205 | return $ value d 206 | 207 | mkFullName :: AccountProvider -> Text -> Text -> Text 208 | mkFullName GitHub owner name = owner <> "/" <> name 209 | mkFullName GitLab owner name = owner <> "/" <> name 210 | 211 | isValidRepo :: RepoT Maybe -> Bool 212 | isValidRepo (Repo _ (ConnectedAccountId (Just _)) (Just _) (Just _) (Just _) (Just _) (Just _) (BinaryCacheId _) _) = True 213 | isValidRepo _ = False 214 | -------------------------------------------------------------------------------- /frontend/src/Frontend/Widgets/Settings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | module Frontend.Widgets.Settings where 8 | 9 | ------------------------------------------------------------------------------ 10 | import Control.Monad.Reader 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Data.Text.Encoding 14 | import qualified GHCJS.DOM.Types as DOM 15 | import Language.Javascript.JSaddle (MonadJSM) 16 | import Obelisk.Configs 17 | import Reflex.Dom 18 | import Reflex.Network 19 | ------------------------------------------------------------------------------ 20 | import Common.Types.CiSettings 21 | import Frontend.App 22 | import Frontend.AppState 23 | import Frontend.Widgets.Common 24 | import Frontend.Widgets.Form 25 | ------------------------------------------------------------------------------ 26 | 27 | settingsWidget 28 | :: (MonadApp r t m, Prerender js t m, HasConfigs m) 29 | => m () 30 | settingsWidget = do 31 | pb <- getPostBuild 32 | trigger trigger_getCiSettings pb 33 | trigger trigger_getCiInfo pb 34 | el "h1" $ text "Settings" 35 | dynSettingsForm 36 | return () 37 | 38 | dynSettingsForm 39 | :: (MonadApp r t m, Prerender js t m, HasConfigs m) 40 | => m () 41 | dynSettingsForm = do 42 | dcs <- asks _as_ciSettings 43 | dci <- asks _as_ciInfo 44 | _ <- networkView $ ffor ((,) <$> dcs <*> dci) $ \pair -> do 45 | case pair of 46 | (Just cs, Just ci) -> do 47 | semuiForm $ do 48 | dcsNew <- settingsForm ci cs never 49 | let mkAttrs cs2 csNew = 50 | if cs2 == Just csNew 51 | then ("class" =: "ui button disabled") 52 | else ("class" =: "ui button") 53 | (e,_) <- divClass "field" $ elDynAttr' "button" (mkAttrs <$> dcs <*> dcsNew) $ 54 | text "Update Settings" 55 | trigger trigger_updateCiSettings $ tag (current dcsNew) (domEvent Click e) 56 | return () 57 | _ -> genericLoading 58 | return () 59 | 60 | settingsForm 61 | :: (MonadApp r t m, Prerender js t m, HasConfigs m) 62 | => Text 63 | -> CiSettings 64 | -> Event t CiSettings 65 | -> m (Dynamic t CiSettings) 66 | settingsForm ciInfo iv sv = do 67 | dnp <- divClass "field" $ do 68 | el "label" $ text "Nix Path" 69 | ie <- inputElement $ def 70 | & inputElementConfig_initialValue .~ _ciSettings_nixPath iv 71 | & inputElementConfig_setValue .~ (_ciSettings_nixPath <$> sv) 72 | return $ value ie 73 | 74 | serveLocalCache <- divClass "field" $ do 75 | divClass "ui checkbox" $ do 76 | v <- checkbox (_ciSettings_serveLocalCache iv) $ def 77 | & setValue .~ (_ciSettings_serveLocalCache <$> sv) 78 | el "label" $ text "Serve Local Cache" 79 | return $ value v 80 | dynInfoWidget ciInfo serveLocalCache 81 | return (CiSettings 1 <$> dnp <*> serveLocalCache) 82 | 83 | dynInfoWidget 84 | :: (MonadApp r t m, Prerender js t m, HasConfigs m) 85 | => Text 86 | -> Dynamic t Bool 87 | -> m () 88 | dynInfoWidget ciInfo serveLocalCache = do 89 | _ <- networkView $ ffor serveLocalCache $ infoWidget ciInfo 90 | return () 91 | 92 | infoWidget 93 | :: (MonadApp r t m, Prerender js t m, HasConfigs m) 94 | => Text 95 | -> Bool 96 | -> m () 97 | infoWidget pubkey True = divClass "ui segment" $ do 98 | mRootRoute <- getConfig "common/route" 99 | case mRootRoute of 100 | Nothing -> text "Can't find server address. Server not configured properly." 101 | Just rootRoute -> do 102 | let route = T.strip (decodeUtf8 rootRoute) <> "/cache/" 103 | copyableValue "Cache Address" route 104 | copyableValue "Cache Public Key" pubkey 105 | el "h4" $ text "To use this cache, put the following in your /etc/nix/nix.conf:" 106 | elAttr "pre" ("class" =: "ui segment" <> "style" =: "overflow: auto;") $ do 107 | text $ nixConfExample route pubkey 108 | infoWidget _ False = blank 109 | 110 | nixConfExample :: Text -> Text -> Text 111 | nixConfExample addr pubkey = T.unlines 112 | [ "substituters = " <> addr <> " https://cache.nixos.org/" 113 | , "trusted-public-keys = " <> pubkey <> " cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" 114 | ] 115 | 116 | copyableValue 117 | :: (MonadApp r t m, Prerender js t m) 118 | => Text 119 | -> Text 120 | -> m () 121 | copyableValue label val = do 122 | el "h4" $ text label 123 | el "div" $ mdo 124 | -- _ <- prerender blank $ void $ liftJS $ copyButton (_element_raw e) 125 | (e,_) <- el' "span" $ text val 126 | return () 127 | -------------------------------------------------------------------------------- /makeLinks: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm -f frontend.jsexe.assets 4 | rm -f static.assets 5 | ln -s result-exe/frontend.jsexe.assets . 6 | ln -s result-exe/static.assets . 7 | -------------------------------------------------------------------------------- /migrations.md: -------------------------------------------------------------------------------- 1 | # Migrations 2 | 3 | Haven't had time to put in place a fully automated migration system, so until 4 | that happens will put migration code here. 5 | 6 | ### 2020-06-27 Columns of type INTEGER change to BIGINT 7 | 8 | ------------------------------------------------------------------------------ 9 | NOTE: This migration is not needed after pull request 36 was merged. Leaving 10 | it here for now as a useful migration trick that we may want to use in the 11 | future. 12 | ------------------------------------------------------------------------------ 13 | 14 | Sqlite does not support changing column data types, but you can migrate with the 15 | following script. Note that this script hasn't been exhaustively tested, so use 16 | with care. 17 | 18 | ``` 19 | echo '.dump' | sqlite3 zeus.db > zeus.dump 20 | sed 's/INTEGER/BIGINT/g' zeus.dump > zeus.dump2 21 | cat zeus.dump2 | sqlite3 zeus-new.db 22 | mv zeus-new.db zeus.db 23 | ``` 24 | 25 | ### 2019-08-12 Per-repository S3 caches and keep track of what has been uploaded to them 26 | 27 | #### Added nullable binaryCache_id column 28 | ``` 29 | ALTER TABLE "ciDb_repos" RENAME TO "ciDb_repos_old_1"; 30 | CREATE TABLE IF NOT EXISTS "ciDb_repos"("repo_id" INTEGER NOT NULL , "repo_accessAccount__connectedAccount_id" INTEGER NOT NULL , "repo_name" VARCHAR NOT NULL , "repo_namespace" VARCHAR NOT NULL , "repo_buildNixFile" VARCHAR NOT NULL , "repo_timeout" INTEGER NOT NULL , "repo_cache__binaryCache_id" INTEGER, "repo_hookId" INTEGER NOT NULL , PRIMARY KEY("repo_id")); 31 | INSERT INTO "ciDb_repos" SELECT "repo_id", "repo_accessAccount__connectedAccount_id", "repo_name", "repo_namespace", "repo_buildNixFile", "repo_timeout", NULL, "repo_hookId" FROM "ciDb_repos_old_1"; 32 | DROP TABLE ciDb_repos_old_1; 33 | ``` 34 | 35 | #### Removed s3cache column 36 | ``` 37 | ALTER TABLE "ciDb_ciSettings" RENAME TO "ciDb_ciSettings_old_0"; 38 | CREATE TABLE IF NOT EXISTS "ciDb_ciSettings"("ciSettings_id" INTEGER NOT NULL , "ciSettings_nixPath" VARCHAR NOT NULL , "ciSettings_serveLocalCache" BOOLEAN NOT NULL , PRIMARY KEY("ciSettings_id")); 39 | INSERT INTO "ciDb_ciSettings" SELECT "ciSettings_id", "ciSettings_nixPath", "ciSettings_serveLocalCache" FROM "ciDb_ciSettings_old_0"; 40 | DROP TABLE ciDb_ciSettings_old_0; 41 | ``` 42 | 43 | #### Removed CachedHash autoincrementing ID 44 | 45 | ``` 46 | ALTER TABLE "ciDb_cachedHashes" RENAME TO "ciDb_cachedHashes_old_0"; 47 | CREATE TABLE IF NOT EXISTS "ciDb_cachedHashes"("cachedHash_hash" VARCHAR NOT NULL , "cachedHash_cache__binaryCache_id" INTEGER NOT NULL , "cachedHash_time" TIMESTAMP WITH TIME ZONE NOT NULL , PRIMARY KEY("cachedHash_hash")); 48 | INSERT INTO "ciDb_cachedHashes" SELECT distinct("cachedHash_hash"), max("cachedHash_cache__binaryCache_id"), max("cachedHash_time") FROM "ciDb_cachedHashes_old_0" GROUP BY "cachedHash_hash"; 49 | DROP TABLE "ciDb_cachedHashes_old_0"; 50 | ``` 51 | 52 | #### Add repo build attributes column 53 | 54 | ``` 55 | ALTER TABLE "ciDb_repos" RENAME TO "ciDb_repos_old_2"; 56 | CREATE TABLE IF NOT EXISTS "ciDb_repos"("repo_id" INTEGER NOT NULL , "repo_accessAccount__connectedAccount_id" INTEGER NOT NULL , "repo_name" VARCHAR NOT NULL , "repo_namespace" VARCHAR NOT NULL , "repo_buildNixFile" VARCHAR NOT NULL , "repo_attributesToBuild" VARCHAR NOT NULL , "repo_timeout" INTEGER NOT NULL , "repo_cache__binaryCache_id" INTEGER, "repo_hookId" INTEGER NOT NULL , PRIMARY KEY("repo_id")); 57 | INSERT INTO ciDb_repos SELECT repo_id, repo_accessAccount__connectedAccount_id, repo_name, repo_namespace, repo_buildNixFile, '[]', repo_timeout, repo_cache__binaryCache_id, repo_hookId FROM ciDb_repos_old_2; 58 | DROP TABLE ciDb_repos_old_2; 59 | ``` 60 | 61 | ### 2019-07-07 Migration for removing clone method column 62 | 63 | ``` 64 | ALTER TABLE "ciDb_repos" RENAME TO "ciDb_repos_old_0"; 65 | CREATE TABLE IF NOT EXISTS "ciDb_repos"("repo_id" INTEGER NOT NULL , "repo_accessAccount__connectedAccount_id" INTEGER NOT NULL , "repo_name" VARCHAR NOT NULL , "repo_namespace" VARCHAR NOT NULL , "repo_buildNixFile" VARCHAR NOT NULL , "repo_timeout" INTEGER NOT NULL , "repo_hookId" INTEGER NOT NULL , PRIMARY KEY("repo_id")); 66 | INSERT INTO "ciDb_repos" SELECT "repo_id", "repo_accessAccount__connectedAccount_id", "repo_name", "repo_namespace", "repo_buildNixFile", "repo_timeout", "repo_hookId" FROM "ciDb_repos_old_0"; 67 | DROP TABLE ciDb_repos_old_0; 68 | ``` 69 | 70 | -------------------------------------------------------------------------------- /static.assets: -------------------------------------------------------------------------------- 1 | result-exe/static.assets -------------------------------------------------------------------------------- /static/css/custom.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: #FFFFFF; 3 | } 4 | .ui.menu .item img.logo { 5 | margin-right: 1.5em; 6 | } 7 | .main.container { 8 | margin-top: 7em; 9 | } 10 | .wireframe { 11 | margin-top: 2em; 12 | } 13 | .ui.footer.segment { 14 | margin: 5em 0em 0em; 15 | padding: 5em 0em; 16 | } 17 | 18 | .jobstatus { 19 | width: 100%; 20 | } 21 | 22 | .clickable { 23 | cursor: pointer; 24 | } 25 | 26 | .avatar { 27 | width: 16px; 28 | height: 16px; 29 | } 30 | 31 | .highlighted { 32 | background-color: #fffbbd; 33 | } 34 | 35 | .build-output { 36 | counter-reset: linenumber; 37 | } 38 | 39 | .build-output .output { 40 | color: #ccc; 41 | } 42 | 43 | .build-output td { 44 | border: none!important; 45 | padding-top: 0!important; 46 | padding-bottom: 0!important; 47 | padding-right: 0!important; 48 | } 49 | 50 | tr::before { 51 | display: block; 52 | content: " "; 53 | margin-top: -50px; 54 | height: 50px; 55 | visibility: hidden; 56 | pointer-events: none; 57 | } 58 | 59 | .output-line { 60 | margin-left: 45px; 61 | } 62 | 63 | td.linenum { 64 | text-align: right!important; 65 | vertical-align: top; 66 | } 67 | 68 | .linenum a { 69 | cursor: pointer; 70 | color: #666; 71 | } 72 | 73 | td.linenum a::before { 74 | counter-increment: linenumber; 75 | content: counter(linenumber); 76 | } 77 | 78 | table.build-output td.output { 79 | white-space: pre-wrap; 80 | width: 100%; 81 | font-family: monospace; 82 | } 83 | 84 | tr.cmd-msg td.output { 85 | color: #00d600; 86 | font-weight: 600; 87 | } 88 | -------------------------------------------------------------------------------- /static/favicon.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/brand-icons.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/brand-icons.eot -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/brand-icons.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/brand-icons.ttf -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/brand-icons.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/brand-icons.woff -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/brand-icons.woff2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/brand-icons.woff2 -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/icons.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/icons.eot -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/icons.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/icons.otf -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/icons.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/icons.ttf -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/icons.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/icons.woff -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/icons.woff2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/icons.woff2 -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/outline-icons.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/outline-icons.eot -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/outline-icons.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/outline-icons.ttf -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/outline-icons.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/outline-icons.woff -------------------------------------------------------------------------------- /static/themes/default/assets/fonts/outline-icons.woff2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/fonts/outline-icons.woff2 -------------------------------------------------------------------------------- /static/themes/default/assets/images/flags.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mightybyte/zeus/097b2e8669a659749b46c3cca48e300b27f194cd/static/themes/default/assets/images/flags.png --------------------------------------------------------------------------------