module Main where

import qualified Prelude


import           RIO                     hiding ( view )
import           RIO.List.Partial
import qualified RIO.HashMap                   as HM
import qualified RIO.HashMap.Partial           as HMP
import           RIO.Process
import qualified RIO.Text                      as Text
import qualified RIO.Text.Partial              as TextP

import           Baserock.Schema.V9
import qualified Data.Aeson                    as JSON
import qualified Data.Aeson.Lens               as JSON
import qualified Data.Aeson.Types              as JSON
                                                ( typeMismatch )
import           Data.Hashable                  ( Hashable )
import           Gitlab
import           GHC.Generics                   ( Generic )
import           Lens.Micro.Platform
import qualified System.Etc                    as Etc

import           Paths_baserock_schema          ( getDataFileName )

--------------------------------------------------------------------------------

data Cmd
  = BumpShas
  | MaybeTrackRef
  | PrintConfig
  | Sanitize
  | SetAllRefs
  | StealInstructions
  deriving (Show, Eq, Generic)

instance Hashable Cmd

instance JSON.FromJSON Cmd where
  parseJSON json = case json of
    JSON.String cmdName
      | cmdName == "bump-shas"             -> return BumpShas
      | cmdName == "maybe-track-ref"       -> return MaybeTrackRef
      | cmdName == "print-config"          -> return PrintConfig
      | cmdName == "sanitize"              -> return Sanitize
      | cmdName == "set-all-refs"          -> return SetAllRefs
      | cmdName == "steal-instructions"    -> return StealInstructions
      | otherwise -> JSON.typeMismatch ("Cmd (" <> Text.unpack cmdName <> ")") json
    _ -> JSON.typeMismatch "Cmd" json

instance JSON.ToJSON Cmd where
  toJSON cmd = case cmd of
    BumpShas          -> JSON.String "bump-shas"
    PrintConfig       -> JSON.String "print-config"
    MaybeTrackRef     -> JSON.String "maybe-track-ref"
    Sanitize          -> JSON.String "sanitize"
    SetAllRefs        -> JSON.String "set-all-refs"
    StealInstructions -> JSON.String "steal-instructions"

---------------------------------------------------------------------------------

type Aliases = HashMap Text Text

class HasAliases a where
  aliasesL :: Lens' a Aliases

type MonadSimpleApp env m = (MonadReader env m, HasLogFunc env, MonadIO m, MonadUnliftIO m)

type MonadBaserock env m = (MonadSimpleApp env m, MonadGitlab env m, HasAliases env)

type Repo = Text
type Ref  = Text

data BaserockApp =
  BaserockApp {
    appAliases        :: !Aliases
  , appGitlabConfig   :: !GitlabConfig
  , appLogFunc        :: !LogFunc
  , appProcessContext :: !ProcessContext
  }

data YBDConf = YBDConf {
  aliases :: Aliases
, directories :: HashMap Text Text
} deriving (Generic, Show)

instance FromJSON YBDConf

instance HasAliases BaserockApp where
  aliasesL = lens appAliases (\x y -> x { appAliases =y })

instance HasGitlabConfig BaserockApp where
  gitlabConfigL = lens appGitlabConfig (\x y -> x { appGitlabConfig = y })

instance HasLogFunc BaserockApp where
  logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })

instance HasProcessContext BaserockApp where
  processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })

---------------------------------------------------------------------------------

toSignificantSuffix :: Repo -> Text
toSignificantSuffix = (!! 1) . TextP.splitOn ":"

repoRefLatest :: MonadGitlab env m => Aliases -> Repo -> Ref -> m GitlabCommitData
repoRefLatest as = getCommitData . Text.dropSuffix ".git" . toSignificantSuffix . expandAliases as
 
expandAliases :: Aliases -> Repo -> Repo
expandAliases = flip (HM.foldrWithKey TextP.replace)

bumpChunkSha :: MonadBaserock env m => Chunk -> m Chunk
bumpChunkSha c = case liftA2 (,) (view repo c) (view ref c) of
  Nothing     -> logInfo ("No repo/ref for chunk" <> display (view chunkName c)) >> return c
  Just (x, y) -> do
    as <- asks (view aliasesL)
    logInfo $ "Getting latest commit data for repo " <> display x <> " at ref " <> display y
    t <- (Just <$> repoRefLatest as x y) `catch` \(e :: SomeException) -> return Nothing
    case t of
      Nothing -> logInfo "No value found, moving on." >> return c
      Just z  -> logInfo ("Found sha:" <> display (view glCommitId z)) >> return ((sha ?~ view glCommitId z) c)

mapSystemStrata :: Monad m => System -> (FilePath -> m b) -> m [b]
mapSystemStrata s x = forM (s ^.. (strata . traverse . stratumIncludeMorph)) $ x . Text.unpack

sanitizeStratum :: MonadSimpleApp env m => FilePath -> m Stratum
sanitizeStratum x = do
  logInfo $ "Sanitizing stratum " <> displayShow x
  sanitizeFile x

sanitizeSystem :: MonadSimpleApp env m => FilePath -> m System
sanitizeSystem x = do
  logInfo $ "Sanitizing system " <> displayShow x
  s <- sanitizeFile x
  mapSystemStrata s sanitizeStratum
  return s

setStratumRef :: MonadSimpleApp env m => FilePath -> Text -> m Stratum
setStratumRef f a = do
  logInfo $ "Setting ref of Stratum " <> displayShow f <> " to " <> displayShow a
  inplace overFile f (chunks . traverse) (ref ?~ a)

setSystemRef :: MonadSimpleApp env m => FilePath -> Text -> m System
setSystemRef f a = do
  logInfo $ "Setting ref of System " <> displayShow f <> " to " <> displayShow a
  s <- decodeFileThrow f
  mapSystemStrata s $ flip setStratumRef a
  return s

bumpStratum :: MonadBaserock env m => FilePath -> m Stratum
bumpStratum f = do
  logInfo $ "Bumping all shas in stratum " <> displayShow f
  inplace traverseOfFile f (chunks . traverse) bumpChunkSha

bumpSystem :: MonadBaserock env m => FilePath -> m System
bumpSystem f = do
  logInfo $ "Bumping all shas in system " <> displayShow f
  s <- decodeFileThrow f
  mapSystemStrata s bumpStratum
  return s

maybeTrackRemote :: MonadBaserock env m => Ref -> Chunk -> m Chunk
maybeTrackRemote r c = case view repo c of
  Nothing -> logInfo ("No repo/ref for chunk" <> display (view chunkName c)) >> return c
  Just x  -> do
    as <- asks (view aliasesL)
    logInfo $ "Getting latest commit data for repo " <> display x <> " at ref " <> display r
    t <- (Just <$> repoRefLatest as x r) `catch` \(e :: SomeException) -> return Nothing
    case t of
      Nothing -> logInfo "No value found, moving on." >> return c
      Just z  -> logInfo ("Found sha:" <> display (view glCommitId z))  >> return ((sha ?~ view glCommitId z) . (ref ?~ r) $ c)

maybeTrackStratum r f = do
  logInfo $ "Looking up tracking info for stratum " <> displayShow f <> " for ref " <> displayShow r
  inplace traverseOfFile f (chunks . traverse) (maybeTrackRemote r)

maybeTrackSystem r f = do
  logInfo $ "Looking up tracking info for system " <> displayShow f <> " for ref " <> displayShow r
  s <- decodeFileThrow f
  mapSystemStrata s $ maybeTrackStratum r
  return s

stealInstructionsChunk :: (HasProcessContext env, MonadSimpleApp env m) => String -> FilePath -> m ()
stealInstructionsChunk r f = do
  void $ proc "git" ["checkout", r, "--", f] readProcess
  void $ proc "git" ["reset", f, "HEAD"] readProcess

stealInstructionsStratum r f = do
  logInfo $ "Checking out instructions for stratum " <> displayShow f <> " on branch " <> displayShow r
  s <- decodeFileThrow f
  forM_ (s ^.. chunks . traverse . chunkMorph) $ mapM (stealInstructionsChunk r . Text.unpack)

stealInstructionsSystem r f = do
  logInfo $ "Checking out instructions for system " <> displayShow f <> " on branch " <> displayShow r
  s <- decodeFileThrow f
  mapSystemStrata s $ stealInstructionsStratum r

---------------------------------------------------------------------------------

runBaserock
  :: (Etc.IConfig config, MonadThrow m, MonadIO m)
  => config
  -> LogFunc
  -> ProcessContext
  -> (FilePath -> RIO BaserockApp b)
  -> m b
runBaserock c l p m = do
  let cValueS = flip Etc.getConfigValue c
  f       <- cValueS ["morph"]
  gUrl    <- cValueS ["gitlab", "url"]
  gToken  <- cValueS ["gitlab", "token"]
  ybdConf <- decodeFileThrow "ybd.conf"
  let gConfg = GitlabConfig (fromString gUrl) (fromString gToken)
  runRIO (BaserockApp (aliases ybdConf) gConfg l p) $ m f

main :: IO ()
main = do
  specPath   <- getDataFileName "spec.yaml"
  configSpec <- Etc.readConfigSpec (Text.pack specPath)

  Etc.reportEnvMisspellingWarnings configSpec

  (configFiles, _fileWarnings) <- Etc.resolveFiles configSpec
  (cmd        , configCli    ) <- Etc.resolveCommandCli configSpec
  configEnv                    <- Etc.resolveEnv configSpec

  let configDefault = Etc.resolveDefault configSpec

      config = configDefault `mappend` configFiles `mappend` configEnv `mappend` configCli

  logOptions <- logOptionsHandle stdout True

  let cValueS = flip Etc.getConfigValue config :: [Text] -> IO String
  let cValueB = flip Etc.getConfigValue config :: [Text] -> IO Bool

  appProcessContext <- mkDefaultProcessContext

  withLogFunc logOptions $ \logFunc -> case cmd of
    PrintConfig -> Etc.printPrettyConfig config

    Sanitize -> do
      f <- cValueS ["morph"]
      runRIO logFunc $ do
        (m :: Value) <- decodeFileThrow f
        case m ^? JSON.key "kind" of
          Just (String "stratum") -> void $ sanitizeStratum f
          Just (String "system")  -> void $ sanitizeSystem f

    SetAllRefs -> do
      f <- cValueS ["morph"]
      a <- cValueS ["ref"]
      runRIO logFunc $ do
        (m :: Value) <- decodeFileThrow f
        case m ^? JSON.key "kind" of
          Just (String "stratum") -> void $ setStratumRef f (Text.pack a)
          Just (String "system")  -> void $ setSystemRef  f (Text.pack a)

    BumpShas -> runBaserock config logFunc appProcessContext $ \f -> do
      (m :: Value) <- decodeFileThrow f
      case m ^? JSON.key "kind" of
        Just (String "stratum") -> void $ bumpStratum f
        Just (String "system")  -> void $ bumpSystem f

    MaybeTrackRef -> do
      a <- cValueS ["ref"]
      runBaserock config logFunc appProcessContext $ \f -> do
        (m :: Value) <- decodeFileThrow f
        case m ^? JSON.key "kind" of
          Just (String "stratum") -> void $ maybeTrackStratum (Text.pack a) f
          Just (String "system")  -> void $ maybeTrackSystem (Text.pack a) f

    StealInstructions -> do
      f <- cValueS ["morph"]
      a <- cValueS ["ref"]
      runRIO (LoggedProcessContext appProcessContext logFunc)  $ do
        (m :: Value) <- decodeFileThrow f
        case m ^? JSON.key "kind" of
          Just (String "stratum") -> void $ stealInstructionsStratum a f
          Just (String "system")  -> void $ stealInstructionsSystem a f
          Just (String "chunk")   -> void $ stealInstructionsChunk a f