-- Copyright © 2021 Felix Lechner
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <https://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}

module Main where

import qualified Codec.Compression.Lzma        as Lzma
import           Control.Monad.Loops            ( iterateM_ )
import qualified Data.Aeson                    as JSON
import qualified Data.Aeson.Encode.Pretty      as PrettyJSON
import qualified Data.ByteString.Lazy.Char8    as Lazy
import qualified Data.ByteString.Lazy.UTF8     as UTF8
import           Data.Either                    ( Either(Left, Right) )
import           Data.List                      ( map )
import           Data.Maybe                     ( fromJust )
import           Data.Time.Clock                ( getCurrentTime )
import           Data.Time.ISO8601              ( formatISO8601Millis )
import qualified Data.Yaml                     as Yaml
import           GHC.Generics                   ( Generic )
import qualified Options.Applicative           as Options
import           System.Environment             ( getArgs )
import           System.Exit                    ( ExitCode(..) )
import           System.IO                      ( writeFile )
import           System.IO.Temp                 ( withSystemTempDirectory )
import           System.Posix.Process           ( nice )
import           System.Process                 ( CreateProcess(..)
                                                , proc
                                                , readCreateProcessWithExitCode
                                                , readProcessWithExitCode
                                                )
import           System.ZMQ4.Monadic            ( Req(..)
                                                , Socket(..)
                                                , ZMQ(..)
                                                , bind
                                                , close
                                                , connect
                                                , disconnect
                                                , liftIO
                                                , receive
                                                , runZMQ
                                                , send
                                                , socket
                                                )
import           Text.Printf                    ( printf )

import qualified Config.Connection             as Connection
import           Config.Connection              ( Connection(..) )
import qualified Job.Product                   as Product
import           Job.Product                    ( Product )
import qualified Job.Task                      as Task
import           Job.Task                       ( Task )
import qualified Job.Tool                      as Tool
import           Job.Tool                       ( Tool(..) )
import qualified Lintian.Results               as Results
import           Lintian.Results                ( Results )

data CommandLine = CommandLine
  { configPath :: String
  }

parser :: Options.Parser CommandLine
parser = CommandLine <$> Options.strOption
  (  Options.long "config"
  <> Options.short 'c'
  <> Options.metavar "PATH"
  <> Options.help "Path to configuration file"
  )

data Config = Config
  { scheduler :: Connection
  , collector :: Connection
  , tool      :: Tool
  }
  deriving (Show, Generic)

instance Yaml.FromJSON Config

defaultConnection =
  Connection { Connection.host = "localhost", Connection.listen_port = 5555 }

defaultTool = Tool { Tool.executable    = ""
                   , Tool.name          = ""
                   , Tool.git_remote    = Nothing
                   , Tool.path          = Nothing
                   , Tool.folder        = Nothing
                   , Tool.change_folder = Nothing
                   , Tool.options       = ""
                   , Tool.mime_type     = ""
                   }

defaultConfig = Config { scheduler = defaultConnection
                       , collector = defaultConnection
                       , tool      = defaultTool
                       }

getConfig :: String -> IO Config
getConfig configPath = do
  eitherConfig <-
    Yaml.decodeFileEither configPath :: IO (Either Yaml.ParseException Config)

  case eitherConfig of
    Right config -> return config
    Left  error  -> do
      print error
      return defaultConfig

connectionString :: Connection -> String
connectionString connection =
  "tcp://" ++ host connection ++ ":" ++ show (listen_port connection)

getTool :: Tool -> String -> IO (Maybe String)
getTool tool folder = do

  let tool_name = Tool.name tool

  case Tool.git_remote tool of
    Nothing -> do
      printf "No Git repo for tool %s.\n" tool_name
      return Nothing

    Just git_remote -> do

      printf "Getting %s tool from Git.\n" tool_name

      (status, stdout, stderr) <- readProcessWithExitCode
        "git"
        ["-C", folder, "clone", git_remote, tool_name]
        ""
      putStr $ "git clone: " <> stdout

      case status of

        ExitFailure code -> do
          printf "Error: could not clone Git repo (code %d): %s\n" code stderr
          return Nothing

        ExitSuccess -> do
          printf "Cloned into temporary folder %s.\n" folder
          return $ Just (folder <> "/" <> tool_name)

updateTool :: String -> IO ()
updateTool folder = do

  (status, stdout, stderr) <- readProcessWithExitCode "git"
                                                      ["-C", folder, "pull"]
                                                      ""
  putStr $ "git pull: " <> stdout

  case status of

    ExitFailure code -> do
      printf "Error: could not update Git repo (code %d): %s\n" code stderr

    ExitSuccess -> do
      printf "Updated Git repo in %s to latest version.\n" folder

processTask :: Task -> String -> Config -> Integer -> ZMQ z Product
processTask task folder config counter = do

  liftIO $ printf "Started new %s run for task %s.\n"
                  (Task.tool_name task)
                  (Task.name task)
  liftIO $ printf "Processing those input files:\n"
  liftIO $ mapM_ (putStrLn . ("    - " <>)) (Task.inputs task)

  processing_start <- liftIO getCurrentTime
  let my_tool    = tool config
  let executable = folder <> "/" <> Tool.executable my_tool
  let options    = words (Tool.options my_tool)

  (status, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode
    (proc executable (options <> Task.inputs task))
      { cwd = Tool.change_folder my_tool
      }
    ""
  processing_end <- liftIO getCurrentTime

  let product = Product.Product { Product.exit_status      = 0
                                , Product.processing_start = processing_start
                                , Product.processing_end   = processing_end
                                , Product.stdout           = Nothing
                                , Product.stderr           = stderr
                                }

  case status of

    ExitFailure code -> do
      liftIO $ printf "Error: could not run %s tool (code %d): %s\n"
                      (Task.tool_name task)
                      code
                      stderr
      pure (product { Product.exit_status = code })

    ExitSuccess -> do
      let eitherResults =
            JSON.eitherDecode (UTF8.fromString stdout) :: Either String Results
      case eitherResults of
        Left error -> do
          liftIO $ printf "Error: %s\n%s\n" error stdout
          pure product
        Right results -> do
          pure (product { Product.stdout = Just results })

produce :: CommandLine -> IO ()
produce (CommandLine path) = do
  config <- getConfig path

  let priority = 19
  printf "Adjusting process priority to %d.\n" priority
  nice priority

  withSystemTempDirectory "generate" $ \tempdir -> do

    tool_folder <- getTool (tool config) tempdir

    putStrLn
      $  "Expecting scheduler on "
      <> connectionString (scheduler config)
      <> "."
    putStrLn
      $  "Expecting collector on "
      <> connectionString (collector config)
      <> "."

    runZMQ $ do

      thrower <- socket Req
      let throw_endpoint = connectionString (scheduler config)
      connect thrower throw_endpoint

      catcher <- socket Req
      let catch_endpoint = connectionString (collector config)
      connect catcher catch_endpoint

      flip iterateM_ 1 $ \counter -> do

        send thrower [] "ready"
        json <- receive thrower

        case tool_folder of
          Nothing     -> return ()
          Just folder -> do
            liftIO $ updateTool folder
            let eitherTask =
                  JSON.eitherDecode (Lazy.fromStrict json) :: Either String Task
            case eitherTask of
              Left error -> liftIO $ printf
                "Error: %s\n%s\n"
                error
                (Lazy.unpack (Lazy.fromStrict json))
              Right task -> do
                product <- processTask task folder config counter
                let completed_task = task { Task.product = Just product
                                          , Task.tool    = Just (tool config)
                                          }
                send catcher []
                  $ Lazy.toStrict
                  $ Lzma.compress
                  $ PrettyJSON.encodePretty completed_task
                acknowledgement <- receive catcher
                liftIO
                  $  putStrLn
                  $  "Response from collector: "
                  <> Lazy.unpack (Lazy.fromStrict acknowledgement)
                  <> "\n"

        pure (counter + 1)

      disconnect thrower throw_endpoint
      disconnect catcher catch_endpoint

main :: IO ()
main = produce =<< Options.execParser opts
 where
  opts = Options.info
    (parser Options.<**> Options.helper)
    (  Options.fullDesc
    <> Options.progDesc "Produce results from a worker declaration"
    <> Options.header "produce - job worker that produces results"
    )
