server: post map updates to exneuland's API

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)