Run.hs

{-# 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
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.String
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 hiding (catch)
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       :: String
  , ccToken     :: String
  , 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 <- parseUrl (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","token " <> fromString token)]
              , responseTimeout = Nothing
              , cookieJar = jar
              }
        trunc :: Text -> Text
        trunc = ellipsize 140
        errprefix = "Error from request: " <> T.pack (show (cmd Returns)) <> "\n"