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

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

import           Universum

import           CheckDir                      (recursiveCheckDir)
import           Control.Concurrent.Async      (async, link)
import           Control.Concurrent.STM.TQueue
import           Control.Exception             (IOException, handle)
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               ((</>))
import           System.Process


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

linterThread :: Config True -> TQueue Job -> MVar ServerState -> IO Void
linterThread config 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 done
  -- TODO: is this a good idea? will crash the server if a job thread fails
  link job

-- | the actual check function. Calls out to git to update the
-- repository, create a new worktree, lints it, then tells git to
-- delete that tree again.
--
-- May occasionally be brittle (if someone else changed files)
-- TODO: re-add proper fancy (colourful?) logging
runJob :: Config True -> Job -> MVar ServerState -> IO ()
runJob config Job {..} done = do
  rand <- liftIO UUID.nextRandom
  let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)

  handle whoops
    $ finally (lint workdir) (cleanup workdir)
  where
    lint workdir = do
      ifM (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])
      rev <- map T.strip -- git returns a newline here
        $ readgit' gitdir ["rev-parse", toString ref]
      callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
      res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
      setJobStatus done jobOrg jobRef $
        Linted res rev

    cleanup workdir = do
      callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]

    whoops (error :: IOException) = do
      -- TODO: should also log this error
      setJobStatus done jobOrg jobRef $ Failed (show error)

    url = repourl jobRef
    ref = reporef jobRef
    callgit = callgit'
    gitdir = view tmpdir config </> toString hashedname
    hashedname = T.map escapeSlash url
      where escapeSlash = \case { '/' -> '-'; a -> a }

readgit' :: MonadIO m => FilePath -> [String] -> m Text
readgit' dir args = map toText $
  liftIO $ do
    print args
    readProcess "git" ([ "-C", toString dir ] <> args) ""

callgit' :: MonadIO m => FilePath -> [String] -> m ()
callgit' dir args =
  liftIO $ do
    print args
    callProcess "git" ([ "-C", toString dir ] <> args)