{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Worker (linterThread, Job(..)) where

import           Universum

import           Bindings.Cli.Git              (gitProc)
import           CheckDir                      (recursiveCheckDir)
import           Cli.Extras                    (CliConfig, ProcessFailure,
                                                Severity (..),
                                                callProcessAndLogOutput,
                                                prettyProcessFailure, runCli)
import           Control.Concurrent.Async      (async, link)
import           Control.Concurrent.STM.TQueue
import qualified Data.Text                     as T
import qualified Data.UUID                     as UUID
import qualified Data.UUID.V4                  as UUID
import           Server                        (Config, JobStatus (..),
                                                Org (..),
                                                RemoteRef (reporef, repourl),
                                                ServerState, setJobStatus,
                                                tmpdir)
import           System.Directory              (doesDirectoryExist)
import           System.FilePath               ((</>))



data Job = Job
  { jobRef :: RemoteRef
  , jobOrg :: Org True
  }

linterThread :: Config True -> CliConfig -> TQueue Job -> MVar ServerState -> IO Void
linterThread config cliconfig queue done = forever $ do
  next <- atomically (readTQueue queue)
  -- TODO: this doesn't guard against two jobs running on the same repo!
  job <- async $ runJob config next cliconfig done
  link job -- TODO: is this a good idea? will crash the server if a job fails

-- | the actual check function. forks, calls out to git to update the
-- repository, create a new worktree, lints it, then tells git to
-- delete that tree again
runJob :: Config True -> Job -> CliConfig -> MVar ServerState -> IO (Either ProcessFailure ())
runJob config Job {..} cliconfig done = runCli cliconfig $ do
    res <- liftIO $ runCli cliconfig $ do
      ifM (liftIO $ doesDirectoryExist gitdir)
        -- TODO: these calls fail for dumb http, add some fallback!
        (callgit gitdir
         [ "fetch", "origin", toString ref, "--depth", "1" ])
        (callgit gitdir
         [ "clone", toString ref, "--bare"
         , "--depth", "1", "-b", toString ref])
      rand <- liftIO UUID.nextRandom
      let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
      callgit gitdir [ "worktree", "add", workdir ]
      callgit workdir [ "checkout", toString ref ]
      res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
      callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
      pure res
    liftIO $ setJobStatus done jobRef $ case res of
      Right res -> Linted res
      Left err  -> Failed (prettyProcessFailure err)
  where
    url = repourl jobRef
    ref = reporef jobRef
    callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
    gitdir = view tmpdir config </> toString hashedname
    hashedname = T.map escapeSlash url
      where escapeSlash = \case { '/' -> '-'; a -> a }