module ReviewBoard.Core (
RBAction,
runRBAction,
liftBA,
runRequest,
RBState(..),
setErrorHandler,
setDebugHTTP,
RBResponse(..),
responseToEither,
mkURI
) where
import Network.URI
import Network.HTTP
import qualified Network.Browser as NB
import ReviewBoard.Browser
import qualified ReviewBoard.Response as R
import Control.Monad.Error
import Control.Monad.State
import Data.Maybe
import Text.JSON
newtype RBAction a = RBAction
{ exec :: ErrorT String (StateT RBState NB.BrowserAction) a }
deriving (Functor, Monad, MonadState RBState)
instance MonadIO RBAction where
liftIO = RBAction . lift . lift . NB.ioAction
instance MonadError String RBAction where
throwError = RBAction . throwError
l `catchError` h = RBAction $ exec l `catchError` (exec . h)
runRBAction :: String -> String -> String -> RBAction a -> IO (Either String a, RBState)
runRBAction url u p a = NB.browse . runStateT (runErrorT (exec init)) $ initState url u
where init = setDebugHTTP False >> login u p >> a
data RBState = RBState
{ rbUrl :: String
, rbUser :: String
, rbSessionId :: Maybe NB.Cookie
, rbErrHandler :: String -> IO ()
}
initState :: String -> String -> RBState
initState url user = RBState
{ rbUrl = url
, rbUser = user
, rbSessionId = Nothing
, rbErrHandler = print }
setSessionId :: NB.Cookie -> RBAction ()
setSessionId sid = get >>= \s -> put s { rbSessionId = Just sid }
setErrorHandler :: (String -> IO ()) -> RBAction ()
setErrorHandler eh = get >>= \s -> put s { rbErrHandler = eh }
data RBResponse
= RBok JSValue
| RBerr String
deriving Eq
instance Show RBResponse where
show (RBok r) = "Ok: " ++ encode r
show (RBerr e) = "Error: " ++ e
responseToEither :: RBResponse -> Either String JSValue
responseToEither (RBok r) = Right r
responseToEither (RBerr s) = Left s
runRequest :: Form -> (RBResponse -> RBAction a) -> RBAction a
runRequest form f = do
s <- get
(u, r) <- liftBA $ do
attachSID $ rbSessionId s
formToRequest form >>= NB.request
case rspCode r of
(2,0,0) -> do
case (decode . rspBody) r of
Ok rsp -> mkResponse rsp >>= handle f (rbErrHandler s)
Error e -> throwError e
c -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")"
where
attachSID (Just sid) = NB.setCookies [sid]
attachSID _ = return ()
handle :: (RBResponse -> RBAction a) -> (String -> IO ()) -> RBResponse -> RBAction a
handle f _ o@(RBok r) = f o
handle f eh o@(RBerr e) = liftIO (eh e) >> f o
login :: String -> String -> RBAction RBResponse
login user password = do
s <- get
uri <- mkURI "accounts/login/"
let form = Form POST uri [textField "username" user, textField "password" password]
runRequest form setSessionCookie
where
setSessionCookie rsp = liftBA NB.getCookies >>= setCookie >> return rsp
setCookie [] = throwError "No session cookie found!"
setCookie (c:cs) = setSessionId c
mkResponse :: JSValue -> RBAction RBResponse
mkResponse v = do
stat <- (return $ R.stat v) `catchError` (\_ -> return "")
case stat of
"ok" -> return $ RBok v
"fail" -> do
err <- (return $ (R.msg . R.err) v) `catchError` (\_ -> return "No error message received")
return $ RBerr (err ++ " (" ++ encode v ++ ")")
_ -> return $ RBerr "Invalid response, not status received"
liftBA :: NB.BrowserAction a -> RBAction a
liftBA = RBAction . lift . lift
mkURI :: String -> RBAction URI
mkURI apiUrl = do
s <- get
let url = rbUrl s ++ "/api/json/" ++ apiUrl
case parseURI url of
Just u -> return u
Nothing -> throwError $ "Invalid url: " ++ url
setDebugHTTP :: Bool -> RBAction ()
setDebugHTTP True = liftBA $ NB.setOutHandler putStrLn
setDebugHTTP False = liftBA $ NB.setOutHandler (\_ -> return())