non-blocking server

1 files changed, 21 insertions, 24 deletions

diff --git a/server/Main.hs b/server/Main.hs
index 77c8fde..33c2c5c 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,15 +1,8 @@
 {-# 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              #-}
@@ -18,16 +11,20 @@
 -- | simple server offering linting "as a service"
 module Main where
 
-import           CheckDir                   (DirResult)
 import           Cli.Extras                 (mkDefaultCliConfig, runCli)
+import           Control.Concurrent         (MVar, newMVar)
 import           Control.Monad.IO.Class     (liftIO)
 import qualified Data.ByteString.Lazy.Char8 as C8
-import           Data.Text                  (Text)
-import           Git                        (App, submitImpl)
+import           Handlers                   (App, statusImpl, submitImpl)
 import           Network.Wai.Handler.Warp   (run)
-import           Servant
-import           Serverconfig               (Config (..), RemoteRef (..),
-                                             loadConfig)
+import           Servant                    (Application, Get, Handler,
+                                             HasServer (ServerT), JSON,
+                                             Proxy (Proxy), ReqBody,
+                                             ServerError (errBody), err500,
+                                             hoistServer, serve, throwError,
+                                             type (:<|>) (..), type (:>), Post)
+import           Server                     (Config (..), JobStatus,
+                                             RemoteRef (..), State, loadConfig)
 
 {-
 Needed:
@@ -43,21 +40,20 @@ Needed:
 -}
 -- | Main API type
 type API format =
-       "submit" :> ReqBody '[JSON] RemoteRef :> Get '[format] DirResult
-  :<|> "status" :> Capture "sha1" Text :> Get '[format] [Int]
+       "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] ()
+  :<|> "status" :> ReqBody '[JSON] RemoteRef :> Get '[format] JobStatus
+
 
 -- | API's implementation
-jsonAPI :: Config True -> ServerT (API JSON) App
-jsonAPI config =
-  submitImpl config
-  :<|> (\sha -> do
-          liftIO $ print sha
-          pure [1])
+jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
+jsonAPI config state =
+  submitImpl config state
+  :<|> statusImpl state
 
 -- | make an application; convert any cli errors into a 500
-app :: Config True -> Application
+app :: Config True -> MVar State -> Application
 app config =
-  serve api $ hoistServer api conv (jsonAPI config)
+  serve api . hoistServer api conv . jsonAPI config
   where api = Proxy @(API JSON)
         conv :: App a -> Handler a
         conv m = do
@@ -69,6 +65,7 @@ app config =
 
 main :: IO ()
 main = do
+  state <- newMVar (mempty :: State)
   let config = Config "/tmp" 8080 "main.json" "./config.json"
   config' <- loadConfig config
-  run (port config) (app config')
+  run (port config) (app config' state)