diff options
| -rw-r--r-- | package.yaml | 22 | ||||
| -rw-r--r-- | server/Git.hs | 60 | ||||
| -rw-r--r-- | server/Main.hs | 74 | ||||
| -rw-r--r-- | server/Serverconfig.hs | 45 | ||||
| -rw-r--r-- | stack.yaml | 12 | ||||
| -rw-r--r-- | stack.yaml.lock | 28 | ||||
| -rw-r--r-- | walint.cabal | 36 |
7 files changed, 274 insertions, 3 deletions
diff --git a/package.yaml b/package.yaml index b3684cd..95ed5fb 100644 --- a/package.yaml +++ b/package.yaml @@ -43,10 +43,30 @@ executables: walint: main: Main.hs source-dirs: 'src' - build-tools: hspec-discover dependencies: - walint - getopt-generics - aeson-pretty - template-haskell - process + server: + main: Main.hs + source-dirs: 'server' + dependencies: + - time + - servant + - servant-server + - wai + - base-compat + - string-conversions + - http-media + - warp + - cli-git + - cli-extras + - filepath + - logging-effect + - process + - extra + - directory + - walint + - uuid 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 } @@ -23,6 +23,10 @@ extra-deps: - text-short-0.1.4@sha256:4f7a76e78baf391d262883007e8f8d8fb23a2805d56d9725d6abdf1428542e11,3575 - time-compat-1.9.6.1@sha256:381a2e8ed6e41d20ff5929d12d25c1d9337d459de5964ef1d90b06d115b31f07,5033 - HList-0.5.1.0@sha256:3ecb2d10ad2b3d36ad28e2f08505f9c3d7143ca737ef13b3e64db503635966c2,7525 + - cli-extras-0.1.0.2@sha256:404552a3e5e844f332fcf74858999b9b9b6d5dcab6017a9d5a48868715a21468,1996 + - logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679 + - which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858 + - cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 allow-newer: true @@ -31,3 +35,11 @@ flags: aeson: ordered-keymap: true +nix: + enable: true + packages: + - zlib.dev + - zlib + - openssl + - git + - cacert diff --git a/stack.yaml.lock b/stack.yaml.lock index 77b02f5..a7bbaf3 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -46,6 +46,34 @@ packages: sha256: fe9d53555847bd16ffd46e3fb6013751c23f375a95d05b4d4c8de0bb22911e72 original: hackage: HList-0.5.1.0@sha256:3ecb2d10ad2b3d36ad28e2f08505f9c3d7143ca737ef13b3e64db503635966c2,7525 +- completed: + hackage: cli-extras-0.1.0.2@sha256:404552a3e5e844f332fcf74858999b9b9b6d5dcab6017a9d5a48868715a21468,1996 + pantry-tree: + size: 849 + sha256: 0f78dd9ad144dd81d2567ff0c47c111e2764db1b48341b34a2026018fb7f01ff + original: + hackage: cli-extras-0.1.0.2@sha256:404552a3e5e844f332fcf74858999b9b9b6d5dcab6017a9d5a48868715a21468,1996 +- completed: + hackage: logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679 + pantry-tree: + size: 330 + sha256: 3907e21147987af4f1590abce025e7439f0d338444f259791068c361d586117f + original: + hackage: logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679 +- completed: + hackage: which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858 + pantry-tree: + size: 262 + sha256: bef8458bddea924f3162e51fcef66cb3071f73c31d3dbb6d4029b0115af88a54 + original: + hackage: which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858 +- completed: + hackage: cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 + pantry-tree: + size: 269 + sha256: 1e81c51e2b60db2b1784901cf0af33c67384f5412ad8edaad8a7068135f5217f + original: + hackage: cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 snapshots: - completed: size: 586286 diff --git a/walint.cabal b/walint.cabal index 73c5fd0..096d396 100644 --- a/walint.cabal +++ b/walint.cabal @@ -57,11 +57,43 @@ library , witherable default-language: Haskell2010 +executable server + main-is: Main.hs + other-modules: + Git + Serverconfig + Paths_walint + hs-source-dirs: + server + ghc-options: -Wall -Wno-name-shadowing + build-depends: + aeson + , base + , base-compat + , bytestring + , cli-extras + , cli-git + , directory + , extra + , filepath + , http-media + , logging-effect + , mtl + , process + , servant + , servant-server + , string-conversions + , text + , time + , uuid + , wai + , walint + , warp + default-language: Haskell2010 + executable walint main-is: Main.hs ghc-options: -Wall -Wno-name-shadowing - build-tool-depends: - hspec-discover:hspec-discover build-depends: aeson , aeson-pretty |