module Network.Mollom
( getServerList
, checkContent
, sendFeedback
, getImageCaptcha
, getAudioCaptcha
, checkCaptcha
, getStatistics
, verifyKey
, detectLanguage
, addBlacklistText
, removeBlacklistText
, listBlacklistText
, addBlacklistURL
, removeBlacklistURL
, listBlacklistURL
, MollomConfiguration(..)
, MollomValue(..)
) where
import Control.Arrow (second)
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Data.Maybe(fromJust, isJust)
import Network.XmlRpc.Client
import Network.XmlRpc.Internals
import Network.Mollom.Internals
import Network.Mollom.Auth
import Network.Mollom.MollomMonad
mollomFallbackServer :: String
mollomFallbackServer = "http://xmlrpc2.mollom.com/"
hardCodedMollomServerList :: [String]
hardCodedMollomServerList = ["http://xmlrpc1.mollom.com", "http://xmlrpc2.mollom.com", "http://xmlrpc3.mollom.com"]
data MollomRequest = MollomRequest [(String, String)]
retrieveNewServerList :: MollomConfiguration -> IO (Maybe [String])
retrieveNewServerList config = do
let publicKey = mcPublicKey config
privateKey = mcPrivateKey config
apiVersion = mcAPIVersion config
requestStruct = getAuthenticationInformation publicKey privateKey
newServerList <- rsl requestStruct apiVersion hardCodedMollomServerList
case newServerList of
Left s -> return Nothing
Right sl -> return $ Just sl
rsl :: [(String, String)] -> String -> [String] -> IO (Either String [String])
rsl _ _ [] = return $ Left "Error: no more servers left"
rsl rq a (server:ss) = do
response <- service' rq server a "mollom.getServerList"
case response of
Left s -> rsl rq a ss
Right v -> return $ Right v
service :: XmlRpcType a
=> String
-> MollomRequest
-> ErrorT MollomError MollomState a
service function (MollomRequest fields) = do
config <- ask
let publicKey = mcPublicKey config
privateKey = mcPrivateKey config
apiVersion = mcAPIVersion config
requestStruct = getAuthenticationInformation publicKey privateKey ++ fields
serviceLoop config requestStruct apiVersion function
serviceLoop :: XmlRpcType a => MollomConfiguration -> [(String, String)] -> String -> String -> ErrorT MollomError MollomState a
serviceLoop config r a f = serviceLoop'
where serviceLoop' = do serverList <- get
case serverList of
UninitialisedServerList -> refetchAndLoop
MollomServerList [] -> throwError MollomNoMoreServers
MollomServerList (server:ss) -> do response <- liftIO $ service' r server a f
case response of
Left s -> case take 10 s of
"Error 1100" -> refetchAndLoop
"Error 1000" -> throwError MollomInternalError
_ -> put (MollomServerList ss) >> serviceLoop'
Right v -> return v
refetchAndLoop = do nsl <- liftIO $ retrieveNewServerList config
case nsl of
Nothing -> throwError MollomNoMoreServers
Just sl -> put (MollomServerList sl) >> serviceLoop'
service' :: XmlRpcType a => [(String, String)] -> String -> String -> String -> IO (Either String a)
service' requestStruct server api function = do
response <- runErrorT $ call (mollomFallbackServer ++ mollomApiVersion ++ "/") function [toValue . map (second toValue) $ requestStruct]
case response of
Left s -> return $ Left s
Right v -> runErrorT $ fromValue v
returnStateT a = StateT $ \s -> liftM (flip (,) s) a
getServerList :: MollomMonad [String]
getServerList = do
put Nothing
response <- ErrorT . returnStateT . runErrorT $ service "mollom.getServerList" (MollomRequest [])
lift . lift . put $ MollomServerList response
return response
checkContent :: [(String, String)]
-> MollomMonad [(String, MollomValue)]
checkContent ds = do
response <- ErrorT . returnStateT . runErrorT $ service "mollom.checkContent" (MollomRequest ds)
case lookup "session_id" response of
Nothing -> put Nothing
Just (MString sessionID) -> put $ Just sessionID
return response
sendFeedback :: String
-> MollomMonad Bool
sendFeedback feedback = do
sessionID <- get
case sessionID of
Nothing -> throwError $ HMollomError "Mollom Error: no session ID provided"
Just s -> do let mRequest = MollomRequest [("session_id", s), ("feedback", feedback)]
ErrorT . returnStateT . runErrorT $ service "mollom.sendFeedback" mRequest
getImageCaptcha :: Maybe String
-> MollomMonad [(String, MollomValue)]
getImageCaptcha authorIP = do
sessionID <- get
let mRequest = MollomRequest $ map (second fromJust) $ filter (isJust . snd) [("session_id", sessionID), ("author_ip", authorIP)]
response <- ErrorT . returnStateT . runErrorT $ service "mollom.getImageCaptcha" mRequest
case lookup "session_id" response of
Nothing -> put Nothing
Just (MString s) -> put $ Just s
return response
getAudioCaptcha :: Maybe String
-> MollomMonad [(String, MollomValue)]
getAudioCaptcha authorIP = do
sessionID <- get
let mRequest = MollomRequest $ map (second fromJust) $ filter (isJust . snd) [("session_id", sessionID), ("author_ip", authorIP)]
response <- ErrorT . returnStateT . runErrorT $ service "mollom.getAudioCaptcha" mRequest
case lookup "session_id" response of
Nothing -> put Nothing
Just (MString s) -> put $ Just s
return response
checkCaptcha :: String
-> MollomMonad Bool
checkCaptcha solution = do
let sessionID = Just "ll"
case sessionID of
Nothing -> throwError (HMollomError "Mollom Error: no session ID provided")
Just s -> do let mRequest = MollomRequest [("session_id", s), ("solution", solution)]
ErrorT . returnStateT . runErrorT $ service "mollom.checkCaptcha" mRequest
getStatistics :: String
-> MollomMonad Int
getStatistics statType = do
let mRequest = MollomRequest [("type", statType)]
ErrorT . returnStateT . runErrorT $ service "mollom.getStatistics" mRequest
verifyKey :: MollomMonad Bool
verifyKey = ErrorT . returnStateT . runErrorT $ service "mollom.verifyKey" (MollomRequest [])
detectLanguage :: String
-> MollomMonad [[(String, MollomValue)]]
detectLanguage text = ErrorT . returnStateT . runErrorT $ service "mollom.detectLanguage" (MollomRequest [("text", text)])
addBlacklistText :: String
-> String
-> String
-> MollomMonad Bool
addBlacklistText text match reason = do
let mRequest = MollomRequest [("text", text), ("match", match), ("reason", reason)]
ErrorT . returnStateT . runErrorT $ service "mollom.addBlacklistText" mRequest
removeBlacklistText :: String
-> MollomMonad Bool
removeBlacklistText text = do
let mRequest = MollomRequest [("text", text)]
ErrorT . returnStateT . runErrorT $ service "mollom.removeBlacklistText" mRequest
listBlacklistText :: MollomMonad [[(String, MollomValue)]]
listBlacklistText = ErrorT . returnStateT . runErrorT $ service "mollom.listBlacklistText" (MollomRequest [])
addBlacklistURL :: String
-> MollomMonad Bool
addBlacklistURL url = do
let mRequest = MollomRequest [("url", url)]
ErrorT . returnStateT . runErrorT $ service "mollom.addBlacklistURL" mRequest
removeBlacklistURL :: String
-> MollomMonad Bool
removeBlacklistURL url = do
let mRequest = MollomRequest [("url", url)]
ErrorT . returnStateT . runErrorT $ service "mollom.removeBlacklistURL" mRequest
listBlacklistURL :: MollomMonad [[(String, MollomValue)]]
listBlacklistURL = ErrorT . returnStateT . runErrorT $ service "mollom.listBlacklistURL" (MollomRequest [])