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

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

import           Universum

import           Bindings.Cli.Git        (gitProc)
import           CheckDir                (recursiveCheckDir)
import           Cli.Extras              (CliConfig, CliT, ProcessFailure,
                                          Severity (..),
                                          callProcessAndLogOutput, getCliConfig,
                                          prettyProcessFailure, runCli)
import           Control.Concurrent      (ThreadId, forkIO)
import           Control.Concurrent.MVar (withMVar)
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           Servant                 (Handler, NoContent (NoContent),
                                          err404, err500, throwError)
import           Server                  (AdminOverview (AdminOverview),
                                          Config, orgs, tmpdir,
                                          JobStatus (..),
                                          RemoteRef (reporef, repourl),
                                          ServerState, jobs, registry,
                                          setJobStatus, setRegistry, Org (..))
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 ServerState -> 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 ServerState -> 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 ServerState -> 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


adminOverviewImpl :: MVar ServerState -> App AdminOverview
adminOverviewImpl state = do
  state <- readMVar state
  pure (AdminOverview state)

-- | 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 -> Org True -> CliConfig -> MVar ServerState -> RemoteRef -> App ThreadId
checkRef config org 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", toString (reporef ref), "--depth", "1" ])
        (callgit gitdir
         [ "clone", toString $ repourl ref, "--bare"
         , "--depth", "1", "-b", toString (reporef ref)])
      rand <- liftIO UUID.nextRandom
      let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
      callgit gitdir [ "worktree", "add", workdir ]
      callgit workdir [ "checkout", toString (reporef ref) ]
      res <- liftIO $ recursiveCheckDir (orgLintconfig org) workdir (orgEntrypoint org)
      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 = view tmpdir config </> toString hashedname
    hashedname = T.map escapeSlash . repourl $ ref
    escapeSlash = \case { '/' -> '-'; a -> a }