{-# LANGUAGE CPP             #-}
{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE RecordWildCards #-}

-- | Auxx plugin.

module Plugin
       ( auxxPlugin
       , rawExec
       ) where

import           Universum

#if !(defined(mingw32_HOST_OS))
import           System.Exit (ExitCode (ExitSuccess))
import           System.Posix.Process (exitImmediately)
#endif
import           Control.Monad.Except (ExceptT (..), withExceptT)
import           Data.Constraint (Dict (..))
import           Data.Time.Units (Second)
import           Formatting (float, int, sformat, (%))
import           System.IO (hFlush, stdout)

import           Pos.Chain.Genesis as Genesis (Config (..))
import           Pos.Chain.Txp (TxpConfiguration, genesisUtxo)
import           Pos.Core.Conc (delay)
import           Pos.Crypto (AHash (..), fullPublicKeyF, hashHexF)
import           Pos.Infra.Diffusion.Types (Diffusion)
import           Pos.Util.Wlog (CanLog, HasLoggerName, logInfo)

import           AuxxOptions (AuxxOptions (..))
import           Command (createCommandProcs)
import qualified Lang
import           Mode (MonadAuxxMode)
import           Repl (PrintAction, WithCommandAction (..))

----------------------------------------------------------------------------
-- Plugin implementation
----------------------------------------------------------------------------

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}

auxxPlugin ::
       MonadAuxxMode m
    => Genesis.Config
    -> TxpConfiguration
    -> AuxxOptions
    -> Either WithCommandAction Text
    -> Diffusion m
    -> m ()
auxxPlugin genesisConfig txpConfig auxxOptions repl = \diffusion -> do
    logInfo $ sformat ("Length of genesis utxo: " %int)
                      (length $ genesisUtxo $ configGenesisData genesisConfig)
    rawExec (Just genesisConfig) (Just txpConfig) (Just Dict) auxxOptions (Just diffusion) repl

rawExec ::
       ( MonadIO m
       , MonadCatch m
       , CanLog m
       , HasLoggerName m
       )
    => Maybe Genesis.Config
    -> Maybe TxpConfiguration
    -> Maybe (Dict (MonadAuxxMode m))
    -> AuxxOptions
    -> Maybe (Diffusion m)
    -> Either WithCommandAction Text
    -> m ()
rawExec mCoreConfig txpConfig mHasAuxxMode AuxxOptions{..} mDiffusion = \case
    Left WithCommandAction{..} -> do
        printAction "... the auxx plugin is ready"
        forever $ withCommand $ runCmd mCoreConfig txpConfig mHasAuxxMode mDiffusion printAction
    Right cmd -> runWalletCmd mCoreConfig txpConfig mHasAuxxMode mDiffusion cmd

runWalletCmd ::
       ( MonadIO m
       , CanLog m
       , HasLoggerName m
       )
    => Maybe Genesis.Config
    -> Maybe TxpConfiguration
    -> Maybe (Dict (MonadAuxxMode m))
    -> Maybe (Diffusion m)
    -> Text
    -> m ()
runWalletCmd mCoreConfig txpConfig mHasAuxxMode mDiffusion line = do
    runCmd mCoreConfig txpConfig mHasAuxxMode mDiffusion printAction line
    printAction "Command execution finished"
    printAction " " -- for exit by SIGPIPE
    liftIO $ hFlush stdout
#if !(defined(mingw32_HOST_OS))
    delay (3 :: Second)
    liftIO $ exitImmediately ExitSuccess
#endif
  where
    printAction = putText

runCmd ::
       ( MonadIO m
       , CanLog m
       , HasLoggerName m
       )
    => Maybe Genesis.Config
    -> Maybe TxpConfiguration
    -> Maybe (Dict (MonadAuxxMode m))
    -> Maybe (Diffusion m)
    -> PrintAction m
    -> Text
    -> m ()
runCmd mCoreConfig txpConfig mHasAuxxMode mDiffusion printAction line = do
    let commandProcs = createCommandProcs mCoreConfig
                                          txpConfig
                                          mHasAuxxMode
                                          printAction
                                          mDiffusion
        parse = withExceptT Lang.ppParseError . ExceptT . return . Lang.parse
        resolveCommandProcs =
            withExceptT Lang.ppResolveErrors . ExceptT . return .
            Lang.resolveCommandProcs commandProcs
        evaluate = withExceptT Lang.ppEvalError . ExceptT . Lang.evaluate
        pipeline = parse >=> resolveCommandProcs >=> evaluate
    runExceptT (pipeline line) >>= \case
        Left errDoc -> printAction (Lang.renderAuxxDoc errDoc)
        Right value -> withValueText printAction value

withValueText :: Monad m => (Text -> m ()) -> Lang.Value -> m ()
withValueText cont = \case
    Lang.ValueUnit -> return ()
    Lang.ValueNumber n -> cont (sformat float n)
    Lang.ValueString s -> cont (toText s)
    Lang.ValueBool b -> cont (pretty b)
    Lang.ValueAddress a -> cont (pretty a)
    Lang.ValuePublicKey pk -> cont (sformat fullPublicKeyF pk)
    Lang.ValueTxOut txOut -> cont (pretty txOut)
    Lang.ValueStakeholderId sId -> cont (sformat hashHexF sId)
    Lang.ValueHash h -> cont (sformat hashHexF (getAHash h))
    Lang.ValueBlockVersion v -> cont (pretty v)
    Lang.ValueSoftwareVersion v -> cont (pretty v)
    Lang.ValueBlockVersionModifier bvm -> cont (pretty bvm)
    Lang.ValueBlockVersionData bvd -> cont (pretty bvd)
    Lang.ValueProposeUpdateSystem pus -> cont (show pus)
    Lang.ValueAddrDistrPart adp -> cont (show adp)
    Lang.ValueAddrStakeDistribution asd -> cont (pretty asd)
    Lang.ValueFilePath s -> cont (toText s)
    Lang.ValueList vs -> for_ vs $
        withValueText (cont . mappend "  ")

----------------------------------------------------------------------------
-- Extra logging
----------------------------------------------------------------------------

-- This addLogging was misplaced to begin with.
-- A debug-mode diffusion layer could be chosen, which logs absolutely all
-- network activity. But surely for auxx logging, the logging should go around
-- the high-level auxx commands, no?
{-
addLogging :: forall m. WithLogger m => SendActions m -> SendActions m
addLogging SendActions{..} = SendActions{
      enqueueMsg = error "unused"
    , withConnectionTo = aux
    }
  where
    aux nid k = withConnectionTo nid $ \peerData -> fmap auxConv (k peerData)
    auxConv (Conversation k) = Conversation (\acts -> k (auxActs acts))

    auxActs :: (Message snd, Message rcv)
            => ConversationActions snd rcv m -> ConversationActions snd rcv m
    auxActs (ConversationActions{..}) = ConversationActions {
        send = \body -> do
                 logDebug $ sformat ("Auxx sending " % stext) (formatMessage body)
                 send body
      , recv = \limit -> do
                 mRcv <- recv limit
                 logDebug $
                   case mRcv of
                     Nothing  -> sformat ("Auxx received end of input")
                     Just rcv -> sformat ("Auxx received " % stext) (formatMessage rcv)
                 return mRcv
      , sendRaw = sendRaw
      }
-}
