diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Main.hs | 55 | ||||
| -rw-r--r-- | server/Server.hs | 29 |
2 files changed, 65 insertions, 19 deletions
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) |