From 1ff03848753ed4881d02289ca9236ad4d2e2853a Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 20:28:46 +0100
Subject: server: exneuland wants a token, apparently

---
 server/Main.hs   | 20 +++++++-------------
 server/Server.hs | 15 +++++++++------
 2 files changed, 16 insertions(+), 19 deletions(-)

(limited to 'server')

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)
-- 
cgit v1.2.3