{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE TypeApplications #-}

module Handlers (App, submitImpl,statusImpl,relintImpl) where

import           Bindings.Cli.Git       (gitProc)
import           CheckDir               (recursiveCheckDir)
import           Cli.Extras             (CliConfig, CliT, ProcessFailure,
                                         Severity (..), callProcessAndLogOutput,
                                         getCliConfig, prettyProcessFailure,
                                         runCli)
import           Control.Concurrent     (MVar, ThreadId, forkIO, withMVar)
import           Control.Monad.Extra    (ifM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans    (lift)
import qualified Data.Map               as M
import qualified Data.Text              as T
import           Data.UUID              (UUID)
import qualified Data.UUID              as UUID
import qualified Data.UUID.V4           as UUID
import           Lens.Micro.Extras      (view)
import           Servant                (Handler, NoContent (NoContent), err404,
                                         err500, throwError)
import           Server                 (Config (entrypoint, lintconfig, tmpdir),
                                         JobStatus (..),
                                         RemoteRef (reporef, repourl), State,
                                         jobs, registry, setJobStatus,
                                         setRegistry)
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 -> MVar State -> RemoteRef -> App UUID
submitImpl config state ref = do
  jobid <- liftIO UUID.nextRandom
  -- TODO: these two should really be atomic
  liftIO $ setJobStatus state ref Pending
  liftIO $ setRegistry state jobid ref
  cliconfig <- getCliConfig
  -- we'll just forget the thread id for now and trust this terminates …
  _ <- checkRef config cliconfig state ref
  -- the submission itself can't really fail or return anything useful
  pure jobid

relintImpl :: Config True -> MVar State -> UUID -> App NoContent
relintImpl config state uuid = do
  mref <- liftIO $ withMVar state (pure . M.lookup uuid . view registry)
  case mref of
    Nothing -> lift $ throwError err404
    Just ref -> do
      cliconfig <- getCliConfig
      _ <- checkRef config cliconfig state ref
      pure NoContent

statusImpl :: MVar State -> UUID -> App JobStatus
statusImpl state uuid = do
   status <- liftIO $ withMVar state $ \state ->
     case M.lookup uuid (view registry state) of
       Nothing  -> pure Nothing
       Just ref -> pure $ M.lookup ref (view jobs state)
   case status of
     Just res -> pure res
     Nothing  -> lift $ throwError err404


-- | 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
checkRef :: Config True -> CliConfig -> MVar State -> RemoteRef -> App ThreadId
checkRef config cliconfig state ref = liftIO $ forkIO $ do
    res <- liftIO $ runCli cliconfig $ do
      ifM (liftIO $ doesDirectoryExist gitdir)
        -- TODO: these calls fail for dumb http, add some fallback!
        (callgit gitdir
         [ "fetch", "origin", T.unpack (reporef ref), "--depth", "1" ])
        (callgit gitdir
         [ "clone", T.unpack $ repourl ref, "--bare"
         , "--depth", "1", "-b", T.unpack (reporef ref)])
      rand <- liftIO UUID.nextRandom
      let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
      callgit gitdir [ "worktree", "add", workdir ]
      callgit workdir [ "checkout", T.unpack (reporef ref) ]
      res <- liftIO $ recursiveCheckDir (lintconfig config) workdir (entrypoint config)
      callgit gitdir [ "worktree", "remove", "-f", "-f", workdir ]
      pure res
    liftIO $ setJobStatus state ref $ case res of
      Right res -> Linted res
      Left err  -> Failed (prettyProcessFailure err)
  where
    callgit dir = callProcessAndLogOutput (Debug, Debug) . gitProc dir
    gitdir = tmpdir config </> hashedname
    hashedname = fmap escapeSlash . T.unpack . repourl $ ref
    escapeSlash = \case { '/' -> '-'; a -> a }