{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}

-- | Function for running arbitrary IDE API commands.

module FP.API.Run
  where

import           FP.API.Convert
import           FP.API.Types

import           Control.Exception as E
import           Control.Failure
import           Control.Monad.Extra
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Data.Aeson                   (decode, encode)
import           Data.ByteString.Lazy         (toChunks)
import           Data.Data
import           Data.IORef
import           Data.Monoid
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import           Data.Text.Encoding           (encodeUtf8)
import           Language.Fay.Yesod           (Returns (..))
import           Network.HTTP.Conduit
import           Network.HTTP.Types.Status
import           Prelude
import           Texts.English

-- | Only used internally for encoding.
data Command = IdeCommand !IdeCommand
  deriving Show

-- | Monad that can get info for sending commands.
class (Failure HttpException m,MonadIO m,Functor m) => MonadClient m where
  getClientConfig :: m ClientConfig

-- | Simple command configuration.
data ClientConfig = CC
  { ccUrl       :: !Text
  , ccToken     :: !Text
  , ccManager   :: !Manager
  , ccCookie    :: !(IORef CookieJar)
  , ccUserAgent :: !Text
  }

data CommandException
  = CommandException Text
   deriving (Show,Typeable)
instance Exception CommandException

-- | Helpful simple client instance.
instance (Failure HttpException m,MonadIO m,Functor m) => MonadClient (ReaderT ClientConfig m) where
  getClientConfig = ask

-- | Run the given command.
runCommand :: (MonadLogger m,MonadClient m,Data a,Show a) => (Returns' a -> IdeCommand) -> m a
runCommand cmd = do
  CC{..} <- getClientConfig
  request <- io $ parseUrl (T.unpack (ccUrl <> "/fay-command"))
  jar <- io $ readIORef ccCookie
  let req = urlEncodedBody params $ setup ccToken request (Just jar) ccUserAgent
  $(logDebug) ("=> " <> trunc (T.pack (show (IdeCommand (cmd Returns)))))
  resp <- io (runResourceT (httpLbs req ccManager))
  io $ writeIORef ccCookie (responseCookieJar resp)
  case statusCode (responseStatus resp) of
    200 -> do
      case decode (responseBody resp) >>= readFromFay' of
        Nothing -> do $(logDebug) (errprefix <> "<= [unable to decode] " <> T.pack (show (responseBody resp)))
                      error $ "Unable to decode response: " ++ show (responseBody resp)
        Just result ->
          case result of
            Failure e -> do $(logDebug) (errprefix <> "<= " <> trunc e)
                            throw (CommandException e)
            Success a -> do $(logDebug) ("<= " <> trunc (T.pack (show a)))
                            return a
    code -> throw (CommandException ("Bad status code returned from client command: " <> T.pack (show code)))

  where params =
          [("json",mconcat (toChunks (encode (showToFay' (IdeCommand (cmd Returns))))))]
        setup token req jar agent =
          req { method = "POST"
              , requestHeaders = requestHeaders req ++
                                 [("Accept","application/json")
                                 ,("User-Agent",encodeUtf8 ("fpco-api:" <> agent))
                                 ,("authorization",encodeUtf8 ("token " <> token))]
              , responseTimeout = Nothing
              , cookieJar = jar
              }
        trunc :: Text -> Text
        trunc = ellipsize 140
        errprefix = "Error from request: " <> T.pack (show (cmd Returns)) <> "\n"