diff options
| -rw-r--r-- | config.toml | 1 | ||||
| -rw-r--r-- | server/Main.hs | 20 | ||||
| -rw-r--r-- | 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) |