summaryrefslogtreecommitdiff
path: root/server/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'server/Main.hs')
-rw-r--r--server/Main.hs74
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')