server: repositores & orgs fixed in config

a very simple setup that might be usable for divoc and similar small events

1 files changed, 58 insertions, 59 deletions

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))