server: repositores & orgs fixed in config

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

1 files changed, 60 insertions, 62 deletions

diff --git a/server/Main.hs b/server/Main.hs
index 04a2010..02f7ed3 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE TypeFamilies      #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 
 -- | simple server offering linting "as a service"
@@ -11,14 +12,16 @@ module Main where
 
 import           Universum
 
-import           Cli.Extras                           (CliConfig,
-                                                       mkDefaultCliConfig,
-                                                       runCli)
-import qualified Data.ByteString.Lazy.Char8           as C8
-import           Data.UUID                            (UUID)
-import           Handlers                             (App, adminOverviewImpl,
-                                                        statusImpl,
-                                                       )
+import           Cli.Extras                           (mkDefaultCliConfig)
+import           Control.Concurrent                   (threadDelay)
+import           Control.Concurrent.Async             (async, waitEither_)
+import           Control.Concurrent.STM.TQueue        (TQueue, newTQueueIO,
+                                                       writeTQueue)
+import qualified Data.Text                            as T
+import           Fmt                                  ((+|), (|+))
+import           Handlers                             (AdminOverview,
+                                                       adminOverviewImpl,
+                                                       statusImpl)
 import           HtmlOrphans                          ()
 import           Network.Wai.Handler.Warp             (defaultSettings,
                                                        runSettings, setPort)
@@ -27,78 +30,68 @@ import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
                                                        RequestLoggerSettings (..),
                                                        mkRequestLogger)
 import           Servant                              (Application, Capture,
-                                                       Get, Handler,
-                                                       HasServer (ServerT),
-                                                       JSON, NoContent, Post,
-                                                       Raw, ReqBody,
-                                                       ServerError (errBody),
-                                                       err500, hoistServer,
-                                                       serve, throwError,
-                                                       type (:<|>) (..),
+                                                       Get, JSON, Raw, Server,
+                                                       serve, type (:<|>) (..),
                                                        type (:>))
 import           Servant.HTML.Lucid                   (HTML)
 import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
-import           Server                               (AdminOverview,
-                                                       Config (..), JobStatus,
-                                                       RemoteRef (..),
-                                                       ServerState,
-                                                       defaultState, loadConfig, verbose, port, orgs, Org (orgEntrypoint, orgRepos))
+import           Server                               (JobStatus, Org (..),
+                                                       ServerState, Sha1,
+                                                       defaultState, interval,
+                                                       loadConfig, orgs, port,
+                                                       verbose)
+import           Worker                               (Job (Job), linterThread)
 
 
 -- | Main API type
 type API format =
        -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
-       "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
+       "status" :> Capture "jobid" Sha1 :> Get '[format] JobStatus
   -- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
   :<|> "admin" :> "overview" :> Get '[format] AdminOverview
 
-type Routes =
-   "api" :> API JSON
-  :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
-  :<|> "admin" :> "overview" :> Get '[HTML] AdminOverview
-  :<|> Raw
+type Routes = "api" :> API JSON
+         :<|> API HTML -- websites mirror the API exactly
+         :<|> Raw
 
 -- | API's implementation
-jsonAPI :: Config True -> MVar ServerState -> ServerT (API JSON) App
-jsonAPI config state =
-  -- submitImpl config state
-       statusImpl state
-  -- :<|> relintImpl config state
-  :<|> adminOverviewImpl state
-
-server :: Config True -> MVar ServerState -> ServerT Routes App
-server config state =
-  jsonAPI config state
-  :<|> statusImpl state
-  :<|> adminOverviewImpl state
-  :<|> serveDirectoryWebApp "./static"
-
--- | make an application; convert any cli errors into a 500
-app :: CliConfig -> Config True -> MVar ServerState -> Application
-app cliconfig config =
-  serve api . hoistServer api conv . server config
-  where api = Proxy @Routes
-        conv :: App a -> Handler a
-        conv m = do
-          res <- runCli cliconfig m
-          case res of
-            Right a  -> pure a
-            Left err -> throwError (err500 { errBody = C8.pack (show err) })
+jsonAPI :: forall format. MVar ServerState -> Server (API format)
+jsonAPI state = statusImpl state
+           :<|> adminOverviewImpl state
 
+-- | Complete set of routes: API + HTML sites
+server :: MVar ServerState -> Server Routes
+server state = jsonAPI @JSON state
+          :<|> jsonAPI @HTML state
+          :<|> serveDirectoryWebApp "./static"
+
+app :: MVar ServerState -> Application
+app = serve (Proxy @Routes) . server
 
 main :: IO ()
 main = do
   config <- loadConfig "./config.toml"
   state <- newMVar defaultState
+  queue :: TQueue Job <- newTQueueIO
   -- TODO: i really don't like all this cli logging stuff, replace it with
   -- fast-logger at some point …
   cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config]
   loggerMiddleware <- mkRequestLogger
     $ def { outputFormat = Detailed (view verbose config) }
 
-  -- print (keys $ view orgs config)
-  print (map orgEntrypoint $ view orgs config)
-  print (map orgRepos $ view orgs config)
+  putTextLn "reading config …"
+  putTextLn $ T.concat $ map showInfo (view orgs config)
+
+  -- periodically ‘pokes’ jobs to re-lint each repo
+  poker <- async $ forever $ do
+    atomically $ forM_ (view orgs config) $ \org ->
+      forM_ (orgRepos org) $ \repo ->
+        writeTQueue queue (Job repo org)
+    -- microseconds for some reason
+    threadDelay (view interval config * 1000000)
+
+  -- spawns threads for each job in the queue
+  linter <- async $ void $ linterThread config cliconfig queue state
 
   let warpsettings =
        setPort (view port config)
@@ -106,4 +99,9 @@ main = do
 
   runSettings warpsettings
     . loggerMiddleware
-    $ app cliconfig config state
+    $ app state
+
+  waitEither_ linter poker
+  where
+    showInfo org =
+      "→ org "+|orgSlug org|+" divoc ("+|length (orgRepos org)|+" repositoryies)\n" :: Text