module ReviewBoard.Core (
RBAction,
RBState(..),
runRBAction,
setErrorHandler,
RBStatus(..),
RBResponse(..),
runRequest,
liftBA,
mkURI,
setDebugHTTP,
jsValue,
jsInt,
jsString
) where
import Text.JSON
import Network.URI
import Network.HTTP
import qualified Network.Browser as NB
import ReviewBoard.Browser
import Data.Maybe
import Control.Monad.Error
import Control.Monad.State
import Data.Ratio
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 RBStatus
= RBok
| RBerr String
deriving Eq
instance Show RBStatus where
show RBok = "Successful"
show (RBerr e) = "Error: " ++ e
data RBResponse = RBResponse
{ rbRspStatus :: RBStatus
, rbRspBody :: JSValue
}
instance Show RBResponse where
show rsp = show (rbRspStatus rsp) ++ "\n" ++
"Response: " ++ encode (rbRspBody rsp)
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 -> do
let st = status rsp
case st of
RBok -> handle f st rsp
RBerr e -> do
liftIO $ (rbErrHandler s) $ concat [e, " (Response: ", encode rsp, ")"]
handle f st rsp
Error e -> throwError e
c -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")"
where
attachSID (Just sid) = NB.setCookies [sid]
attachSID _ = return ()
handle :: (RBResponse -> RBAction a) -> RBStatus -> JSValue -> RBAction a
handle f st rsp = f $ RBResponse st rsp
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
status :: JSValue -> RBStatus
status v =
case jsString ["stat"] v of
Just "ok" -> RBok
Just "fail" -> case jsString ["err", "msg"] v of
Just m -> RBerr m
Nothing -> RBerr "No error message found."
Nothing -> RBerr "Invalid response, no status message."
liftBA :: NB.BrowserAction a -> RBAction a
liftBA = RBAction . lift . lift
mkURI :: String -> RBAction URI
mkURI apiUrl = do
s <- get
case parseURI (rbUrl s ++ "/api/json/" ++ apiUrl ++ "/") of
Just u -> return u
Nothing -> throwError $ "Invalid url: " ++ rbUrl s
setDebugHTTP :: Bool -> RBAction ()
setDebugHTTP True = liftBA $ NB.setOutHandler putStrLn
setDebugHTTP False = liftBA $ NB.setOutHandler (\_ -> return())
jsValue :: [String] -> JSValue -> Maybe JSValue
jsValue [] v = Just v
jsValue (x:xs) (JSObject m) = maybe Nothing (jsValue xs) $ findValue x (fromJSObject m)
jsValue (x:xs) v = Nothing
findValue :: String -> [(String, JSValue)] -> Maybe JSValue
findValue s [] = Nothing
findValue s ((n, v):xs) | s == n = Just v
| otherwise = findValue s xs
jsInt :: [String] -> JSValue -> Maybe Integer
jsInt p v = case jsValue p v of
Just (JSRational i) -> Just (numerator i)
_ -> Nothing
jsString :: [String] -> JSValue -> Maybe String
jsString p v = case jsValue p v of
Just (JSString s) -> Just $ fromJSString s
_ -> Nothing