basic server setup (using servant)

adds a very basic http server that can be sent links to repositories &
will download & lint them, then answer the request with the lints.

Should probably do this in a non-blocking way …

1 files changed, 74 insertions, 0 deletions

diff --git a/server/Main.hs b/server/Main.hs
new file mode 100644
index 0000000..77c8fde
--- /dev/null
+++ b/server/Main.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+
+
+-- | simple server offering linting "as a service"
+module Main where
+
+import           CheckDir                   (DirResult)
+import           Cli.Extras                 (mkDefaultCliConfig, runCli)
+import           Control.Monad.IO.Class     (liftIO)
+import qualified Data.ByteString.Lazy.Char8 as C8
+import           Data.Text                  (Text)
+import           Git                        (App, submitImpl)
+import           Network.Wai.Handler.Warp   (run)
+import           Servant
+import           Serverconfig               (Config (..), RemoteRef (..),
+                                             loadConfig)
+
+{-
+Needed:
+ - admin overview (perhaps on seperate port?)
+ - in json:
+   - submit a repository link & ref name, get back job id
+   - look up a lint status by job id
+ - in html
+   - look up a lint status, pretty-printed
+   - front page with overview & links
+   - possibly a "update & relint" button?
+   - links to documentation
+-}
+-- | Main API type
+type API format =
+       "submit" :> ReqBody '[JSON] RemoteRef :> Get '[format] DirResult
+  :<|> "status" :> Capture "sha1" Text :> Get '[format] [Int]
+
+-- | API's implementation
+jsonAPI :: Config True -> ServerT (API JSON) App
+jsonAPI config =
+  submitImpl config
+  :<|> (\sha -> do
+          liftIO $ print sha
+          pure [1])
+
+-- | make an application; convert any cli errors into a 500
+app :: Config True -> Application
+app config =
+  serve api $ hoistServer api conv (jsonAPI config)
+  where api = Proxy @(API JSON)
+        conv :: App a -> Handler a
+        conv m = do
+          config <- liftIO $ mkDefaultCliConfig []
+          res <- runCli config m
+          case res of
+            Right a  -> pure a
+            Left err -> throwError (err500 { errBody = C8.pack (show err) })
+
+main :: IO ()
+main = do
+  let config = Config "/tmp" 8080 "main.json" "./config.json"
+  config' <- loadConfig config
+  run (port config) (app config')