diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Git.hs | 60 | ||||
| -rw-r--r-- | server/Main.hs | 74 | ||||
| -rw-r--r-- | server/Serverconfig.hs | 45 |
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 } |