From 2ce9a23fe7de72f4c8bf33a8c26f555cf08f8715 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Tue, 1 Feb 2022 00:30:13 +0100
Subject: 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 …
---
 server/Git.hs | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 60 insertions(+)
 create mode 100644 server/Git.hs

(limited to 'server/Git.hs')

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
-- 
cgit v1.2.3