From 1ff03848753ed4881d02289ca9236ad4d2e2853a Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Wed, 16 Feb 2022 20:28:46 +0100
Subject: [PATCH] server: exneuland wants a token, apparently
---
config.toml | 1 +
server/Main.hs | 20 +++++++-------------
server/Server.hs | 15 +++++++++------
3 files changed, 17 insertions(+), 19 deletions(-)
diff --git a/config.toml b/config.toml
index cda774b..0518962 100644
--- a/config.toml
+++ b/config.toml
@@ -8,6 +8,7 @@ tmpdir = "/tmp"
# linting interval in seconds
interval = 30
exneuland = "http://localhost:4000"
+token = "hello, world!"
[[org]]
slug = "divoc"
diff --git a/server/Main.hs b/server/Main.hs
index 8ea59d6..1a18c6a 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -10,14 +10,7 @@
-- | simple server offering linting "as a service"
module Main where
-import Universum (Container (length), IO,
- MVar, Monad ((>>=)),
- Num ((*)), Proxy (Proxy),
- Text, atomically, forM_,
- forever, map, newMVar,
- print, putTextLn,
- readMVar, view, void,
- ($), (.))
+import Universum
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, link, waitEither_)
@@ -49,10 +42,11 @@ import Server (JobStatus, Org (..),
ServerState, Sha1,
emptyState, exneuland,
interval, loadConfig,
- orgs, port, unState,
- verbose)
+ orgs, port, token,
+ unState, verbose)
import Worker (Job (Job), linterThread)
+import Servant.API (Header)
import Servant.Client (BaseUrl (BaseUrl),
ClientM, Scheme (Http),
client, mkClientEnv,
@@ -60,7 +54,7 @@ import Servant.Client (BaseUrl (BaseUrl),
type family PolyEndpoint method format payload where
PolyEndpoint Get format payload = Get format payload
- PolyEndpoint Post format payload = ReqBody format payload :> Post '[PlainText] Text
+ PolyEndpoint Post format payload = Header "Auth" Text :> ReqBody format payload :> Post '[PlainText] Text
type MapServiceAPI method =
@@ -92,7 +86,7 @@ server state = jsonAPI @JSON state
app :: MVar ServerState -> Application
app = serve (Proxy @Routes) . server
-postNewMaps :: MapService -> ClientM Text
+postNewMaps :: Maybe Text -> MapService -> ClientM Text
postNewMaps = client (Proxy @(MapServiceAPI Post))
main :: IO ()
@@ -123,7 +117,7 @@ main = do
updater <- async $ forever $ do
done <- readMVar state
res <- runClientM
- (postNewMaps (MapService done))
+ (postNewMaps (view token config) (MapService done))
(mkClientEnv manager' (view exneuland config))
print res
threadDelay (view interval config * 1000000)
diff --git a/server/Server.hs b/server/Server.hs
index ef01b88..8f09ac7 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -19,7 +19,7 @@
module Server ( loadConfig
, Org(..)
, Sha1
- , Config, tmpdir, port, verbose, orgs, interval, exneuland
+ , Config, tmpdir, port, verbose, orgs, interval, exneuland, token
, RemoteRef(..)
, ServerState, emptyState, unState
, JobStatus(..)
@@ -36,19 +36,19 @@ import Data.Aeson (FromJSON, ToJSON, ToJSONKey (..),
eitherDecodeFileStrict')
import qualified Data.Aeson as A
import qualified Data.ByteString.Base64.URL as Base64
+import Data.Coerce (coerce)
+import Data.Either.Extra (mapLeft)
import Data.Functor.Contravariant (contramap)
import qualified Data.Map as M
import Lens.Micro.Platform (at, ix, makeLenses, traverseOf)
import LintConfig (LintConfig')
import Servant (FromHttpApiData)
-import Servant.Client (BaseUrl,
- parseBaseUrl)
+import Servant.Client (BaseUrl, parseBaseUrl)
import Toml (BiMap (BiMap), TomlBiMap,
TomlBiMapError (ArbitraryError),
- TomlCodec,
- prettyTomlDecodeErrors, (.=))
+ TomlCodec, prettyTomlDecodeErrors,
+ (.=))
import qualified Toml as T
-import Data.Either.Extra (mapLeft)
-- | a reference in a remote git repository
data RemoteRef = RemoteRef
@@ -116,6 +116,7 @@ data Config (loaded :: Bool) = Config
, _interval :: Int
-- ^ port to bind to
, _exneuland :: BaseUrl
+ , _token :: Maybe Text
, _orgs :: [Org loaded]
} deriving Generic
@@ -150,6 +151,8 @@ configCodec = Config
<*> T.bool "verbose" .= _verbose
<*> T.int "interval" .= _interval
<*> T.match (urlBimap >>> T._String) "exneuland" .= _exneuland
+ -- First is just Maybe but with different semantics
+ <*> coerce (T.first T.text "token") .= _token
<*> T.list orgCodec "org" .= _orgs
-- | a job status (of a specific uuid)
--
GitLab