{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module FP.API.Common where

import           Control.Applicative
import           Control.Concurrent (threadDelay)
import           Control.Concurrent.STM
import           Control.Exception (Exception)
import           Control.Exception.Lifted (SomeException, try, throw)
import           Control.Monad
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Trans.Control (MonadBaseControl)
import           Data.Aeson (Value, decode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import           Data.Data (Data)
import           Data.Generics.Schemes (listify)
import           Data.IORef
import           Data.List (isInfixOf)
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
import           Data.Typeable
import           FP.API as API
import           FP.API.Dispatch
import           FP.API.Signal
import           FP.API.Convert

import           Language.Fay.Yesod (Returns(..))
import           Prelude hiding (FilePath)
import           System.Timeout

data ClientRoute = MiscCommandRoute
                 | IdeMessagesRoute API.ProjectId
                 | IdeAsyncCommandRoute API.ProjectId
    deriving (Eq, Ord, Show)

class ( Applicative m, MonadIO m, MonadBaseControl IO m
      , Applicative m', MonadIO m', MonadBaseControl IO m')
     => FpClient m m' | m -> m' where
   runCallback :: m' a -> m a
   clientInfo :: m (ClientInfo m')
   makeRequest :: (Data command, Show command)
               => Text
               -> Int
               -> ClientRoute
               -> command
               -> m (Maybe LBS.ByteString)

data ClientInfo m' = ClientInfo
    { ciProjId :: API.ProjectId
    , ciCallbacks :: ProjectCallbacks m'
    , ciTokens :: IORef (M.Map EncFileName FayTutorialToken)
    , ciCompileId :: TVar (Maybe CompileId)
    , ciSessionId :: TVar (Maybe SessionId)
    , ciLastStatus :: TVar (Maybe ProjectStatusSnapshot)
    , ciTimeout :: Int
    }

newClientInfo :: Int -> ProjectId -> IO (ClientInfo m')
newClientInfo ciTimeout ciProjId = do
    ciCallbacks <- liftIO defaultProjectCallbacks
    ciTokens <- liftIO $ newIORef mempty
    ciLastStatus <- liftIO $ newTVarIO Nothing
    ciSessionId <- liftIO $ newTVarIO Nothing
    ciCompileId <- liftIO $ newTVarIO Nothing
    return $ ClientInfo {..}

data ProjectCallbacks m' = ProjectCallbacks
    { pcJobs :: IORef (Join API.JobId (Either Text Value -> m' ()) (Either Text Value))
    , pcMessage :: Signal m' (LogLevel, Text)
    , pcProcessOutput :: Signal m' (ProcId, StdoutResult)
    , pcNewStatus :: Signal m' ProjectStatusSnapshot
    , pcProjectClosed :: Signal m' ()
    }

defaultProjectCallbacks :: IO (ProjectCallbacks m')
defaultProjectCallbacks = ProjectCallbacks
    <$> newIORef emptyJoin
    <*> newSignal
    <*> newSignal
    <*> newSignal
    <*> newSignal

data ClientException = ClientException Text
  deriving (Typeable)

instance Exception ClientException

instance Show ClientException where
  show (ClientException msg) = "ClientException: " ++ T.unpack msg

clientFail :: Text -> a
clientFail = throw . ClientException

-- Messages polling.

data Join k a b = Join (M.Map k a) (M.Map k b)

emptyJoin :: Ord k => Join k a b
emptyJoin = Join mempty mempty

joinAInput :: Ord k => Join k a b -> k -> a -> (Join k a b, Maybe b)
joinAInput (Join as bs) k a =
    case M.lookup k bs of
        Nothing -> (Join (M.insert k a as) bs, Nothing)
        Just b -> (Join as (M.delete k bs), Just b)

joinBInput :: Ord k => Join k a b -> k -> b -> (Join k a b, Maybe a)
joinBInput (Join as bs) k b =
    case M.lookup k as of
        Nothing -> (Join as (M.insert k b bs), Nothing)
        Just a -> (Join (M.delete k as) bs, Just a)

pollProjectMessages :: FpClient m m' => m ()
pollProjectMessages = do
    ClientInfo {..} <- clientInfo
    let loop req = do
            res <- makeFayCall (IdeMessagesRoute ciProjId) (GetProjectMessages req)
            case res of
                -- FIXME mgs: This probably needs the same pause/resume logic as
                -- in the Fay code.
                Failure e | "Server session not yet ready" `isInfixOf` show e -> do
                    liftIO $ threadDelay 100000
                    loop req
                Failure e -> do
                    liftIO $ putStrLn "Failure in pollProjectMessages"
                    clientFail e
                Success (ProjectMessagesOutput msnap hash highestMsg xs mbid) -> do
                    -- NOTE: it might be advantageous to instead have
                    -- another thread, fed by a channel, to handle the
                    -- callbacks.  This way, they won't block subsequent
                    -- requests.
                    mapM_ handleMessage xs
                    case msnap of
                        Nothing -> return ()
                        Just snap -> do
                            liftIO $ atomically $ writeTVar ciLastStatus (Just snap)
                            runCallback $ sendSignal (pcNewStatus ciCallbacks) snap
                    loop $ PMRLaterRequest highestMsg hash mbid
    -- Make sure the project is actually started
    void $ makeRequest "polling messages"
                       200
                       (IdeAsyncCommandRoute ciProjId)
                       (GetInitialProjectInfo "handleMessage" Returns)
    loop PMRFirstRequest

handleMessage :: FpClient m m' => RunnerMessage -> m ()
handleMessage inp = do
    ClientInfo {..} <- clientInfo
    let pc = ciCallbacks
    case inp of
        IdeCommandOutput jid txt ->
            case decode (LBS.fromChunks [encodeUtf8 txt]) of
                Nothing -> clientFail $ "Failed to json decode " <> txt
                Just v -> runCallback $ jobResult ciCallbacks jid (Right v)
        JobException jid e -> runCallback $ jobResult ciCallbacks jid (Left e)
        ProcessOutput procid v -> runCallback $ sendSignal (pcProcessOutput pc) (procid, SRSuccess v)
        ProcessStopped procid pr -> runCallback $ sendSignal (pcProcessOutput pc) (procid, SRTerminated pr)
        ProjectMessage level msg -> runCallback $ sendSignal (pcMessage pc) (level, msg)
        ProjectHasClosed sid True _ -> do
            liftIO $ atomically $ do
                mcurrSid <- readTVar ciSessionId
                when (mcurrSid == Just sid) $ do
                    writeTVar ciCompileId Nothing
                    writeTVar ciSessionId Nothing
            runCallback $ sendSignal (pcProjectClosed pc) ()

            -- Emulate the Fay client code which sends a command to
            --  force the project to restart on the server.
            void $ makeRequest "restarting session"
                               200
                               (IdeAsyncCommandRoute ciProjId)
                               (Ping Returns)
        ProjectHasClosed _sid False e -> error $ "handleMessage: Encountered ProjectHasClosed False: " ++ T.unpack e
        --TODO: use this (probably only relevant to the emacs client)
        JobStillRunning _ -> return ()
        CompileComplete{} -> return ()
        ProjectHasOpened sid -> liftIO $ atomically $ do
            oldSid <- readTVar ciSessionId
            when (oldSid /= Just sid) $ do
                writeTVar ciCompileId Nothing
                writeTVar ciSessionId $ Just sid
        GitShellOutput _ _ -> return ()

jobResult :: MonadIO m'
          => ProjectCallbacks m'
          -> JobId -> Either Text Value -> m' ()
jobResult pc jid x = do
    mf <- liftIO $ atomicModifyIORef (pcJobs pc) $ \jobs ->
        joinBInput jobs jid x
    case mf of
        Nothing -> return ()
        Just f -> f x

jobCallback :: MonadIO m'
            => ProjectCallbacks m'
            -> JobId
            -> (Either Text Value -> m' ())
            -> m' ()
jobCallback pc jid f = do
    mx <- liftIO $ atomicModifyIORef (pcJobs pc) $ \jobs ->
        joinAInput jobs jid f
    case mx of
        Nothing -> return ()
        Just x -> f x

-- Convenient wrappers over ide commands.

ideCommand :: (Data command, Show command, Data a, Show a, FpClient m m')
           => (Returns' a -> command)
           -> m a
ideCommand cmd = do
    let shownCmd = show (cmd Returns)
    eres <- makeFayAsyncCall cmd
    case eres of
        Left e -> clientFail (T.pack shownCmd <> " failed with: " <> e)
        Right x -> return x

-- | (for testing purposes)
ideCommandFail :: forall command a m m'. (Data command, Show command, Data a, Show a, FpClient m m')
               => (Returns' a -> command)
               -> m ()
ideCommandFail cmd = do
    let shownCmd = show (cmd Returns)
    eeres <- try $ makeFayAsyncCall cmd
    case (eeres :: Either SomeException (Either Text a)) of
        Right (Right x) -> clientFail (T.pack shownCmd <> " expected to fail, but it succeeded with " <> T.pack (show x))
        _ -> return ()

makeFayAsyncCall :: forall command a m m'. (Data command, Show command, Data a, Show a, FpClient m m')
                 => (Returns' a -> command) -> m (Either Text a)
makeFayAsyncCall cmd = do
    ClientInfo {..} <- clientInfo
    let shownCmd = show (cmd Returns)
    jid <- makeFayCall'
        (IdeAsyncCommandRoute ciProjId)
        (cmd Returns)
    var <- liftIO newEmptyTMVarIO
    runCallback $ jobCallback ciCallbacks jid (liftIO . atomically . putTMVar var)
    mres <- liftIO $ timeout ciTimeout $ atomically $ takeTMVar var
    case mres of
        Nothing -> clientFail $ "Call timed out: " <> T.pack shownCmd
        Just (Left err) -> return $ Left err
        Just (Right val) ->
            case decodeFpco val of
                Left err -> clientFail $ "Failed to parse response to " <> T.pack shownCmd <> ": " <> T.pack err
                Right (Success x) -> do
                    didRestart <- liftIO $ atomically $ updateSessionCompileId ciCompileId ciSessionId x
                    when didRestart $
                        void $ makeRequest "restarting session"
                                           200
                                           (IdeAsyncCommandRoute ciProjId)
                                           (Ping Returns)
                    return $ Right x
                Right (Failure e) -> return $ Left e

updateSessionCompileId :: (Show a, Data a)
                       => TVar (Maybe CompileId)
                       -> TVar (Maybe SessionId)
                       -> a
                       -> STM Bool
updateSessionCompileId cidVar sidVar a =
    case listify (const True) a of
        [RunnerProjectClosed (Just sid)] -> do
            mcurrSid <- readTVar sidVar
            when (mcurrSid == Just sid) $ do
                writeTVar cidVar Nothing
                writeTVar sidVar Nothing
            return True
        [RunnerProjectClosed Nothing] -> error "updateSessionCompileId: RunnerProjectClosed Nothing"
        [] -> do
            go $ writeTVar cidVar . Just
            go $ writeTVar sidVar . Just
            return False
        x@(_:_) -> error $ "updateSessionCompileId: multiple RunnerProjectClosed: " ++ show x
  where
    go :: (Show b, Monad m, Typeable b) => (b -> m ()) -> m ()
    go f =
        case listify (const True) a of
            [] -> return ()
            [b] -> f b
            bs -> error $ "updateSessionCompileId: multiple values returned in: " ++ show (a, bs)

fayCommand :: (Data command, Show command, Data a, FpClient m m')
           => (Returns' a -> command)
           -> m a
fayCommand = callFay MiscCommandRoute

callFay :: (Data command, Show command, Data a, FpClient m m')
        => ClientRoute
        -> (Returns' a -> command)
        -> m a
callFay r cmd = do
    res <- makeFayCall r cmd
    case res of
        Failure e -> clientFail ("Due to call of " <> T.pack (show (cmd Returns)) <> ": " <> T.pack (show e))
        Success s -> return s

makeFayCall :: (Data command, Show command, Data a, FpClient m m')
            => ClientRoute
            -> (Returns a -> command)
            -> m a
makeFayCall r cmd = makeFayCall' r (cmd Returns)

-- | This is the same thing as 'makeFayCall', but with a less
-- restrictive type that doens't enforce that the return type of the
-- command is correct.
makeFayCall' :: (Data command, Show command, Data a, FpClient m m')
             => ClientRoute
             -> command
             -> m a
makeFayCall' r cmd = do
    handleServerResponse (show cmd) =<< makeRequest "running a command" 200 r cmd

handleServerResponse :: (Data a, Monad m) => String -> Maybe LBS.ByteString -> m a
handleServerResponse (T.pack -> shownCmd) mres =
    case mres of
        Nothing -> clientFail $ "No response to " <> shownCmd
        Just body ->
            case decode body of
                Nothing -> clientFail $
                    "Could not parse JSON of response to " <> shownCmd <>
                    ".  Here's the response: " <> decodeUtf8 (BS.concat (LBS.toChunks body))
                Just json ->
                    case decodeFpco json of
                        Left err -> clientFail $
                            "Error interpreting response from " <> shownCmd <>
                            ".  Here's the error: " <> T.pack err
                        Right x -> return x

-- Generate function equivalents for all of the fay command constructors.
$(mkFayCommands
    [ (''IdeCommand, 'ideCommand, id)
    , (''IdeCommand, 'ideCommandFail, (++ "Fail"))
    , (''FayCommand, 'fayCommand, id)
    ])

-- Wrappers around commands that yield / consume FayTutorialTokens,
-- automatically managing the map of tokens.

addFile' :: FpClient m m' => NewFileInfo -> m (Maybe CompileDesc)
addFile' nfi = do
    SaveFileOutput tok mdesc <- addFile nfi
    updateToken (encFileNameFromText (fiPath nfi)) tok
    return mdesc

saveFile' :: FpClient m m' => EncFileName -> Text -> m (Maybe CompileDesc)
saveFile' efn content = do
    ClientInfo {..} <- clientInfo
    mtok <- liftIO $ M.lookup efn <$> readIORef ciTokens
    case mtok of
        Nothing -> do
            liftIO $ do
                putStrLn $ "Attempted to save to a non-existent file: " ++ unEncFileNameString efn
                putStrLn "Updating its token..."
            tok <- updateFileToken efn
            doSave tok
        Just tok -> doSave tok
  where
    doSave tok = do
        SaveFileOutput tok' mdesc <- saveFile efn content tok
        updateToken efn tok'
        return mdesc


deleteFile' :: FpClient m m' => EncFileName -> m (Maybe CompileDesc)
deleteFile' efn = do
    mdesc <- deleteFile efn
    modifyTokens (M.delete efn)
    return mdesc

renameFile' :: FpClient m m' => EncFileName -> NewFileInfo -> RenameType -> m RenameFileOutput
renameFile' efn nfi rtyp = do
    output <- renameFile efn nfi rtyp
    case output of
        RenameFileOutput (Just tok) _ _ ->
            modifyTokens (M.insert (encFileNameFromText (fiPath nfi)) tok . M.delete efn)
        _ -> return ()
    return output

updateFileToken :: FpClient m m' => EncFileName -> m FayTutorialToken
updateFileToken efn = do
    tok <- getFileToken efn
    updateToken efn tok
    return tok

getFile' :: FpClient m m' => EncFileName -> m (Maybe Text)
getFile' efn = do
    FayFileContent mcontent tok <- getFile efn
    updateToken efn tok
    return mcontent

-- Utilities for token handling.

updateToken :: FpClient m m' => EncFileName -> FayTutorialToken -> m ()
updateToken efn tok = modifyTokens (M.insert efn tok)

modifyTokens :: FpClient m m' => (M.Map EncFileName FayTutorialToken -> M.Map EncFileName FayTutorialToken) -> m ()
modifyTokens f = do
    ClientInfo {..} <- clientInfo
    liftIO $ atomicModifyIORef ciTokens ((,()) . f)

-- Utility for waiting for a particular status.

watchStatusOneShot :: FpClient m m'
                   => String
                   -> Maybe Int
                   -> (ProjectStatusSnapshot -> m' (Maybe a))
                   -> m a
watchStatusOneShot msg mmicros f = do
    ClientInfo {..} <- clientInfo
    mlastStatus <- liftIO $ readTVarIO ciLastStatus
    mres <- case mlastStatus of
              Nothing -> return Nothing
              Just lastStatus -> runCallback $ f lastStatus
    case mres of
        Just res -> return res
        Nothing -> do
            mres' <- liftIO $
                blockOnSignal mmicros (pcNewStatus ciCallbacks) f
            case mres' of
                Nothing -> fail $ msg ++ " timed out while blocking on status."
                Just res -> return res