{-# LANGUAGE GADTs             #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE StrictData        #-}
module Main where

import           XPrelude               hiding (option)

import qualified Data.Aeson             as Aeson
import qualified Data.HashMap.Strict    as HM
import qualified Data.Text              as Text
import qualified Data.Vector            as Vector
import qualified Data.Version           as Meta
import qualified Network.HTTP.Client    as Http
import           Options.Applicative    as O
import qualified Paths_language_puppet  as Meta

import           Facter
import           Puppet.Interpreter
import           PuppetDB


data Options = Options
  { _pdbloc     :: Maybe FilePath
  , _pdbtype    :: PDBType
  , _pdbcmd     :: Maybe Command
  , _pdbversion :: Bool
  }

data Command
  = DumpFacts
  | DumpFact Text
  | DumpNodes
  | EditFact Text Text
  | DeactivateNode Text
  | DumpResources Text
  | CreateTestDB FilePath
  | AddFacts Text

options :: Parser Options
options = Options
  <$> optional (strOption
      (  long "location"
      <> short 'l'
      <> metavar "FILE|URL"
      <> help "Location of the PuppetDB, a file for type 'test' or an URL for type 'remote'"))
  <*> option auto
      (  long "pdbtype"
      <> short 't'
      <> value PDBTest
      <> help "PuppetDB types : test, remote, dummy")
  <*> optional cmd
  <*> switch
      (  long "version"
      <> help "Output version information and exit")
  where
      cmd = subparser (  command "resources"   (info resourcesparser (progDesc "Output resources for one node" <> failureCode 5))
                      <> command "facts"  (info factparser (progDesc "Output facts for one node" <> failureCode 12 ))
                      <> command "nodes"     (info (pure DumpNodes)(progDesc "Output all nodes" <> failureCode 8))
                      <> command "dumpfacts" (info (pure DumpFacts)(progDesc "Dump all facts, store in /tmp/allfacts.yaml" <> failureCode 4))
                      <> command "snapshot"  (info createtestdb    (progDesc "Create a test DB from the current DB" <> failureCode 10))
                      <> command "delnode"   (info delnodeparser   (progDesc "Deactivate node" <> failureCode 6))
                      <> command "editfact"  (info factedit (progDesc "Edit a fact corresponding to a node" <> failureCode 7 ))
                      <> command "addfacts"  (info addfacts        (progDesc "Adds facts to the test DB for the given node name, if they are not already defined" <> failureCode 11))
                      )

factedit :: Parser Command
factedit = EditFact <$> O.argument auto mempty <*> O.argument auto mempty

factparser :: Parser Command
factparser = DumpFact <$> fmap Text.pack (O.strArgument (metavar "NODE"))

resourcesparser :: Parser Command
resourcesparser = DumpResources <$> fmap Text.pack (O.strArgument (metavar "NODE"))

delnodeparser :: Parser Command
delnodeparser = DeactivateNode <$> O.argument auto mempty

createtestdb :: Parser Command
createtestdb = CreateTestDB <$> O.argument str (metavar "FILE")

addfacts :: Parser Command
addfacts = AddFacts <$> O.argument auto mempty


display :: (Show r, Aeson.ToJSON a) => Text -> Either r a -> IO ()
display s (Left rr) = panic (s <> " " <> show rr)
display _ (Right a) = putLByteString (Aeson.encode a)

runCheck :: Doc -> ExceptT PrettyError IO a -> IO a
runCheck s = runExceptT >=> unwrapError s

showHelpText :: ParserPrefs -> ParserInfo a -> IO ()
showHelpText pprefs pinfo = handleParseResult . Failure $
  parserFailure pprefs pinfo ShowHelpText mempty

run :: Options -> IO ()
run Options {_pdbversion = False, _pdbcmd = Nothing} =
  putText "Please provide one of the available command (see --help for more information) " *> exitFailure
run Options {_pdbversion = True, ..} = putStrLn ("language-puppet " ++ Meta.showVersion Meta.version)

run Options{_pdbcmd = Just pdbcmd, ..} = do
  mgr <- Http.newManager Http.defaultManagerSettings
  epdbapi <- case (_pdbloc, _pdbtype) of
    (Just url, PDBRemote) -> pdbConnect mgr url
    (Just l, PDBTest)   -> loadTestDB l
    (_, x)              -> getDefaultDB x
  pdbapi <- case epdbapi of
    Left r  -> panic (show r)
    Right x -> return x
  case pdbcmd of
      DumpFacts -> if _pdbtype == PDBDummy
                     then puppetDBFacts "dummy"  pdbapi >>= mapM_ print . HM.toList
                     else do
                       allfacts <- runCheck "get facts" (getPDBFacts pdbapi QEmpty)
                       tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= unwrapError "load test db"
                       let groupfacts = foldl' groupfact HM.empty allfacts
                           groupfact curmap (FactInfo ndname fctname fctval) =
                               curmap & at ndname . non HM.empty %~ (at fctname ?~ fctval)
                       runCheck "replace facts in dummy db" (replaceFacts tmpdb (HM.toList groupfacts))
                       runCheck "commit db" (commitDB tmpdb)
      DumpFact n -> runExceptT (getPDBFacts pdbapi (QEqual FCertname n ) ) >>= display "dump fact"
      DumpNodes -> runExceptT (getNodes pdbapi QEmpty) >>= display "dump nodes"
      DumpResources n -> runExceptT (getResourcesOfNode pdbapi n QEmpty) >>= display "get resources"
      AddFacts n -> do
        unless (_pdbtype == PDBTest) (panic "This option only works with the test puppetdb")
        fcts <- puppetDBFacts n pdbapi
        runCheck "replace facts" (replaceFacts pdbapi [(n, fcts)])
        runCheck "commit db" (commitDB pdbapi)
      CreateTestDB destfile -> do
        ndb <- loadTestDB destfile >>= unwrapError "puppetdb load"
        allnodes <- runCheck "get nodes" (getNodes pdbapi QEmpty)
        allfacts <- runCheck "get facts" (getPDBFacts pdbapi QEmpty)
        let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. factInfoNodename, HM.singleton (x ^. factInfoName) (x ^. factInfoVal))) allfacts
        runCheck "replace facts" (replaceFacts ndb factsGrouped)
        forM_ allnodes $ \pnodename -> do
            let ndename = pnodename ^. nodeInfoName
            res <- runCheck ("get resources for " <> ppline ndename) (getResourcesOfNode pdbapi ndename QEmpty)
            let wirecatalog = WireCatalog ndename "version" Vector.empty (Vector.fromList res) ndename
            runCheck "replace catalog" (replaceCatalog ndb wirecatalog)
        runCheck "commit db" (commitDB ndb)
      _ -> panic "Not yet implemented"

main :: IO ()
main =
  execParser opts >>= run
  where
    opts :: ParserInfo Options
    opts = info (helper <*> options)
            (fullDesc
             <> progDesc "A program to work with PuppetDB implementations"
             <> header "pdbQuery - work with PuppetDB implementations"
             <> failureCode 3)