module ReviewBoard.Core (
RBAction,
runRBAction,
liftBA,
runRequest,
RBRequestType(..),
RBState(..),
setErrorHandler,
setDebugHTTP,
RBResponse(..),
responseToEither,
mkApiURI,
mkHttpURI
) 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 RBRequestType
= API
| HTTP
deriving Show
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 :: RBRequestType -> Form -> (RBResponse -> RBAction a) -> RBAction a
runRequest rt form f = do
s <- get
(u, r) <- liftBA $ do
attachSID $ rbSessionId s
formToRequest form >>= NB.request
case rspCode r of
(2,0,0) -> respond rt r s
c -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")"
where
attachSID (Just sid) = NB.setCookies [sid]
attachSID _ = return ()
respond API r s = case (decode . rspBody) r of
Ok rsp -> mkApiResponse rsp >>= handle f (rbErrHandler s)
Error e -> throwError e
respond HTTP r s = mkHttpResponse r >>= handle f (rbErrHandler s)
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 <- mkApiURI "accounts/login/"
let form = Form POST uri [textField "username" user, textField "password" password]
runRequest API form setSessionCookie
where
setSessionCookie rsp = liftBA NB.getCookies >>= setCookie >> return rsp
setCookie [] = throwError "No session cookie received!"
setCookie (c:cs) = setSessionId c
mkApiResponse :: JSValue -> RBAction RBResponse
mkApiResponse 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"
mkHttpResponse :: Response -> RBAction RBResponse
mkHttpResponse r = return $ RBok . JSObject . toJSObject $
[ ("head", mkHead (rspHeaders r))
, ("body", mkBody (rspBody r)) ]
where
mkHead = JSArray . map (\(Header n v) -> JSObject . toJSObject $
[ ("name", JSString . toJSString . show $ n)
, ("value", JSString . toJSString $ v)])
mkBody = JSString . toJSString
liftBA :: NB.BrowserAction a -> RBAction a
liftBA = RBAction . lift . lift
mkApiURI :: String -> RBAction URI
mkApiURI apiUrl = mkURI ("/api/json/" ++ apiUrl)
mkHttpURI = mkURI
mkURI :: String -> RBAction URI
mkURI url = do
s <- get
case parseURI (rbUrl s ++ 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())