non-blocking server

1 files changed, 61 insertions, 0 deletions

diff --git a/server/Server.hs b/server/Server.hs
new file mode 100644
index 0000000..41e5bde
--- /dev/null
+++ b/server/Server.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Server (loadConfig, Config(..), RemoteRef(..), State, JobStatus(..),
+                    setJobStatus) where
+
+import           CheckDir             (DirResult)
+import           Control.Concurrent   (MVar, modifyMVar_)
+import           Data.Aeson           (FromJSON, ToJSON, eitherDecode)
+import qualified Data.ByteString.Lazy as LB
+import           Data.Map             (Map)
+import qualified Data.Map             as M
+import           Data.Text            (Text)
+import           GHC.Generics         (Generic)
+import           LintConfig           (LintConfig')
+
+-- | a reference in a remote git repository
+data RemoteRef = RemoteRef
+  { repourl :: Text
+  , reporef :: Text
+  } deriving (Generic, FromJSON, Eq, Ord)
+
+type family ConfigRes (b :: Bool) a where
+  ConfigRes True a = a
+  ConfigRes False a = FilePath
+
+-- | the server's configuration
+data Config l = Config
+  { tmpdir     :: FilePath
+  -- ^ dir to clone git things in
+  , port       :: Int
+  -- ^ port to bind to
+  , entrypoint :: FilePath
+  , lintconfig :: ConfigRes l LintConfig'
+  }
+
+data JobStatus =
+  Pending | Linted DirResult | Failed Text
+  deriving (Generic, ToJSON)
+
+type State = Map RemoteRef JobStatus
+
+
+loadConfig :: Config False -> IO (Config True)
+loadConfig config = do
+  loaded <- LB.readFile (lintconfig config) >>= \res ->
+      case eitherDecode res :: Either String LintConfig' of
+        Left err   -> error $ "config file invalid: " <> err
+        Right file -> pure file
+  pure $ config { lintconfig = loaded }
+
+
+setJobStatus :: MVar State -> RemoteRef -> JobStatus -> IO ()
+setJobStatus mvar ref status = modifyMVar_ mvar $ \state ->
+  pure $ M.insert ref status state