server: post map updates to exneuland's API

1 files changed, 44 insertions, 11 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)