{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-| Definition of the B9 monad. It encapsulates logging, very basic command
execution profiling, a reader for the "B9.B9Config" and access to the
current build id, the current build directory and the artifact to build.

This module is used by the _effectful_ functions in this library.
-}
module B9.B9Monad
  ( B9
  , run
  , traceL
  , dbgL
  , infoL
  , errorL
  , errorExitL
  , getConfig
  , getBuildId
  , getBuildDate
  , getBuildDir
  , getExecEnvType
  , getSelectedRemoteRepo
  , getRemoteRepos
  , getRepoCache
  , cmd
  )
where

import           B9.B9Config
import           B9.Repository
import           Control.Applicative
import           Control.Exception              ( bracket )
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.State
import           Control.Lens                   ( (&)
                                                , (.~)
                                                , (^.)
                                                , (%~)
                                                , (?~)
                                                )
import qualified Data.ByteString.Char8         as B
import           Data.Functor                   ( )
import           Data.Hashable
import           Data.Maybe
import           Data.Time.Clock
import           Data.Time.Format
import           Data.Word                      ( Word32 )
import           System.Directory
import           System.Exit
import           System.FilePath
import           System.Random                  ( randomIO )
import qualified System.IO                     as SysIO
import           Text.Printf
import           Control.Concurrent.Async       ( Concurrently(..) )
import           Data.Conduit                   ( (.|)
                                                , runConduit
                                                )
import qualified Data.Conduit.List             as CL
import           Data.Foldable
import           Data.Conduit.Process

data BuildState =
  BuildState {bsBuildId :: String
             ,bsBuildDate :: String
             ,bsCfg :: B9Config
             ,bsBuildDir :: FilePath
             ,bsLogFileHandle :: Maybe SysIO.Handle
             ,bsSelectedRemoteRepo :: Maybe RemoteRepo
             ,bsRepoCache :: RepoCache
             ,bsProf :: [ProfilingEntry]
             ,bsStartTime :: UTCTime
             ,bsInheritStdIn :: Bool}

data ProfilingEntry
  = IoActionDuration NominalDiffTime
  | LogEvent LogLevel
             String
  deriving (Eq,Show)


run :: MonadIO m => B9 a -> B9ConfigAction m a
run action = do
  cfg <- askRuntimeConfig
  liftIO $ do
    buildId <- liftIO $ generateBuildId cfg
    now     <- liftIO $ getCurrentTime
    liftIO
      $ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)
 where
  resolveBuildDirRoot cfg = case _buildDirRoot cfg of
    Nothing    -> getCurrentDirectory >>= canonicalizePath
    Just root' -> do
      createDirectoryIfMissing True root'
      canonicalizePath root'
  withLogFile cfg f = maybe
    (f Nothing)
    (\logf -> SysIO.withFile logf SysIO.AppendMode (f . Just))
    (_logFile cfg)
  withBuildDir cfg buildId =
    bracket (createBuildDir cfg buildId) (removeBuildDir cfg)
  runImpl cfg buildId now buildDir logFileHandle = do
      -- Check repositories
    repoCache <- initRepoCache
      (fromMaybe defaultRepositoryCache (_repositoryCache cfg))
    let buildDate = formatTime undefined "%F-%T" now
    remoteRepos'    <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)
    buildDirRootAbs <- resolveBuildDirRoot cfg
    let finalCfg =
          (  cfg
          &  remoteRepos
          .~ remoteRepos'
          &  (buildDirRoot ?~ buildDirRootAbs)
          &  envVars
          %~ mappend [("buildDirRoot", buildDirRootAbs)]
          )
    let
      ctx = BuildState buildId
                       buildDate
                       finalCfg
                       buildDir
                       logFileHandle
                       selectedRemoteRepo
                       repoCache
                       []
                       now
                       (_interactive finalCfg)
      selectedRemoteRepo = do
        sel <- _repository cfg
        lookupRemoteRepo remoteRepos' sel <|> error
          (printf
            "selected remote repo '%s' not configured, valid remote repos are: '%s'"
            sel
            (show remoteRepos')
          )
    (r, ctxOut) <- runStateT (runB9 wrappedAction) ctx
    -- Write a profiling report
    when (isJust (_profileFile cfg)) $ writeFile
      (fromJust (_profileFile cfg))
      (unlines $ show <$> reverse (bsProf ctxOut))
    return r
  createBuildDir cfg buildId = do
      let subDir = "BUILD-" ++ buildId
      buildDir <- resolveBuildDir subDir
      createDirectoryIfMissing True buildDir
      canonicalizePath buildDir
   where
    resolveBuildDir f = do
      root <- resolveBuildDirRoot cfg
      return $ root </> f
  removeBuildDir cfg buildDir =
    when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg))
      $ removeDirectoryRecursive buildDir
  generateBuildId cfg =
    let cfgHash = hash (show cfg) in
       if _uniqueBuildDirs cfg then
        do salt <- randomIO :: IO Word32
           return (printf "%08X-%08X" cfgHash salt)
        else
           return (printf "%08X" cfgHash)
  -- Run the action build action
  wrappedAction   = do
    b9cfg <- getConfig
    traverse_ (traceL . printf "Root Build Directory: %s")
              (b9cfg ^. buildDirRoot)
    startTime <- gets bsStartTime
    r         <- action
    now       <- liftIO getCurrentTime
    let duration = show (now `diffUTCTime` startTime)
    infoL (printf "DURATION: %s" duration)
    return r

getBuildId :: B9 String
getBuildId = gets bsBuildId

getBuildDate :: B9 String
getBuildDate = gets bsBuildDate

getBuildDir :: B9 FilePath
getBuildDir = gets bsBuildDir

getConfig :: B9 B9Config
getConfig = gets bsCfg

getExecEnvType :: B9 ExecEnvType
getExecEnvType = gets (_execEnvType . bsCfg)

getSelectedRemoteRepo :: B9 (Maybe RemoteRepo)
getSelectedRemoteRepo = gets bsSelectedRemoteRepo

getRemoteRepos :: B9 [RemoteRepo]
getRemoteRepos = gets (_remoteRepos . bsCfg)

getRepoCache :: B9 RepoCache
getRepoCache = gets bsRepoCache

-- getDownloader :: B9 Downloader
-- getDownloader = gets bsDownloader
--
-- -- | Configuration for a tool that retreives arbitrary URL and returns them to
-- -- @stdout@.
-- data Downloader =
--   Downloader {downloaderCmd :: FilePath
--              ,downloaderArgsBeforeUrl :: [String]
--              ,downloaderUrlArgPrintfFormatString :: [String]
--              ,downloaderArgsAfterUrl :: [String]}
--   deriving (Read,Show,Eq,Ord,Typeable,Generic)
--
-- readContentFromUrl :: String -> B9 B.ByteString
-- readContentFromUrl url = do
--   return expression

cmd :: String -> B9 ()
cmd str = do
  inheritStdIn <- gets bsInheritStdIn
  if inheritStdIn then interactiveCmd str else nonInteractiveCmd str

interactiveCmd :: String -> B9 ()
interactiveCmd str = void (cmdWithStdIn True str :: B9 Inherited)

nonInteractiveCmd :: String -> B9 ()
-- TODO if we use 'ClosedStream' we get an error from 'virsh console'
-- complaining about a missing controlling tty. Original source line:
-- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream)
nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 Inherited)

cmdWithStdIn :: (InputSource stdin) => Bool -> String -> B9 stdin
cmdWithStdIn toStdOut cmdStr = do
  traceL $ "COMMAND: " ++ cmdStr
  cmdLogger <- getCmdLogger
  let outPipe = if toStdOut then CL.mapM_ B.putStr else cmdLogger LogTrace
  (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)
  e                         <-
    liftIO
    $  runConcurrently
    $  Concurrently (runConduit (cpOut .| outPipe))
    *> Concurrently (runConduit (cpErr .| cmdLogger LogInfo))
    *> Concurrently (waitForStreamingProcess cph)
  checkExitCode e
  return cpIn
 where
  getCmdLogger = do
    lv  <- gets $ _verbosity . bsCfg
    lfh <- gets bsLogFileHandle
    return $ \level -> CL.mapM_ (logImpl lv lfh level . B.unpack)
  checkExitCode ExitSuccess =
    traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr
  checkExitCode ec@(ExitFailure e) = do
    errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e
    liftIO $ exitWith ec

traceL :: String -> B9 ()
traceL = b9Log LogTrace

dbgL :: String -> B9 ()
dbgL = b9Log LogDebug

infoL :: String -> B9 ()
infoL = b9Log LogInfo

errorL :: String -> B9 ()
errorL = b9Log LogError

errorExitL :: String -> B9 a
errorExitL e = b9Log LogError e >> fail e

b9Log :: LogLevel -> String -> B9 ()
b9Log level msg = do
  lv  <- gets $ _verbosity . bsCfg
  lfh <- gets bsLogFileHandle
  modify $ \ctx -> ctx { bsProf = LogEvent level msg : bsProf ctx }
  B9 $ liftIO $ logImpl lv lfh level msg

logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO ()
logImpl minLevel mh level msg = do
  lm <- formatLogMsg level msg
  when (isJust minLevel && level >= fromJust minLevel) (putStr lm)
  when (isJust mh) $ do
    SysIO.hPutStr (fromJust mh) lm
    SysIO.hFlush (fromJust mh)

formatLogMsg :: LogLevel -> String -> IO String
formatLogMsg l msg = do
  utct <- getCurrentTime
  let time = formatTime defaultTimeLocale "%H:%M:%S" utct
  return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg

printLevel :: LogLevel -> String
printLevel l = case l of
  LogNothing -> "NOTHING"
  LogError   -> " ERROR "
  LogInfo    -> " INFO  "
  LogDebug   -> " DEBUG "
  LogTrace   -> " TRACE "

newtype B9 a =
  B9 {runB9 :: StateT BuildState IO a}
  deriving (Functor,Applicative,Monad,MonadState BuildState)

instance MonadIO B9 where
  liftIO m = do
    start <- B9 $ liftIO getCurrentTime
    res   <- B9 $ liftIO m
    stop  <- B9 $ liftIO getCurrentTime
    let durMS = IoActionDuration (stop `diffUTCTime` start)
    modify $ \ctx -> ctx { bsProf = durMS : bsProf ctx }
    return res