summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/Git.hs60
-rw-r--r--server/Main.hs74
-rw-r--r--server/Serverconfig.hs45
3 files changed, 179 insertions, 0 deletions
diff --git a/server/Git.hs b/server/Git.hs
new file mode 100644
index 0000000..e32d801
--- /dev/null
+++ b/server/Git.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Git (App, submitImpl) where
+
+import Bindings.Cli.Git (gitProc)
+import CheckDir (DirResult, recursiveCheckDir)
+import Cli.Extras (CliT, ProcessFailure, Severity (..),
+ callProcessAndLogOutput)
+import Control.Monad.Extra (ifM)
+import Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Servant
+import Serverconfig
+import System.Directory (doesDirectoryExist)
+import System.FilePath ((</>))
+
+
+-- | this servant app can run cli programs!
+type App = CliT ProcessFailure Handler
+
+-- | annoying (and afaik unused), but has to be here for type system reasons
+instance MonadFail Handler where
+ fail _ = throwError $ err500
+
+-- | someone submitted a map; lint it (synchronously for now)
+submitImpl :: Config True -> RemoteRef -> App DirResult
+submitImpl config ref = do
+ ifM (liftIO $ doesDirectoryExist gitdir)
+ (callProcessAndLogOutput (Debug, Error) gitfetch)
+ (callProcessAndLogOutput (Debug, Error) gitclone)
+ checkPath config gitdir (reporef ref)
+ where gitclone = gitProc gitdir -- TODO: these calls fail for dumb http, add some fallback!
+ [ "clone", T.unpack $ repourl ref, "--bare", "--depth", "1", "-b", T.unpack (reporef ref)]
+ gitfetch = gitProc gitdir
+ [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ]
+ gitdir = tmpdir config </> hashedname
+ hashedname = fmap escapeSlash . T.unpack . repourl $ ref
+ escapeSlash = \case
+ '/' -> '-'
+ a -> a
+
+checkPath :: Config True -> FilePath -> Text -> App DirResult
+checkPath config gitdir ref = do
+ rand <- liftIO $ UUID.nextRandom
+ let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
+ callProcessAndLogOutput (Debug, Error)
+ $ gitProc gitdir [ "worktree", "add", workdir ]
+ callProcessAndLogOutput (Debug, Error)
+ $ gitProc workdir [ "checkout", T.unpack ref ]
+ res <- liftIO $ recursiveCheckDir (lintconfig config) gitdir (entrypoint config)
+ callProcessAndLogOutput (Debug, Error)
+ $ gitProc gitdir [ "worktree", "remove", "-f", "-f", workdir ]
+ pure res
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')
diff --git a/server/Serverconfig.hs b/server/Serverconfig.hs
new file mode 100644
index 0000000..d919567
--- /dev/null
+++ b/server/Serverconfig.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Serverconfig (loadConfig, Config(..), RemoteRef(..)) where
+
+import Data.Aeson (FromJSON, eitherDecode)
+import qualified Data.ByteString.Lazy as LB
+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)
+
+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'
+ }
+
+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 }