basic server setup (using servant)

adds a very basic http server that can be sent links to repositories &
will download & lint them, then answer the request with the lints.

Should probably do this in a non-blocking way …

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 }