diff --git a/package.yaml b/package.yaml
index b3684cd8fc3d63c2848dda5783ab7501ee49ef55..95ed5fb420b77dd2d7bd4579b7259ea438734899 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 0000000000000000000000000000000000000000..e32d801cfae22d83c66e53f3dd5970f43eb2c829
--- /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 0000000000000000000000000000000000000000..77c8fdee8d26879f46a3527c23848fe70e2d082e
--- /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 0000000000000000000000000000000000000000..d91956784f6e768c662000972fce72bfee050692
--- /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 }
diff --git a/stack.yaml b/stack.yaml
index 50475b04903540511cd95275cb88e6ffb880ba29..738b3ad80d8c6fec9884f0bca77c20e3bd41ea6b 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -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 77b02f5aa665652dd7a9b44615878969c71273ce..a7bbaf3d43970949e3566f9fcc7bce58f49d4d47 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 73c5fd04bb8c3e0e821eca02c29a85250ed03ea3..096d396be578f2307fbf70c533535e163cf7809c 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