From cc52022f3b099287f0ac57eb514753202ef47db2 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Wed, 16 Feb 2022 19:38:08 +0100
Subject: [PATCH] server: post map updates to exneuland's API
---
config.toml | 1 +
package.yaml | 4 +++-
server/Main.hs | 55 ++++++++++++++++++++++++++++++++++++++----------
server/Server.hs | 29 ++++++++++++++++++-------
walint.cabal | 2 ++
5 files changed, 71 insertions(+), 20 deletions(-)
diff --git a/config.toml b/config.toml
index 1f0f349..cda774b 100644
--- a/config.toml
+++ b/config.toml
@@ -7,6 +7,7 @@ tmpdir = "/tmp"
# linting interval in seconds
interval = 30
+exneuland = "http://localhost:4000"
[[org]]
slug = "divoc"
diff --git a/package.yaml b/package.yaml
index 3bcac30..ac13e9a 100644
--- a/package.yaml
+++ b/package.yaml
@@ -66,11 +66,13 @@ executables:
- warp
- wai
- wai-extra
+ - lucid
- servant
- servant-server
- - lucid
+ - servant-client
- servant-lucid
- http-types
+ - http-client
- process
- extra
- microlens-platform
diff --git a/server/Main.hs b/server/Main.hs
index 660b69e..8ea59d6 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -10,7 +10,14 @@
-- | simple server offering linting "as a service"
module Main where
-import Universum
+import Universum (Container (length), IO,
+ MVar, Monad ((>>=)),
+ Num ((*)), Proxy (Proxy),
+ Text, atomically, forM_,
+ forever, map, newMVar,
+ print, putTextLn,
+ readMVar, view, void,
+ ($), (.))
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, link, waitEither_)
@@ -22,6 +29,8 @@ import Handlers (AdminOverview (AdminOverv
MapService (MapService),
stateImpl, statusImpl)
import HtmlOrphans ()
+import Network.HTTP.Client (defaultManagerSettings,
+ newManager)
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
import Network.Wai.Middleware.Gzip (def)
@@ -29,32 +38,42 @@ import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
- Get, JSON, Raw, Server,
- serve, type (:<|>) (..),
+ EmptyAPI, Get, JSON,
+ PlainText, Post, Raw,
+ ReqBody, Server, serve,
+ type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (JobStatus, Org (..),
ServerState, Sha1,
- emptyState, interval,
- loadConfig, orgs, port,
- unState, verbose)
+ emptyState, exneuland,
+ interval, loadConfig,
+ orgs, port, unState,
+ verbose)
import Worker (Job (Job), linterThread)
+import Servant.Client (BaseUrl (BaseUrl),
+ ClientM, Scheme (Http),
+ client, mkClientEnv,
+ runClientM)
--- | that thing we need to replace the hub
-type MapServiceAPI = "api" :> "maps" :> "list" :> Get '[JSON] MapService
+type family PolyEndpoint method format payload where
+ PolyEndpoint Get format payload = Get format payload
+ PolyEndpoint Post format payload = ReqBody format payload :> Post '[PlainText] Text
+
+
+type MapServiceAPI method =
+ "api" :> "maps" :> "list" :> PolyEndpoint method '[JSON] MapService
-- | abstract api
type API format =
- -- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
"status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus
- -- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
-- | actual set of routes: api for json & html + static pages from disk
type Routes = "api" :> API JSON
- :<|> MapServiceAPI
+ :<|> MapServiceAPI Get
:<|> API HTML -- websites mirror the API exactly
:<|> Raw
@@ -73,6 +92,9 @@ server state = jsonAPI @JSON state
app :: MVar ServerState -> Application
app = serve (Proxy @Routes) . server
+postNewMaps :: MapService -> ClientM Text
+postNewMaps = client (Proxy @(MapServiceAPI Post))
+
main :: IO ()
main = do
config <- loadConfig "./config.toml"
@@ -96,10 +118,21 @@ main = do
-- microseconds for some reason
threadDelay (view interval config * 1000000)
+ -- TODO: what about tls / https?
+ manager' <- newManager defaultManagerSettings
+ updater <- async $ forever $ do
+ done <- readMVar state
+ res <- runClientM
+ (postNewMaps (MapService done))
+ (mkClientEnv manager' (view exneuland config))
+ print res
+ threadDelay (view interval config * 1000000)
+
-- spawns threads for each job in the queue
linter <- async $ void $ linterThread config queue state
link linter
link poker
+ link updater
let warpsettings =
setPort (view port config)
diff --git a/server/Server.hs b/server/Server.hs
index bcb96a0..ef01b88 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -19,7 +19,7 @@
module Server ( loadConfig
, Org(..)
, Sha1
- , Config, tmpdir, port, verbose, orgs, interval
+ , Config, tmpdir, port, verbose, orgs, interval, exneuland
, RemoteRef(..)
, ServerState, emptyState, unState
, JobStatus(..)
@@ -29,6 +29,7 @@ module Server ( loadConfig
import Universum
import CheckDir (DirResult)
+import Control.Arrow ((>>>))
import Control.Concurrent (modifyMVar_, withMVar)
import Crypto.Hash.SHA1 (hash)
import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
@@ -40,9 +41,14 @@ import qualified Data.Map as M
import Lens.Micro.Platform (at, ix, makeLenses, traverseOf)
import LintConfig (LintConfig')
import Servant (FromHttpApiData)
-import Toml (TomlCodec, prettyTomlDecodeErrors,
- (.=))
+import Servant.Client (BaseUrl,
+ parseBaseUrl)
+import Toml (BiMap (BiMap), TomlBiMap,
+ TomlBiMapError (ArbitraryError),
+ TomlCodec,
+ prettyTomlDecodeErrors, (.=))
import qualified Toml as T
+import Data.Either.Extra (mapLeft)
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
@@ -103,13 +109,14 @@ instance ToJSONKey (Org True) where
-- | the server's configuration
data Config (loaded :: Bool) = Config
- { _tmpdir :: FilePath
+ { _tmpdir :: FilePath
-- ^ dir to clone git things in
- , _port :: Int
- , _verbose :: Bool
- , _interval :: Int
+ , _port :: Int
+ , _verbose :: Bool
+ , _interval :: Int
-- ^ port to bind to
- , _orgs :: [Org loaded]
+ , _exneuland :: BaseUrl
+ , _orgs :: [Org loaded]
} deriving Generic
makeLenses ''Config
@@ -130,6 +137,11 @@ orgCodec = Org
<*> T.text "url" .= orgUrl
<*> T.text "webdir" .= orgWebdir
+-- why exactly does everything in tomland need to be invertable
+urlBimap :: TomlBiMap BaseUrl String
+urlBimap = BiMap
+ (Right . show)
+ (mapLeft (ArbitraryError . show) . parseBaseUrl)
configCodec :: TomlCodec (Config False)
configCodec = Config
@@ -137,6 +149,7 @@ configCodec = Config
<*> T.int "port" .= _port
<*> T.bool "verbose" .= _verbose
<*> T.int "interval" .= _interval
+ <*> T.match (urlBimap >>> T._String) "exneuland" .= _exneuland
<*> T.list orgCodec "org" .= _orgs
-- | a job status (of a specific uuid)
diff --git a/walint.cabal b/walint.cabal
index e721b0d..c2a19a1 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -105,12 +105,14 @@ executable walint-server
, extra
, filepath
, fmt
+ , http-client
, http-types
, lucid
, microlens-platform
, mtl
, process
, servant
+ , servant-client
, servant-lucid
, servant-server
, stm
--
GitLab