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
data Command = IdeCommand !IdeCommand
deriving Show
class (Failure HttpException m,MonadIO m,Functor m) => MonadClient m where
getClientConfig :: m ClientConfig
data ClientConfig = CC
{ ccUrl :: !Text
, ccToken :: !Text
, ccManager :: !Manager
, ccCookie :: !(IORef CookieJar)
, ccUserAgent :: !Text
}
data CommandException
= CommandException Text
deriving (Show,Typeable)
instance Exception CommandException
instance (Failure HttpException m,MonadIO m,Functor m) => MonadClient (ReaderT ClientConfig m) where
getClientConfig = ask
runCommand :: (MonadLogger m,MonadClient m,Data a,Show a) => (Returns' a -> IdeCommand) -> m a
runCommand cmd = do
CC{..} <- getClientConfig
request <- 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"