hMollom 0.1.1 → 0.2

raw patch · 5 files changed

+294/−167 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hMollom.cabal +3/−1
• src/Network/Mollom.hs +171/−166
• src/Network/Mollom/Auth.hs +10/−0
• src/Network/Mollom/Internals.hs +62/−0
• src/Network/Mollom/MollomMonad.hs +48/−0

@@ -1,5 +1,5 @@ name:                hMollom-version:             0.1.1+version:             0.2 cabal-version:       >= 1.6 stability:           experimental synopsis:            Library to interact with the Mollom anti-spam service@@ -12,6 +12,8 @@ maintainer:          itkovian@gmail.com build-Type:          Simple extra-source-files:  src/Network/Mollom/Auth.hs+                     src/Network/Mollom/Internals.hs+                     src/Network/Mollom/MollomMonad.hs   library

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} -- |Interface to the Mollom API module Network.Mollom   ( getServerList@@ -15,163 +17,180 @@   , addBlacklistURL   , removeBlacklistURL   , listBlacklistURL-  , MollomConn(..)+  , 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.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) +import Network.Mollom.Internals import Network.Mollom.Auth+import Network.Mollom.MollomMonad  -mollomApiVersion :: String-mollomApiVersion = "1.0"- mollomFallbackServer :: String mollomFallbackServer = "http://xmlrpc2.mollom.com/" --- FIXME: This should be specified in some configuration file--- or use the system locale-mollomTimeFormat = "%Y-%m-%dT%H:%M:%S.000+0200" --- |Describes connection with the Mollom server-data MollomConn = MollomConn-  { mcPublicKey :: String-  , mcPrivateKey :: String-  , mcSessionID :: String-  , mcServerList :: [String]-  }---- |A computation that interacts with the Mollom server.-data MollomMonad a = MollomMonad (MollomConn -> IO (a, MollomConn))--instance Monad MollomMonad where-  return a = MollomMonad $ \conn -> return (a, conn)--  (MollomMonad m) >>= k = MollomMonad $ \conn -> do-    (a, conn') <- m conn-    let (MollomMonad m') = k a-    m' conn'-+-- |The hardcoded server list+-- XXX: this should go at the back of the state tracking the serverlist, rather than have it here. When the+-- state tracked list is empty, then we refill it next time with this list+hardCodedMollomServerList :: [String]+hardCodedMollomServerList = ["http://xmlrpc1.mollom.com", "http://xmlrpc2.mollom.com", "http://xmlrpc3.mollom.com"]  data MollomRequest = MollomRequest [(String, String)] -data MollomValue = MInt Int-                 | MBool Bool-                 | MDouble Double-                 | MString String deriving (Show, Eq)+-- | Retrieve a new server list using the MollomMonad approach+-- This is a computation that may fail. Upon failure, we return Nothing.+-- This function should only be called from the service function. There is+-- no fall back if this fails, as we need a valid list of servers to begin with.+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 -instance XmlRpcType MollomValue where-  toValue (MInt i) = toValue i-  toValue (MBool b) = toValue b-  toValue (MDouble d) = toValue d-  toValue (MString s) = toValue s -  fromValue (ValueInt i) = maybeToM "" (Just (MInt i))-  fromValue (ValueBool b) = maybeToM "" (Just (MBool b)) -  fromValue (ValueDouble d) = maybeToM "" (Just (MDouble d))-  fromValue (ValueString s) = maybeToM "" (Just (MString s))-  -  getType (MInt _) = TInt-  getType (MBool _) = TBool-  getType (MDouble _) = TDouble-  getType (MString _) = TString+-- | rsl does the actual polling of the service' function.+-- Keeping this as a top-level function for now. +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  --- | make the actual XML-RPC call to the Mollom servers-service :: XmlRpcType a -        => MollomConn    -- ^connection to the Mollom service-        -> String        -- ^remote function name+-- | The 'service' function implements the basic load balancing scheme from+-- <http://mollom.com/api/client-side-load-balancing>. +--+-- FIXME: It expects the MollomConfiguration record to contain a list of valid servers,+-- obtained either through a cache or a call to getServerList with one of the+-- hardCoded server.+service :: XmlRpcType a+        => String        -- ^remote function name         -> MollomRequest -- ^request specific data -        -> IO a-service conn function (MollomRequest fields) = do-  let publicKey = mcPublicKey conn-      privateKey = mcPrivateKey conn-      timeStamp = getMollomTime mollomTimeFormat-      nonce = getMollomNonce-      hash = authenticate publicKey privateKey timeStamp nonce-      requestStruct = [("public_key", publicKey), ("time", timeStamp), ("hash", hash), ("nonce", nonce)] ++ fields-  response <- remote (mollomFallbackServer ++ mollomApiVersion ++ "/") function requestStruct-  return response-{---- | make the actual XML-RPC call to the Mollom server returning---   the raw XML response, for debug purposes---   This requires that haxr exports the post function!-service__ :: MollomConn    -- ^connection to the Mollom service-          -> String        -- ^remote function name-          -> MollomRequest -- ^request specific data-          -> IO String-service__ conn function (MollomRequest fields) = do-  let publicKey = mcPublicKey conn-      privateKey = mcPrivateKey conn-      timeStamp = getMollomTime mollomTimeFormat-      nonce = getMollomNonce-      hash = authenticate publicKey privateKey timeStamp nonce-  response <- post (mollomFallbackServer ++ mollomApiVersion ++ "/") (renderCall $ MethodCall function [toValue ([("public_key", publicKey), ("time", timeStamp), ("hash", hash), ("nonce", nonce)] ++ fields)] )-  return response-  -}+        -> 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   --- | request a list of Mollom servers that can handle a site's calls.-getServerList :: MollomConn -- ^connection to the Mollom service-              -> IO [String]-- ^list of servers that can be used-getServerList conn  = -  service conn "mollom.getServerList" (MollomRequest [])+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' +-- | Make the actual call to the given Mollom server. +-- +-- We unwrap the ErrorT such that we get the Left error message back when Mollom gives a fault. +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 --- | asks Mollom whether the specified message is legitimate.-checkContent :: MollomConn -- ^connection to the Mollom service-             -> [(String, String)] -- ^data-             -> IO [(String, MollomValue)] -- ^contains spam decision and session ID-checkContent conn ds = -  service conn "mollom.checkContent" (MollomRequest ds) +returnStateT a = StateT $ \s -> liftM (flip (,) s) a +-- | request a list of Mollom servers that can handle a site's calls.+getServerList :: MollomMonad [String]+getServerList = do+  put Nothing -- no session ID here+  response <- ErrorT . returnStateT . runErrorT $ service "mollom.getServerList" (MollomRequest [])+  lift . lift . put $ MollomServerList response+  return response+  +-- | asks Mollom whether the specified message is legitimate.+checkContent :: [(String, String)] -- ^data+             -> MollomMonad [(String, MollomValue)] -- ^contains spam decision and session ID+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 --- | tells Mollom that the specifieed message was spam or otherwise abusive.-sendFeedback :: MollomConn -- ^connection to the Mollom service-             -> String -- ^session ID-             -> String -- ^feedback: "spam", "profanity", "low-quality" or "unwanted"-             -> IO Bool -- ^always returns True-sendFeedback conn sessionID feedback = do             -  service conn  "mollom.sendFeedback" (MollomRequest [("session_id", sessionID), ("feedback", feedback)])+-- | tells Mollom that the specified message was spam or otherwise abusive.+sendFeedback :: String -- ^feedback: "spam", "profanity", "low-quality" or "unwanted"+            -> MollomMonad Bool -- ^always returns true+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   -- | requests Mollom to generate a image CAPTCHA.-getImageCaptcha :: MollomConn -- ^connection to the Mollom service-                -> Maybe String -- ^session ID-                -> Maybe String -- ^author IP address-                -> IO [(String, MollomValue)] -- ^session ID and CAPTCHA url-getImageCaptcha conn sessionID authorIP = do-  let ds = map (\(n, v) -> (n, fromJust v)) $ filter (isJust . snd) [("session_id", sessionID), ("author_ip", authorIP)]-  service conn "mollom.getImageCaptcha" (MollomRequest ds)-+getImageCaptcha :: Maybe String -- ^author IP address+                -> MollomMonad [(String, MollomValue)] -- ^session ID and CAPTCHA url+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  -- | requests Mollom to generate an audio CAPTCHA-getAudioCaptcha :: MollomConn -- ^connection to the Mollom service-                -> Maybe String -- ^session ID-                -> Maybe String -- ^author IP address-                -> IO [(String, MollomValue)] -- ^session ID and CAPTCHA url-getAudioCaptcha conn sessionID authorIP = do-  let ds = map (\(n, v) -> (n, fromJust v)) $ filter (isJust . snd) [("session_id", sessionID), ("author_ip", authorIP)]-  service conn "mollom.getAudioCaptcha" (MollomRequest ds)+getAudioCaptcha :: Maybe String -- ^author IP address+                -> 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 +    -- | requests Mollom to verify the result of a CAPTCHA.-checkCaptcha :: MollomConn -- ^connection to the Mollom service-             -> String -- ^session ID associated with the CAPTCHA-             -> String -- ^solution to the CAPTCHA-             -> IO Bool -- ^True if correct, False if wrong-checkCaptcha conn sessionID solution = do-  let ds = [("session_id", sessionID), ("solution", solution)]-  service conn "mollom.checkCaptcha" (MollomRequest ds)-+checkCaptcha :: String -- ^solution to the CAPTCHA+             -> MollomMonad Bool+checkCaptcha solution = do+  --sessionID <- get+  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  -- | retrieves usage statistics from Mollom.-getStatistics :: MollomConn -- ^connection to the Mollom service-              -> String -- ^type of statistics demanded+getStatistics :: String -- ^type of statistics demanded                         -- total_days — Number of days Mollom has been used.                         -- total_accepted — Total accepted posts.                         -- total_rejected — Total rejected spam posts.@@ -179,78 +198,64 @@                         -- yesterday_rejected — Number of spam posts blocked yesterday.                         -- today_accepted — Number of posts accepted today.                         -- today_rejected — Number of spam posts rejected today.-              -> IO Int -- ^Value of requested statistic-getStatistics conn statType = do-  service conn "mollom.getStatistics" (MollomRequest [("type", statType)])+              -> MollomMonad Int -- ^Value of requested statistic+getStatistics statType = do+  let mRequest = MollomRequest [("type", statType)]+  ErrorT . returnStateT . runErrorT $ service "mollom.getStatistics" mRequest   -- | return a status value.-verifyKey :: MollomConn -- ^connection to the Mollom service-          -> IO Bool -- ^Always returns True-verifyKey conn = do-  service conn "mollom.verifyKey" (MollomRequest [])+verifyKey :: MollomMonad Bool -- ^Always returns True+verifyKey = ErrorT . returnStateT . runErrorT $ service "mollom.verifyKey" (MollomRequest [])   -- | analyze text and return its most likely language code.-detectLanguage :: MollomConn -- ^connection to the Mollom service-              -> String -- ^text to analyse-              -- -> IO [[DetectLanguageResponseStruct]] -- ^list of (language, confidence) tuples-              -> IO [[(String, MollomValue)]] -- ^list of (language, confidence) tuples-detectLanguage conn text = do-  service conn "mollom.detectLanguage" (MollomRequest [("text", text)]) +detectLanguage :: String -- ^text to analyse+              -> MollomMonad [[(String, MollomValue)]] -- ^list of (language, confidence) tuples+detectLanguage text = ErrorT . returnStateT . runErrorT $ service "mollom.detectLanguage" (MollomRequest [("text", text)])    -- | add text to your site's custom text blacklist.-addBlacklistText :: MollomConn -- ^connection to the Mollom service-                 -> String -- ^text to blacklist+addBlacklistText :: String -- ^text to blacklist                  -> String -- ^match used to search for the text, either "exact" or "contains"                  -> String -- ^reason: "spam", "profanity", "low-quality", or "unwanted"-                 -> IO Bool -- ^always returns True-addBlacklistText conn text match reason = do-  let ds = [("text", text), ("match", match), ("reason", reason)]-  service conn "mollom.addBlacklistText" (MollomRequest ds)+                 -> MollomMonad Bool -- ^always returns True+addBlacklistText text match reason = do+  let mRequest = MollomRequest [("text", text), ("match", match), ("reason", reason)]+  ErrorT . returnStateT . runErrorT $ service "mollom.addBlacklistText" mRequest   -- | remove text from your site's custom text blacklist.-removeBlacklistText :: MollomConn -- ^connection to the Mollom service-                 -> String -- ^text to blacklist-                 -> IO Bool -- ^always returns True-removeBlacklistText conn text = do-  let ds = [("text", text)]-  service conn "mollom.removeBlacklistText" (MollomRequest ds)+removeBlacklistText :: String -- ^text to blacklist+                    -> MollomMonad Bool -- ^always returns True+removeBlacklistText text = do+  let mRequest = MollomRequest [("text", text)]+  ErrorT . returnStateT . runErrorT $ service "mollom.removeBlacklistText" mRequest   -- | return the contents of your site's custom text blacklist.-listBlacklistText :: MollomConn -- ^connection to the Mollom service-                  -- -> IO [[(String, MollomValue)]] -- ^List of the current blacklisted URLs for the website corresponding to the public and private keypair-                  -> IO () -- ^List of the current blacklisted URLs for the website corresponding to the public and private keypair-listBlacklistText conn = do-  r <- service conn "mollom.listBlacklistText" (MollomRequest []) -  p <- handleError fail (parseResponse r)-  putStrLn $ show p+listBlacklistText :: MollomMonad [[(String, MollomValue)]] -- ^List of the current blacklisted URLs for the website corresponding to the public and private keypair+listBlacklistText = ErrorT . returnStateT . runErrorT $ service "mollom.listBlacklistText" (MollomRequest [])  + -- | add a URL to your site's custom URL blacklist.-addBlacklistURL :: MollomConn -- ^connection to the Mollom service-                -> String -- ^URL to be added to custom URL blacklist for the website identified by the public and private keypair-                -> IO Bool -- ^always returns True-addBlacklistURL conn url = do-  let ds = [("url", url)]-  service conn "mollom.addBlacklistURL" (MollomRequest ds)+addBlacklistURL :: String -- ^URL to be added to custom URL blacklist for the website identified by the public and private keypair+                -> MollomMonad Bool -- ^always returns True+addBlacklistURL url = do+  let mRequest = MollomRequest [("url", url)]+  ErrorT . returnStateT . runErrorT $ service "mollom.addBlacklistURL" mRequest   -- | remove a URL from your site's custom URL blacklist.-removeBlacklistURL :: MollomConn -- ^connection to the Mollom service-                   -> String -- ^URL to be removed from the custom URL blacklist for the website identified by the public and private keypair-                   -> IO Bool -- ^always returns True-removeBlacklistURL conn url = do-  let ds = [("url", url)]-  service conn "mollom.removeBlacklistURL" (MollomRequest ds)+removeBlacklistURL :: String -- ^URL to be removed from the custom URL blacklist for the website identified by the public and private keypair+                   -> MollomMonad Bool -- ^always returns True+removeBlacklistURL url = do+  let mRequest = MollomRequest [("url", url)]+  ErrorT . returnStateT . runErrorT $ service "mollom.removeBlacklistURL" mRequest   -- | return the contents of your site's custom URL blacklist.-listBlacklistURL :: MollomConn -- ^connection to the Mollom service-                 -> IO [[(String, MollomValue)]] -- ^List of the current blacklisted URLs for the website corresponding to the public and private keypair-listBlacklistURL conn = do-  service conn "mollom.listBlacklistURL" (MollomRequest [])+listBlacklistURL :: MollomMonad [[(String, MollomValue)]] -- ^List of the current blacklisted URLs for the website corresponding to the public and private keypair+listBlacklistURL = ErrorT . returnStateT . runErrorT $ service "mollom.listBlacklistURL" (MollomRequest [])  

@@ -3,6 +3,7 @@   ( authenticate   , getMollomTime   , getMollomNonce+  , getAuthenticationInformation   ) where  import Codec.Binary.Base64(encode)@@ -14,6 +15,8 @@ import System.IO.Unsafe (unsafePerformIO) import System.Locale (defaultTimeLocale) +import Network.Mollom.Internals+ authenticate :: String -- ^public key              -> String -- ^private key              -> String -- ^timestamp@@ -35,3 +38,10 @@ getMollomNonce = "FIXME_NONCE"  +getAuthenticationInformation :: String -> String -> [(String, String)]+getAuthenticationInformation publicKey privateKey = +  let timeStamp = getMollomTime mollomTimeFormat+      nonce = getMollomNonce+      hash = authenticate publicKey privateKey timeStamp nonce+  in [("public_key", publicKey), ("time", timeStamp), ("hash", hash), ("nonce", nonce)]+ 

@@ -0,0 +1,62 @@+-- |Internal data structures and functions to the Mollom service+module Network.Mollom.Internals +  ( mollomApiVersion+  , mollomTimeFormat+  , MollomConfiguration(..)+  , MollomError(..)+  , MollomValue(..)+  , MollomServerList(..)+  ) where++import Control.Monad.Error+import Network.XmlRpc.Client+import Network.XmlRpc.Internals ++mollomApiVersion :: String+mollomApiVersion = "1.0"++-- FIXME: This should be specified in some configuration file+-- or use the system locale+mollomTimeFormat = "%Y-%m-%dT%H:%M:%S.000+0200"++data MollomConfiguration = MollomConfiguration +  { mcPublicKey :: String+  , mcPrivateKey :: String+  , mcAPIVersion :: String+  } deriving (Eq, Ord, Show)++data MollomServerList = UninitialisedServerList | MollomServerList [String] deriving (Eq, Ord, Show)++data MollomError = MollomInternalError +                 | MollomRefresh+                 | MollomServerBusy +                 | MollomNoMoreServers+                 | HMollomError String deriving (Eq, Ord, Show)++instance Error MollomError where +  noMsg = HMollomError "Unknown Error"+  strMsg str = HMollomError str+++data MollomValue = MInt Int+                 | MBool Bool+                 | MDouble Double+                 | MString String deriving (Eq, Ord, Show)++instance XmlRpcType MollomValue where+  toValue (MInt i) = toValue i+  toValue (MBool b) = toValue b+  toValue (MDouble d) = toValue d+  toValue (MString s) = toValue s++  fromValue (ValueInt i) = maybeToM "" (Just (MInt i))+  fromValue (ValueBool b) = maybeToM "" (Just (MBool b)) +  fromValue (ValueDouble d) = maybeToM "" (Just (MDouble d))+  fromValue (ValueString s) = maybeToM "" (Just (MString s))+  +  getType (MInt _) = TInt+  getType (MBool _) = TBool+  getType (MDouble _) = TDouble+  getType (MString _) = TString++

@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |Module that implements the Mollom monad stack+-- We wrap the configuration and the serverlist+-- in a Reader and a State, respectively+module Network.Mollom.MollomMonad +  ( MollomMonad+--  , createMollomMonad+--  , runMollomMonad+  , MollomState+--  , runMollomState+  ) where+++import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad.Error+import Data.Monoid++import Network.Mollom.Internals++type SessionID = String+type Server = String++++type MollomState = ReaderT MollomConfiguration (StateT MollomServerList IO)+type MollomMonad = ErrorT MollomError (StateT (Maybe SessionID) MollomState)++++{-+newtype Eq a => MollomState a = MollomState {+    runMollomState :: ReaderT MollomConfiguration (StateT MollomServerList IO) a+  } deriving (Monad, MonadIO, MonadReader MollomConfiguration, MonadState MollomServerList)+  -}++{-+newtype Eq a => MollomMonad a = MollomMonad { +    runMollomMonad :: ErrorT String (StateT SessionID MollomState) a+  } deriving (Monad, MonadIO, MonadState SessionID)++-}++-- createMollomMonad :: MollomConfiguration -> MollomMonad ()+-- createMollomMonad configuration = MollomMonad $ ++