… several hours of fighting with TOML later

WHO THOUGHT THIS SYNTAX WAS A GOOD IDEA??

(and who decided to write the least obvious combinator library to parse it?)

6 files changed, 115 insertions, 71 deletions

diff --git a/config.toml b/config.toml
index ff3ef8e..3886597 100644
--- a/config.toml
+++ b/config.toml
@@ -4,6 +4,17 @@ port = 8080
 verbose = true
 
 tmpdir = "/tmp"
-entrypoint = "main.json"
+
+
+[[org]]
+slug = "divoc"
 lintconfig = "./config.json"
+entrypoint = "main.json"
+
+[[org.repo]] # I hate TOML
+url = "https://gitlab.infra4future.de/hacc/events/hacc-map"
+ref = "master"
 
+[[org.repo]]
+url = "https://github.com/namiko/assembly_2021"
+ref = "master"
diff --git a/package.yaml b/package.yaml
index 652cb37..7dacce8 100644
--- a/package.yaml
+++ b/package.yaml
@@ -75,6 +75,7 @@ executables:
       - cli-extras
       - extra
       - uuid
+      - microlens
       - microlens-th
       - tomland
       - dotgen
diff --git a/server/Handlers.hs b/server/Handlers.hs
index e590cb7..afbb2b9 100644
--- a/server/Handlers.hs
+++ b/server/Handlers.hs
@@ -3,7 +3,12 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Handlers (App, submitImpl,statusImpl,relintImpl,adminOverviewImpl) where
+module Handlers (App
+                -- , submitImpl
+                , statusImpl
+                -- , relintImpl
+                , adminOverviewImpl
+                ) where
 
 import           Universum
 
@@ -23,11 +28,11 @@ import qualified Data.UUID.V4            as UUID
 import           Servant                 (Handler, NoContent (NoContent),
                                           err404, err500, throwError)
 import           Server                  (AdminOverview (AdminOverview),
-                                          Config (entrypoint, lintconfig, tmpdir),
+                                          Config, orgs, tmpdir,
                                           JobStatus (..),
                                           RemoteRef (reporef, repourl),
                                           ServerState, jobs, registry,
-                                          setJobStatus, setRegistry)
+                                          setJobStatus, setRegistry, Org (..))
 import           System.Directory        (doesDirectoryExist)
 import           System.FilePath         ((</>))
 
@@ -38,28 +43,28 @@ type App = CliT ProcessFailure Handler
 instance MonadFail Handler where
   fail _ = throwError err500
 
--- | someone submitted a map; lint it (synchronously for now)
-submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
-submitImpl config state ref = do
-  jobid <- liftIO UUID.nextRandom
-  -- TODO: these two should really be atomic
-  liftIO $ setJobStatus state ref Pending
-  liftIO $ setRegistry state jobid ref
-  cliconfig <- getCliConfig
-  -- we'll just forget the thread id for now and trust this terminates …
-  _ <- checkRef config cliconfig state ref
-  -- the submission itself can't really fail or return anything useful
-  pure jobid
+-- -- | someone submitted a map; lint it (synchronously for now)
+-- submitImpl :: Config True -> MVar ServerState -> RemoteRef -> App UUID
+-- submitImpl config state ref = do
+--   jobid <- liftIO UUID.nextRandom
+--   -- TODO: these two should really be atomic
+--   liftIO $ setJobStatus state ref Pending
+--   liftIO $ setRegistry state jobid ref
+--   cliconfig <- getCliConfig
+--   -- we'll just forget the thread id for now and trust this terminates …
+--   _ <- checkRef config cliconfig state ref
+--   -- the submission itself can't really fail or return anything useful
+--   pure jobid
 
-relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent
-relintImpl config state uuid = do
-  mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
-  case mref of
-    Nothing -> lift $ throwError err404
-    Just ref -> do
-      cliconfig <- getCliConfig
-      _ <- checkRef config cliconfig state ref
-      pure NoContent
+-- relintImpl :: Config True -> MVar ServerState -> UUID -> App NoContent
+-- relintImpl config state uuid = do
+--   mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
+--   case mref of
+--     Nothing -> lift $ throwError err404
+--     Just ref -> do
+--       cliconfig <- getCliConfig
+--       _ <- checkRef config cliconfig state ref
+--       pure NoContent
 
 statusImpl :: MVar ServerState -> UUID -> App JobStatus
 statusImpl state uuid = do
@@ -80,8 +85,8 @@ adminOverviewImpl state = do
 -- | the actual check function. forks, calls out to git to update the
 -- repository, create a new worktree, lints it, then tells git to
 -- delete that tree again
-checkRef :: Config True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
-checkRef config cliconfig state ref = liftIO $ forkIO $ do
+checkRef :: Config True -> Org True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
+checkRef config org cliconfig state ref = liftIO $ forkIO $ do
     res <- liftIO $ runCli cliconfig $ do
       ifM (liftIO $ doesDirectoryExist gitdir)
         -- TODO: these calls fail for dumb http, add some fallback!
@@ -94,7 +99,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do
       let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
       callgit gitdir [ "worktree", "add", workdir ]
       callgit workdir [ "checkout", toString (reporef ref) ]
-      res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
+      res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org)
       callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
       pure res
     liftIO $ setJobStatus state ref $ case res of
@@ -102,7 +107,7 @@ checkRef config cliconfig state ref = liftIO $ forkIO $ do
       Left err  -> Failed (prettyProcessFailure err)
   where
     callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
-    gitdir = tmpdir config </> toString hashedname
+    gitdir = view tmpdir config </> toString hashedname
     hashedname = T.map escapeSlash . repourl $ ref
     escapeSlash = \case { '/' -> '-'; a -> a }
 
diff --git a/server/Main.hs b/server/Main.hs
index fd66ad3..04a2010 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -17,8 +17,8 @@ import           Cli.Extras                           (CliConfig,
 import qualified Data.ByteString.Lazy.Char8           as C8
 import           Data.UUID                            (UUID)
 import           Handlers                             (App, adminOverviewImpl,
-                                                       relintImpl, statusImpl,
-                                                       submitImpl)
+                                                        statusImpl,
+                                                       )
 import           HtmlOrphans                          ()
 import           Network.Wai.Handler.Warp             (defaultSettings,
                                                        runSettings, setPort)
@@ -42,14 +42,14 @@ import           Server                               (AdminOverview,
                                                        Config (..), JobStatus,
                                                        RemoteRef (..),
                                                        ServerState,
-                                                       defaultState, loadConfig)
+                                                       defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos))
 
 
 -- | Main API type
 type API format =
-       "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
-  :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
-  :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
+       -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
+       "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
+  -- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
   :<|> "admin" :> "overview" :> Get '[format] AdminOverview
 
 type Routes =
@@ -61,9 +61,9 @@ type Routes =
 -- | API's implementation
 jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
 jsonAPI config state =
-  submitImpl config state
-  :<|> statusImpl state
-  :<|> relintImpl config state
+  -- submitImpl config state
+       statusImpl state
+  -- :<|> relintImpl config state
   :<|> adminOverviewImpl state
 
 server :: Config True -> MVar ServerState -> ServerT Routes App
@@ -92,12 +92,16 @@ main = do
   state <- newMVar defaultState
   -- TODO: i really don't like all this cli logging stuff, replace it with
   -- fast-logger at some point …
-  cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | verbose config]
+  cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config]
   loggerMiddleware <- mkRequestLogger
-    $ def { outputFormat = Detailed (verbose config) }
+    $ def { outputFormat = Detailed (view verbose config) }
+
+  -- print (keys $ view orgs config)
+  print (map orgEntrypoint $ view orgs config)
+  print (map orgRepos $ view orgs config)
 
   let warpsettings =
-       setPort (port config)
+       setPort (view port config)
        defaultSettings
 
   runSettings warpsettings
diff --git a/server/Server.hs b/server/Server.hs
index 8014053..bdfa77f 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -11,9 +11,11 @@
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Server ( loadConfig
-              , Config(..)
+              , Org(..)
+              , Config, tmpdir, port, verbose, orgs
               , RemoteRef(..)
               , ServerState, registry, jobs, defaultState
               , JobStatus(..)
@@ -26,45 +28,68 @@ import           Universum
 
 import           CheckDir             (DirResult)
 import           Control.Concurrent   (modifyMVar_)
-import           Data.Aeson           (FromJSON, ToJSON (toJSON), eitherDecode,
-                                       (.=))
+import           Data.Aeson           (FromJSON, ToJSON (toJSON),
+                                       (.=), eitherDecodeFileStrict')
 import qualified Data.Aeson           as A
-import qualified Data.ByteString.Lazy as LB
 import qualified Data.Map             as M
 import           Data.UUID            (UUID)
+import Lens.Micro (traverseOf)
 import           Lens.Micro.TH
 import           LintConfig           (LintConfig')
-import           Toml                 (TomlCodec)
+import           Toml                 (TomlCodec, prettyTomlDecodeErrors)
 import qualified Toml                 as T
 
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
   { repourl :: Text
   , reporef :: Text
-  } deriving (Generic, FromJSON, ToJSON, Eq, Ord)
+  } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show)
 
 type family ConfigRes (b :: Bool) a where
   ConfigRes True a = a
   ConfigRes False a = FilePath
 
+
+data Org (loaded :: Bool) = Org
+  { orgSlug :: Text
+  , orgLintconfig :: ConfigRes loaded LintConfig'
+  , orgEntrypoint :: FilePath
+  , 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
   -- ^ port to bind to
-  , entrypoint :: FilePath
-  , lintconfig :: ConfigRes loaded LintConfig'
+  , _orgs       :: [Org loaded]
   } deriving Generic
 
+makeLenses ''Config
+
+
+remoteCodec :: TomlCodec RemoteRef
+remoteCodec = RemoteRef
+  <$> T.text "url" T..= repourl
+  <*> T.text "ref" T..= 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
+
+
 configCodec :: TomlCodec (Config False)
 configCodec = Config
-    <$> T.string "tmpdir" T..= tmpdir
-    <*> T.int "port" T..= port
-    <*> T.bool "verbose" T..= verbose
-    <*> T.string "entrypoint" T..= entrypoint
-    <*> T.string "lintconfig" T..= lintconfig
+    <$> T.string "tmpdir" T..= _tmpdir
+    <*> T.int "port" T..= _port
+    <*> T.bool "verbose" T..= _verbose
+    <*> T.list orgCodec "org" T..= _orgs
 
 -- | a job status (of a specific uuid)
 data JobStatus =
@@ -81,6 +106,8 @@ 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 }
 
@@ -92,24 +119,19 @@ instance ToJSON AdminOverview where
                , "status" .= M.lookup ref (view jobs state)
                ]
 
-
-
 loadConfig :: FilePath -> IO (Config True)
 loadConfig path = do
   res <- T.decodeFileEither configCodec path
   case res of
-    Right config -> loadConfig' config
-    Left err -> do
-      print err
-      exitFailure
-
-loadConfig' :: Config False -> IO (Config True)
-loadConfig' config = do
-  loaded <- LB.readFile (lintconfig config) >>= \res ->
-      case eitherDecode res :: Either String LintConfig' of
-        Left err   -> error $ "config file invalid: " <> show err
-        Right file -> pure file
-  pure $ config { lintconfig = loaded }
+    Right config -> traverseOf orgs (mapM loadOrg) config
+    Left err -> error $ prettyTomlDecodeErrors err
+    where
+      loadOrg :: Org False -> IO (Org True)
+      loadOrg org = do
+        lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
+          Right c -> pure c
+          Left err -> error $ show err
+        pure $ org { orgLintconfig = lintconfig }
 
 
 setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO ()
diff --git a/walint.cabal b/walint.cabal
index 5b82fec..a00fb6e 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -104,6 +104,7 @@ executable walint-server
     , filepath
     , http-types
     , lucid
+    , microlens
     , microlens-th
     , mtl
     , servant