diff options
| -rw-r--r-- | config.toml | 1 | ||||
| -rw-r--r-- | package.yaml | 4 | ||||
| -rw-r--r-- | server/Main.hs | 55 | ||||
| -rw-r--r-- | server/Server.hs | 29 | ||||
| -rw-r--r-- | walint.cabal | 2 |
5 files changed, 71 insertions, 20 deletions
diff --git a/config.toml b/config.toml index 1f0f349..cda774b 100644 --- a/config.toml +++ b/config.toml @@ -7,6 +7,7 @@ tmpdir = "/tmp" # linting interval in seconds interval = 30 +exneuland = "http://localhost:4000" [[org]] slug = "divoc" diff --git a/package.yaml b/package.yaml index 3bcac30..ac13e9a 100644 --- a/package.yaml +++ b/package.yaml @@ -66,11 +66,13 @@ executables: - warp - wai - wai-extra + - lucid - servant - servant-server - - lucid + - servant-client - servant-lucid - http-types + - http-client - process - extra - microlens-platform 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) diff --git a/walint.cabal b/walint.cabal index e721b0d..c2a19a1 100644 --- a/walint.cabal +++ b/walint.cabal @@ -105,12 +105,14 @@ executable walint-server , extra , filepath , fmt + , http-client , http-types , lucid , microlens-platform , mtl , process , servant + , servant-client , servant-lucid , servant-server , stm |