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

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

import           Universum

import           CheckDir                      (recursiveCheckDir,
                                                shrinkDirResult, resultIsFatal)
import           Control.Concurrent.Async      (async, link)
import           Control.Concurrent.STM        (writeTChan)
import           Control.Concurrent.STM.TQueue
import           Control.Exception             (IOException, handle)
import           Control.Monad.Logger          (logError, logErrorN, logInfoN,
                                                runStdoutLoggingT)
import qualified Data.Text                     as T
import qualified Data.UUID                     as UUID
import qualified Data.UUID.V4                  as UUID
import           Fmt                           ((+|), (|+))
import           LintConfig                    (stuffConfig)
import           Server                        (Config, JobStatus (..),
                                                Org (..),
                                                RealtimeMsg (RelintPending, Reload),
                                                RemoteRef (..), ServerState,
                                                adjustedPath,
                                                newRealtimeChannel,
                                                tmpdir, overJobStatus)
import           System.Directory              (doesDirectoryExist)
import           System.Exit                   (ExitCode (ExitFailure, ExitSuccess))
import           System.FilePath               ((</>))
import           System.Process
import           WriteRepo                     (writeAdjustedRepository)

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 <- UUID.nextRandom
  let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)

  handle whoops
    $ finally (lint workdir) (cleanup workdir)
  where
    lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef)
    lint workdir = do

      -- set the "is being linted" flag in the assembly's state
      -- (to show on the site even after reloads etc.)
      oldstate <- overJobStatus done jobOrg jobRef $ \case
        Just (ref, Linted res rev (_, realtime), oldstatus) ->
          Just (ref, Linted res rev (True, realtime), oldstatus)
        a -> a

      -- send an update message to all connected websocket clients
      maybeRealtime <- case oldstate of
        Just (_, Linted _ _ (_, realtime), _) -> do
          atomically $ writeTChan realtime RelintPending
          pure (Just realtime)
        _ -> pure Nothing

      ifM (doesDirectoryExist gitdir)
        -- TODO: these calls fail for dumb http, add some fallback!
        (callgit gitdir
         [ "fetch", "origin", toString ref, "--depth", "1" ])
        (callProcess "git"
         [ "clone", toString url, "--bare"
         , "--depth", "1", "-b", toString ref, gitdir])
      rev <- map T.strip -- git returns a newline here
        $ readgit' gitdir ["rev-parse", toString ref]

      let outPath = adjustedPath rev jobOrg

      callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]

      res <- recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg)
               >>= evaluateNF

      writeAdjustedRepository lintConfig workdir (toString outPath) res
        >>= runStdoutLoggingT . \case
        ExitSuccess ->
          logInfoN $ "linted map "+| (show jobRef :: Text) |+"."
        ExitFailure 1 ->
          logInfoN $ "linted map "+| (show jobRef :: Text) |+ ", which failed."
        ExitFailure 2 ->
          -- TODO: shouldn't have linted this map at all
          logErrorN $ "outpath "+|outPath|+" already exists!"
        ExitFailure _ ->
          -- writeAdjustedRepository does not return other codes
          $(logError) "wtf, this is impossible"

      realtime <- case maybeRealtime of
        Just realtime -> do
          atomically $ writeTChan realtime Reload
          pure realtime
        Nothing ->
          newRealtimeChannel

      -- the fact that `realtime` can't be defined in here is horrifying
      void $ overJobStatus done jobOrg jobRef $ \maybeOld ->
        let status = Linted (shrinkDirResult res) rev (False, realtime)
            lastvalid = case maybeOld of
              Just (_,_,lastvalid) -> lastvalid
              Nothing -> Nothing
        in Just ( jobRef
                , status
                , if resultIsFatal lintConfig res
                  then lastvalid
                  else Just status
                )

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

    whoops (error :: IOException) = runStdoutLoggingT $ do
      logErrorN (show error)
      void $ liftIO $ overJobStatus done jobOrg jobRef $ \case
        Nothing -> Just (jobRef, Failed (show error), Nothing)
        Just (_,_,lastvalid) -> Just (jobRef, Failed (show error), lastvalid)

    url = repourl jobRef
    ref = reporef jobRef
    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)