From 3e0026151485858de6025f27eebe1f941329687a Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 16 Feb 2022 03:07:35 +0100 Subject: server: repositores & orgs fixed in config a very simple setup that might be usable for divoc and similar small events --- server/Server.hs | 117 +++++++++++++++++++++++++++---------------------------- 1 file changed, 58 insertions(+), 59 deletions(-) (limited to 'server/Server.hs') diff --git a/server/Server.hs b/server/Server.hs index bdfa77f..e392f89 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -5,39 +5,40 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE LambdaCase #-} module Server ( loadConfig , Org(..) - , Config, tmpdir, port, verbose, orgs + , Sha1 + , Config, tmpdir, port, verbose, orgs, interval , RemoteRef(..) - , ServerState, registry, jobs, defaultState + , ServerState, defaultState, unState , JobStatus(..) , setJobStatus - , setRegistry - , AdminOverview(..) - ) where + , prettySha) where import Universum -import CheckDir (DirResult) -import Control.Concurrent (modifyMVar_) -import Data.Aeson (FromJSON, ToJSON (toJSON), - (.=), eitherDecodeFileStrict') -import qualified Data.Aeson as A -import qualified Data.Map as M -import Data.UUID (UUID) -import Lens.Micro (traverseOf) +import CheckDir (DirResult) +import Control.Concurrent (modifyMVar_) +import Crypto.Hash.SHA1 +import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..), + eitherDecodeFileStrict') +import qualified Data.ByteString.Base64.URL as Base64 +import qualified Data.Map as M +import Lens.Micro (traverseOf) import Lens.Micro.TH -import LintConfig (LintConfig') -import Toml (TomlCodec, prettyTomlDecodeErrors) -import qualified Toml as T +import LintConfig (LintConfig') +import Servant (FromHttpApiData) +import Toml (TomlCodec, prettyTomlDecodeErrors, + (.=)) +import qualified Toml as T -- | a reference in a remote git repository data RemoteRef = RemoteRef @@ -49,23 +50,35 @@ type family ConfigRes (b :: Bool) a where ConfigRes True a = a ConfigRes False a = FilePath +newtype Sha1 = Sha1 Text + deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON) + +-- | base64-encoded sha1 +prettySha :: Sha1 -> Text +prettySha (Sha1 text) = text + +instance ToJSONKey Sha1 + +toSha :: RemoteRef -> Sha1 +toSha ref = Sha1 . decodeUtf8 . Base64.encode . hash . encodeUtf8 $ (show ref :: Text) data Org (loaded :: Bool) = Org - { orgSlug :: Text + { orgSlug :: Text , orgLintconfig :: ConfigRes loaded LintConfig' , orgEntrypoint :: FilePath - , orgRepos :: [RemoteRef] + , orgRepos :: [RemoteRef] } -- | the server's configuration data Config (loaded :: Bool) = Config - { _tmpdir :: FilePath + { _tmpdir :: FilePath -- ^ dir to clone git things in - , _port :: Int - , _verbose :: Bool + , _port :: Int + , _verbose :: Bool + , _interval :: Int -- ^ port to bind to - , _orgs :: [Org loaded] + , _orgs :: [Org loaded] } deriving Generic makeLenses ''Config @@ -73,71 +86,57 @@ makeLenses ''Config remoteCodec :: TomlCodec RemoteRef remoteCodec = RemoteRef - <$> T.text "url" T..= repourl - <*> T.text "ref" T..= reporef + <$> T.text "url" .= repourl + <*> T.text "ref" .= reporef orgCodec :: TomlCodec (Org False) orgCodec = Org - <$> T.text "slug" T..= orgSlug - <*> T.string "lintconfig" T..= orgLintconfig - <*> T.string "entrypoint" T..= orgEntrypoint - <*> T.list remoteCodec "repo" T..= orgRepos + <$> T.text "slug" .= orgSlug + <*> T.string "lintconfig" .= orgLintconfig + <*> T.string "entrypoint" .= orgEntrypoint + <*> T.list remoteCodec "repo" .= orgRepos configCodec :: TomlCodec (Config False) configCodec = Config - <$> T.string "tmpdir" T..= _tmpdir - <*> T.int "port" T..= _port - <*> T.bool "verbose" T..= _verbose - <*> T.list orgCodec "org" T..= _orgs + <$> T.string "tmpdir" .= _tmpdir + <*> T.int "port" .= _port + <*> T.bool "verbose" .= _verbose + <*> T.int "interval" .= _interval + <*> T.list orgCodec "org" .= _orgs -- | a job status (of a specific uuid) data JobStatus = Pending | Linted DirResult | Failed Text deriving (Generic, ToJSON) --- | the server's global state -data ServerState = ServerState - { _jobs :: Map RemoteRef JobStatus - , _registry :: Map UUID RemoteRef - } +-- | the server's global state; might eventually end up with more +-- stuff in here, hence the newtype +newtype ServerState = ServerState + { _unState :: Map Sha1 (RemoteRef, JobStatus) } + makeLenses ''ServerState defaultState :: ServerState -defaultState = ServerState mempty mempty - --- | an info type wrapped around the server state, to carry serialisation instances. --- TODO: should probably not be defined here -newtype AdminOverview = - AdminOverview { unAdminOverview :: ServerState } - -instance ToJSON AdminOverview where - toJSON (AdminOverview state) = - toJSON . flip M.mapWithKey (view registry state) $ \uuid ref -> - A.object [ "reference" .= uuid - , "remote" .= ref - , "status" .= M.lookup ref (view jobs state) - ] +defaultState = ServerState mempty +-- | loads a config, along with all things linked in it +-- (e.g. linterconfigs for each org) loadConfig :: FilePath -> IO (Config True) loadConfig path = do res <- T.decodeFileEither configCodec path case res of Right config -> traverseOf orgs (mapM loadOrg) config - Left err -> error $ prettyTomlDecodeErrors err + Left err -> error $ prettyTomlDecodeErrors err where loadOrg :: Org False -> IO (Org True) loadOrg org = do lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case - Right c -> pure c + Right c -> pure c Left err -> error $ show err pure $ org { orgLintconfig = lintconfig } setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO () setJobStatus mvar !ref !status = modifyMVar_ mvar - $ pure . over jobs (M.insert ref status) - -setRegistry :: MVar ServerState -> UUID -> RemoteRef -> IO () -setRegistry mvar !uuid !ref = modifyMVar_ mvar - $ pure . over registry (M.insert uuid ref) + $ pure . over unState (M.insert (toSha ref) (ref, status)) -- cgit v1.2.3