From 24e5ccd98aa33250327d36e3859c461699026859 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 7 Feb 2022 16:05:55 +0100
Subject: non-blocking server

---
 server/Git.hs | 60 -----------------------------------------------------------
 1 file changed, 60 deletions(-)
 delete mode 100644 server/Git.hs

(limited to 'server/Git.hs')

diff --git a/server/Git.hs b/server/Git.hs
deleted file mode 100644
index e32d801..0000000
--- a/server/Git.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# 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