{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StrictData #-}
module Lambdabot.Plugin.Telegram
  ( -- * Lambdabot state

    lambdabotVersion
  , telegramPlugins
  , telegramPlugin
  , customHaskellPlugins
  , newTelegramState
  , feed
  , handleMsg
  , lockRC
  , unlockRC

  -- * Eval

  -- $eval
  , args, isEval, dropPrefix, runGHC, define, mergeModules, moduleProblems, moveFile, customComp, resetCustomL_hs, findPristine_hs, findCustomL_hs

  -- $chatType
  , ChatInfo(..), ChatType(..), renderChatType, readChatInfoFromSource, dropChatInfoFromSource, getDotFilename, getLFilename, editModuleName
  ) where

import Codec.Binary.UTF8.String
import Control.Concurrent.Lifted
import Control.Concurrent.STM
import Control.Exception.Lifted (SomeException, try, finally)
import Control.Monad (void, when)
import Control.Monad.State (gets, lift, liftIO, modify)
import Data.Char
import Data.List
import qualified Data.Map.Strict as Map
import Data.Ord
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import Data.Version
import qualified Language.Haskell.Exts.Simple as Hs
import System.Directory
import System.Exit
import System.Process
import System.Timeout.Lifted
import Telegram.Bot.Simple
import Text.Pretty.Simple (pStringNoColor)

import Lambdabot.Command
import Lambdabot.Config.Telegram
import Lambdabot.IRC
import Lambdabot.Monad
import Lambdabot.Module
import Lambdabot.Nick
import Lambdabot.Plugin
import Lambdabot.Util

import Lambdabot.Plugin.Telegram.Bot
import Lambdabot.Plugin.Telegram.Callback
import Lambdabot.Plugin.Telegram.Message
import Lambdabot.Plugin.Telegram.Shared

-- * Lambdabot state

-- | Lambdabot version from 'lambdabot-core' package.
lambdabotVersion :: String
lambdabotVersion = VERSION_lambdabot_core

-- | Exported plugin(s).
telegramPlugins :: [String]
telegramPlugins = ["telegram"]

-- | Eval excluded because we provide it by ourselves.
customHaskellPlugins :: [String]
customHaskellPlugins =
  [ "check", "djinn", "free", "haddock", "hoogle", "instances"
  , "pl", "pointful", "pretty", "source", "type", "undo", "unmtl"
  ]

-- | Telegram plugin for Lambdabot.
-- Here we redefined @eval@ plugin to provide multiple sandboxes for different chats.
telegramPlugin :: Module TelegramState
telegramPlugin = newModule
  { moduleDefState = newTelegramState
  , moduleInit = do
      lb . modify $ \s -> s
        { ircPrivilegedUsers = Set.insert (Nick "telegramrc" "null") (ircPrivilegedUsers s)
        }
      -- register callback for telegram
      registerCallback "TGMSG" doTGMSG
      ldebug "TGMSG callback registered"
      -- note: moduleInit is invoked with exceptions masked
      void . forkUnmasked $ do
        waitForInit
        lockRC
  , moduleCmds = return
    [ (command "telegram")
        { privileged = True
        , help = say "telegram. Start a bot"
        , process = const . lift $ do
            lockRC
            histFile <- lb $ findLBFileForWriting "telegramrc"
            -- FIXME: token should be passed via config or env
            token <- io $ getEnvToken "TELEGRAM_LAMBDABOT_TOKEN"
            tgState <- readMS
            _ <- fork (io $ runTelegramBot token tgState)
            ldebug "telegram bot started"
            _ <- fork (telegramLoop histFile `finally` unlockRC)
            ldebug "telegram loop started"
            return ()
        }
    , (command "tgversion")
        { help = say $
            "version/source. Report version(s) and git repo of this bot."
        , process = const $ do
            ver <- getConfig telegramLambdabotVersion
            say $ unlines $
              [ "telegram-lambdabot v."
                <> showVersion ver
                <> ". git clone https://github.com/swamp-agr/lambdabot-telegram-plugins.git"
              , "lambdabot-core v."
                <> lambdabotVersion
                <> ". git clone https://github.com/lambdabot/lambdabot.git"
              ]
        }
    , (command "run")
        { help = say "run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"
        , process = lim80 . runGHC
        }
    , (command "let")
        { aliases = ["define"] -- because @define always gets "corrected" to @undefine
        , help = say "let <x> = <e>. Add a binding"
        , process = lim80 . define
        }
    , (command "undefine")
        { help = say "undefine. Reset evaluator local bindings"
        , process = \s -> 
            let chatInfo = readChatInfoFromSource s
                s' = dropChatInfoFromSource chatInfo s
             in 
            if null s'
              then resetCustomL_hs chatInfo >> say "Undefined."
              else say "There's currently no way to undefine just one thing.  Say @undefine (with no extra words) to undefine everything."
        }
    ]
  }

-- | Initialise 'TelegramState' from Lambdabot config and with defaults. Current defaults are:
-- 
-- * Input queue size: 1000000.
-- * Output queue size: 1000000.
newTelegramState :: LB TelegramState
newTelegramState = do
  tgBotName <- Text.pack <$> getConfig telegramBotName
  liftIO $ do
    putStrLn $ " bot name is : " <> Text.unpack (tgBotName)
    let size = 1000000
        tgCurrent = 0
    tgInput <- newTBQueueIO size
    tgOutput <- newTBQueueIO size
  
    return TelegramState {..}

-- | Commands preprocessing. Commands started with @>@, @!@ would be replaced
-- with @<commadPrefix (from Lambdabot config)> + "run "@.
-- Resulted command would be passed to IRC @system@ plugin.
feed :: Text -> Text -> Text -> Telegram ()
feed chatId msgId msg = do
    cmdPrefix <- fmap head (getConfig commandPrefixes)
    let msg' = case Text.unpack msg of
            '>':xs -> cmdPrefix ++ "run " ++ xs
            '!':xs -> xs
            _      -> cmdPrefix ++ dropWhile (== ' ') (Text.unpack msg)
    -- note that `msg'` is unicode, but lambdabot wants utf-8 lists of bytes
    lb . void . timeout (15 * 1000 * 1000) . received $
      makeIrcMessage chatId msgId (Text.pack $ encodeString msg')

-- | Transcoding the response from IRC @system@ plugin and sending message back to Telegram. 
handleMsg :: IrcMessage -> Telegram ()
handleMsg msg = do
  let str = case (tail . ircMsgParams) msg of
        []    -> []
        (x:_) -> tail x
  -- str contains utf-8 list of bytes; convert to unicode
  tg <- readMS
  let out = Msg
        { msgChatId = getTgChatId msg
        , msgMsgId = getTgMsgId msg
        , msgMessage = (TL.toStrict . pStringNoColor . decodeString) str
        }
  ldebug $ "handleMsg : irc : " <> (show msg)
  ldebug $ "handleMsg : out : " <> (show out)
  io $ writeOutput out tg

-- | Register @telegram@ plugin in lambdabot core.
lockRC :: Telegram ()
lockRC = do
  withMS $ \ tg writ -> do
    when (tgCurrent tg == 0) $ do
      registerServer "telegramrc" handleMsg
      lift $ modify $ \state' ->
        state' { ircPersists = Map.insert "telegramrc" True $ ircPersists state' }
      writ (tg { tgCurrent = tgCurrent tg + 1 })

-- | Unregister @telegram@ plugin in lambdabot core.
unlockRC :: Telegram ()
unlockRC = withMS $ \ tg writ -> do
  when (tgCurrent tg == 1) $ unregisterServer "telegramrc"
  writ (tg { tgCurrent = tgCurrent tg - 1})

-- | The main loop process.
-- Constantly read the messages from Telegram and passing them to IRC core.
telegramLoop :: FilePath -> Telegram ()
telegramLoop fp = do
  tg <- readMS
  msg <- io $ readInput tg
  ldebug $ "[DEBUG] : lambdabot : input read : " <> show msg
  let s' = Text.dropWhile isSpace (msgMessage msg)
  when (not (Text.null s')) $ do
    io $ appendFile fp $ Text.unpack (msgMessage msg) <> "\n"
    feed (msgChatId msg) (msgMsgId msg) s'
  continue <- lift $ gets (Map.member "telegramrc" . ircPersists)
  when continue $ telegramLoop fp

-- ** Eval

-- $eval
-- Functions above came from @eval@ plugin from @lambdabot-haskell-plugins@ package.
-- Instead of registering multiple "servers" for each Telegram chat and introducing new entities to manage multiple "servers",
-- we decided to keep a single "server" and to modify "sandboxes".
-- Sandbox is a basically single file "L.hs" that populated once IRC received "@let" command.
-- For every chat used exactly the same file. It means that it was possible to share all definitions across different Telegram chats.
-- To overcome these limitations we decided to create a separate file and associate it with a chat.

-- | Concatenate all input into list of strings to pass to GHC:
--
-- @args filesToLoad sourceExpressionToEvaluate ghcExtensions trustedPackages@
args :: String -> String -> [String] -> [String] -> [String]
args load src exts trusted = concat
    [ ["-S"]
    , map ("-s" ++) trusted
    , map ("-X" ++) exts
    , ["--no-imports", "-l", load]
    , ["--expression=" ++ decodeString src]
    , ["+RTS", "-N", "-RTS"]
    ]

-- | Determine whether command belongs to @eval@ plugin or not.
isEval :: MonadLB m => String -> m Bool
isEval str = do
    prefixes <- getConfig evalPrefixes
    return (prefixes `arePrefixesWithSpaceOf` str)

-- | Drop command prefix.
dropPrefix :: String -> String
dropPrefix = dropWhile (' ' ==) . drop 2

-- | Represents "run" command. Actually run GHC.
-- Response would be handled separately via callbacks.
runGHC :: MonadLB m => String -> m String
runGHC src' = do
    let chatInfo = readChatInfoFromSource src'
        src = dropChatInfoFromSource chatInfo src'

    load    <- findCustomL_hs chatInfo
    binary  <- getConfig muevalBinary
    exts    <- getConfig languageExts
    trusted <- getConfig trustedPackages
    (_,out,err) <- io (readProcessWithExitCode binary (args load src exts trusted) "")
    case (out,err) of
        ([],[]) -> return "Terminated\n"
        _       -> do
            let o = mungeEnc out
                e = mungeEnc err
            return $ case () of {_
                | null o && null e -> "Terminated\n"
                | null o           -> e
                | otherwise        -> o
            }

-- | "define" command. Define a new binding. It would be stored in corresponding sandbox.
define :: MonadLB m => String -> m String
define [] = return "Define what?"
define src' = do
    exts <- getConfig languageExts
    let chatInfo = readChatInfoFromSource src'
        src = dropChatInfoFromSource chatInfo src'
        mode = Hs.defaultParseMode{ Hs.extensions = map Hs.classifyExtension exts }
    case Hs.parseModuleWithMode mode (decodeString src) of
        Hs.ParseOk srcModule -> do
            l <- findCustomL_hs chatInfo
            res <- io (Hs.parseFile l)
            case res of
                Hs.ParseFailed loc err -> return (Hs.prettyPrint loc ++ ':' : err)
                Hs.ParseOk lModule -> do
                    let merged = mergeModules lModule srcModule
                    case moduleProblems merged of
                        Just msg -> return msg
                        Nothing  -> customComp chatInfo merged
        Hs.ParseFailed _loc err -> return ("Parse failed: " ++ err)

-- | Merge the second module _into_ the first - meaning where merging doesn't
-- make sense, the field from the first will be used.
mergeModules :: Hs.Module -> Hs.Module -> Hs.Module
mergeModules (Hs.Module  head1  exports1 imports1 decls1)
             (Hs.Module _head2 _exports2 imports2 decls2)
    = Hs.Module head1 exports1
        (mergeImports imports1 imports2)
        (mergeDecls   decls1   decls2)
    where
        mergeImports x y = nub' (sortBy (comparing Hs.importModule) (x ++ y))
        mergeDecls x y = sortBy (comparing funcNamesBound) (x ++ y)

        -- this is a very conservative measure... we really only even care about function names,
        -- because we just want to sort those together so clauses can be added in the right places
        -- TODO: find out whether the [Hs.Match] can contain clauses for more than one function (e,g. might it be a whole binding group?)
        funcNamesBound (Hs.FunBind ms) = nub $ sort [ n | Hs.Match n _ _ _ <- ms]
        funcNamesBound _ = []
-- we simply do not care about XML cases
mergeModules _ _ = error "Not supported module met"

-- | Import validations.
moduleProblems :: Hs.Module -> Maybe [Char]
moduleProblems (Hs.Module _head pragmas _imports _decls)
    | safe `notElem` langs  = Just "Module has no \"Safe\" language pragma"
    | trusted `elem` langs  = Just "\"Trustworthy\" language pragma is set"
    | otherwise             = Nothing
    where
        safe    = Hs.name "Safe"
        trusted = Hs.name "Trustworthy"
        langs = concat [ ls | Hs.LanguagePragma ls <- pragmas ]
-- we simply do not care about XML cases
moduleProblems _ = error "Not supported module met"

-- | Helper for sandboxes. Used to move temporary file.
moveFile :: FilePath -> FilePath -> IO ()
moveFile from to = do
  copyFile from to
  removeFile from

-- | Custom compilation of temporary files for binding. Used as part of "define" command.
customComp :: MonadLB m => ChatInfo -> Hs.Module -> m String
customComp chatInfo src = do
    -- calculate temporary filename for source, interface and compiled library
    let hs = getDotFilename chatInfo "hs"
        hi = getDotFilename chatInfo "hi"
        lib = getDotFilename chatInfo "o"
        lhs = getLFilename chatInfo
    -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files
    io (writeFile hs (Hs.prettyPrint src))

    -- and compile .L.hs
    -- careful with timeouts here. need a wrapper.
    trusted <- getConfig trustedPackages
    let ghcArgs = concat
            [ ["-O", "-v0", "-c", "-Werror", "-fpackage-trust"]
            , concat [["-trust", pkg] | pkg <- trusted]
            , [hs]
            ]
    ghc <- getConfig ghcBinary
    (c, o',e') <- io (readProcessWithExitCode ghc ghcArgs "")
    -- cleanup, 'try' because in case of error the files are not generated
    _ <- io (try (removeFile hi) :: IO (Either SomeException ()))
    _ <- io (try (removeFile lib)  :: IO (Either SomeException ()))

    case (mungeEnc o', mungeEnc e') of
        ([],[]) | c /= ExitSuccess -> do
                    io (removeFile hs)
                    return "Error."
                | otherwise -> do
                    l <- lb (findLBFileForWriting lhs)
                    io (moveFile hs l)
                    return "Defined."
        (ee,[]) -> return ee
        (_ ,ee) -> return ee

-- | Reset sandbox. Associated "L.hs" file would be reset to defaults.
resetCustomL_hs :: MonadLB m => ChatInfo -> m ()
resetCustomL_hs chatInfo = do
    let lhs = getLFilename chatInfo
    p <- findPristine_hs
    contents <- liftIO (readFile p)
    l <- lb (findLBFileForWriting lhs)
    io (writeFile l $ editModuleName chatInfo contents)

-- | Find "Pristine.hs"; if not found, we try to install a compiler-specific
-- version from lambdabot's data directory, and finally the default one.
findPristine_hs :: MonadLB m => m FilePath
findPristine_hs = do
    p <- lb (findLBFileForReading "Pristine.hs")
    case p of
        Nothing -> do
            p' <- lb (findOrCreateLBFile "Pristine.hs")
            p0 <- lb (findLBFileForReading ("Pristine.hs." ++ show (__GLASGOW_HASKELL__ :: Integer)))
            p0' <- case p0 of
                Nothing -> lb (findLBFileForReading "Pristine.hs.default")
                p0' -> return p0'
            case p0' of
                Just p0'' -> do
                    p'' <- lb (findLBFileForWriting "Pristine.hs")
                    io (copyFile p0'' p'')
                _ -> return ()
            return p'
        Just p' -> return p'

-- | Find associated with a chat "L.hs" file; if not found, we copy it from "Pristine.hs".
findCustomL_hs :: MonadLB m => ChatInfo -> m FilePath
findCustomL_hs chatInfo = do
    let lhs = getLFilename chatInfo
    file <- lb (findLBFileForReading lhs)
    case file of
        -- if L.hs
        Nothing -> resetCustomL_hs chatInfo >> lb (findOrCreateLBFile lhs)
        Just file' -> return file'

-- $chatType
-- Since Lambdabot is passing 'String' inside one plugin (see 'process' for more details), Telegram chat information rendered as 'String' and attached to every command to pass between commands and callbacks inside a plugin.

-- | 'ChatInfo' represents an associated Telegram chat. Currently supports private and public chats.
data ChatInfo = ChatInfo
  { chatInfoChatId :: !Text
  , chatInfoType   :: !ChatType
  }

-- | 'ChatType' represents whether chat is public or private.
data ChatType = Public | Private

-- | Since it's not possible to define module with "L-1000" name and private chats in Telegram are usually represented by negative digits, we simple encode it with a character.
renderChatType :: ChatType -> String
renderChatType Public = ""
renderChatType Private = "P"

-- | Read 'ChatInfo' from command string.
readChatInfoFromSource :: String -> ChatInfo
readChatInfoFromSource str =
  let prefix = takeWhile (/= '|') str
      mode = case find (== '-') str of
        Nothing -> Public
        Just _  -> Private
      onlyChatId = filter isDigit prefix
  in ChatInfo (Text.pack onlyChatId) mode

-- | Drop 'ChatInfo' from command string. Original command is returned.
dropChatInfoFromSource :: ChatInfo -> String -> String
dropChatInfoFromSource ChatInfo{..} str = drop 1 . dropWhile (/= '|') $ drop prefixLength str
  where
    prefixLength = Text.length chatInfoChatId + m
    m = case chatInfoType of
      Private -> 1
      Public  -> 0

-- | Generate temporary filename for given 'ChatInfo' and file extension.
getDotFilename :: ChatInfo -> String -> FilePath
getDotFilename ChatInfo{..} extension
  = ".L" <> renderChatType chatInfoType <> Text.unpack chatInfoChatId <> "." <> extension

-- | Generate "L.hs" filename for given 'ChatInfo'.
getLFilename :: ChatInfo -> FilePath
getLFilename ChatInfo{..}
  = "L" <> renderChatType chatInfoType <> Text.unpack chatInfoChatId <> ".hs"

-- | Replace @module L where@ with @module L\<chatId\> where@ where @\<chatId\>@ is a telegram chat ID.
editModuleName :: ChatInfo -> String -> String
editModuleName ChatInfo{..} str =
  let moduleName = "L" <> Text.pack (renderChatType chatInfoType) <> chatInfoChatId
      moduleLine = "module " <> moduleName <> " where"
  in (Text.unpack . Text.replace "module L where" moduleLine . Text.pack) str

munge, mungeEnc :: String -> String
munge = expandTab 8 . strip (=='\n')
mungeEnc = encodeString . munge

nub' :: Ord a => [a] -> [a]
nub' = Set.toList . Set.fromList