diff --git a/hMollom.cabal b/hMollom.cabal --- a/hMollom.cabal +++ b/hMollom.cabal @@ -1,9 +1,9 @@ name: hMollom -version: 0.2.2 +version: 0.3.1 cabal-version: >= 1.6 stability: experimental -synopsis: Library to interact with the Mollom anti-spam service -description: Library to interact with the Mollom anti-spam service +synopsis: Library to interact with the @Mollom anti-spam service +description: Library to interact with the @Mollom anti-spam service license: BSD3 license-file: LICENSE author: Andy Georges @@ -11,22 +11,44 @@ category: Network maintainer: itkovian@gmail.com build-Type: Simple -extra-source-files: src/Network/Mollom/Auth.hs +extra-source-files: src/Network/Mollom/OAuth.hs + src/Network/Mollom/Blacklist.hs + src/Network/Mollom/Captcha.hs + src/Network/Mollom/Content.hs + src/Network/Mollom/Feedback.hs + src/Network/Mollom/Helper.hs src/Network/Mollom/Internals.hs src/Network/Mollom/MollomMonad.hs - + src/Network/Mollom/Types.hs + src/Network/Mollom/Whitelist.hs library build-depends: + aeson >= 0.5.0.0, + attoparsec >= 0.10, base >= 3 && < 5, - haxr >= 3000.5, + ghc-prim, old-locale >= 1, time >= 1.1.4, Crypto >= 4.2.0, bytestring >= 0.9.1.4, dataenc >= 0.13, - mtl >= 1.1.0.2 - exposed-modules: Network.Mollom + mtl >= 1.1.0.2, + HTTP >= 4000.2.2, + pureMD5 >= 2.1.0.2, + old-time, + random + exposed-modules: + Network.Mollom + , Network.Mollom.Blacklist + , Network.Mollom.Captcha + , Network.Mollom.Content + , Network.Mollom.Feedback + , Network.Mollom.MollomMonad + , Network.Mollom.Site + , Network.Mollom.Types + , Network.Mollom.Whitelist + ghc-options: -Wall hs-source-dirs: src diff --git a/src/Network/Mollom.hs b/src/Network/Mollom.hs --- a/src/Network/Mollom.hs +++ b/src/Network/Mollom.hs @@ -1,288 +1,14 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} --- |Interface to the Mollom API +-- | Interface to the Mollom web service (http://mollom.com), +-- based on the beta REST API, see http://mollom.com/api/rest. module Network.Mollom - ( getServerList - , checkContent - , sendFeedback - , getImageCaptcha - , getAudioCaptcha - , checkCaptcha - , getStatistics - , verifyKey - , detectLanguage - , addBlacklistText - , removeBlacklistText - , listBlacklistText - , addBlacklistURL - , removeBlacklistURL - , listBlacklistURL - , MollomConfiguration(..) - , MollomValue(..) + ( M.runMollom ) 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 qualified Network.Mollom.MollomMonad as M -import Network.Mollom.Internals -import Network.Mollom.Auth -import Network.Mollom.MollomMonad -mollomFallbackServer :: String -mollomFallbackServer = "http://xmlrpc2.mollom.com/" - - --- |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)] - --- | 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 - - --- | 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 - - --- | The 'service' function implements the basic load balancing scheme from --- . --- --- 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 - -> 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' - --- | 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 - -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 - -catSecondMaybes :: [(k, Maybe v)] -> [(k, v)] -catSecondMaybes = map (second fromJust) . filter (isJust . snd) - - --- | asks Mollom whether the specified message is legitimate. -checkContent :: Maybe String -- ^Current session ID - -> Maybe String -- ^Title of submitted post - -> Maybe String -- ^Body of submitted post - -> Maybe String -- ^Submitting user's name or nick - -> Maybe String -- ^Submitting user's URL - -> Maybe String -- ^Submitting user's email address - -> Maybe String -- ^Submitting user's openID - -> Maybe String -- ^Submitting user's current IP - -> Maybe String -- ^Submitting user's unique site ID - -> MollomMonad [(String, MollomValue)] -- ^The monad in which the function is executing -checkContent sessionID title body authorName authorURL authorEmail authorOpenID authorIP authorSiteID = - let kvs = catSecondMaybes [("session_id", sessionID) - ,("post_title", title) - ,("post_body", body) - ,("author_name", authorName) - ,("author_url", authorURL) - ,("author_mail", authorEmail) - ,("author_openid", authorOpenID) - ,("author_ip", authorIP) - ,("author_id", authorSiteID)] - in checkContent' kvs - -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 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 :: 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 :: 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 :: String -- ^solution to the CAPTCHA - -> Maybe String -- ^author IP address - -> MollomMonad Bool -checkCaptcha solution authorIP = do - sessionID <- get - case sessionID of - Nothing -> throwError (HMollomError "Mollom Error: no session ID provided") - Just s -> do let mRequest = MollomRequest $ catSecondMaybes [("session_id", Just s), ("solution", Just solution), ("author_ip", authorIP)] - ErrorT . returnStateT . runErrorT $ service "mollom.checkCaptcha" mRequest - --- | retrieves usage statistics from Mollom. -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. - -- yesterday_accepted — Number of posts accepted yesterday. - -- yesterday_rejected — Number of spam posts blocked yesterday. - -- today_accepted — Number of posts accepted today. - -- today_rejected — Number of spam posts rejected today. - -> 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 :: MollomMonad Bool -- ^Always returns True -verifyKey = ErrorT . returnStateT . runErrorT $ service "mollom.verifyKey" (MollomRequest []) - - --- | analyze text and return its most likely language code. -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 :: String -- ^text to blacklist - -> String -- ^match used to search for the text, either "exact" or "contains" - -> String -- ^reason: "spam", "profanity", "low-quality", or "unwanted" - -> 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 :: 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 :: 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 :: 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 :: 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 :: 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 []) diff --git a/src/Network/Mollom/Auth.hs b/src/Network/Mollom/Auth.hs deleted file mode 100644 --- a/src/Network/Mollom/Auth.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Takes care of the authentication on behalf of a Mollom client. -module Network.Mollom.Auth - ( authenticate - , getMollomTime - , getMollomNonce - , getAuthenticationInformation - ) where - -import Codec.Binary.Base64(encode) -import Data.ByteString.Internal(c2w) -import Data.HMAC (hmac_sha1) -import Data.List (intersperse) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Format (formatTime) -import System.IO.Unsafe (unsafePerformIO) -import System.Locale (defaultTimeLocale) - -import Network.Mollom.Internals - -authenticate :: String -- ^public key - -> String -- ^private key - -> String -- ^timestamp - -> String -- ^nonce - -> String -- ^ resulting hash value, base64 encoded -authenticate publicKey privateKey timestamp nonce = - let hash = hmac_sha1 (map c2w privateKey) $ map c2w . concat . (intersperse ":") $ [timestamp, nonce, privateKey] - in encode hash - - -getMollomTime :: String -- ^time format - -> String -- ^current time in the specified format -getMollomTime format = - let time = unsafePerformIO $ getCurrentTime - in formatTime defaultTimeLocale format time - - -getMollomNonce :: String -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)] - diff --git a/src/Network/Mollom/Blacklist.hs b/src/Network/Mollom/Blacklist.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Blacklist.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- + - (C) 2012, Andy Georges + - + - This module provides the interface to the Mollom blacklisting API. + -} + +module Network.Mollom.Blacklist + ( Reason(..) + , Context(..) + , Match(..) + , BlacklistResponse(..) + , createBlacklist + , updateBlacklist + , deleteBlacklist + , listBlacklist + , readBlacklistEntry + ) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader +import qualified Data.Aeson as A +import Data.List(intercalate) +import Data.Maybe(catMaybes) +import Network.HTTP.Base (RequestMethod(..)) + +import Network.Mollom.Helper +import Network.Mollom.MollomMonad +import Network.Mollom.Types + +-- | Data type representing the reasons the user can provide to +-- the Mollom service for blacklisting a string or a value. +data Reason = Spam + | Profanity + | Quality + | Unwanted + deriving (Eq) + +instance Show Reason where + show Spam = "spam" + show Profanity = " profanity" + show Quality = "quality" + show Unwanted = "unwanted" + +instance A.FromJSON Reason where + parseJSON (A.String s) = return $ case s of + "spam" -> Spam + "profanity" -> Profanity + "quality" -> Quality + "unwanted" -> Unwanted + parseJSON _ = mzero + +-- | Data type representing the context in which the Mollom +-- service is allowed to look for a blacklisted term (to be +-- provided at the creation of said term). +data Context = AllFields + | AuthorName + | AuthorMail + | AuthorIp + | AuthorId + | Links + | PostTitle + deriving (Eq) + +instance Show Context where + show AllFields = "allFields" + show AuthorName = "authorName" + show AuthorMail = "authorMail" + show AuthorIp = "authorIp" + show AuthorId = "authorId" + show Links = "links" + show PostTitle = "postTitle" + +instance A.FromJSON Context where + parseJSON (A.String s) = return $ case s of + "allFields" -> AllFields + "authorName" -> AuthorName + "authorMail" -> AuthorMail + "authorIp" -> AuthorIp + "authorId" -> AuthorId + "links" -> Links + "postTitle" -> PostTitle + parseJSON _ = mzero + + +-- | Data type indicating how well a specific match should be. +data Match = Exact + | Contains + deriving Eq + +instance Show Match where + show Exact = "exact" + show Contains = "contains" + +instance A.FromJSON Match where + parseJSON (A.String s) = return $ case s of + "exact" -> Exact + "contains" -> Contains + parseJSON _ = mzero + + +-- | Data type representing the response in the blacklist API. +data BlacklistResponse = + BlacklistResponse { blacklistId :: String + , blacklistCreated :: String -- FIXME should be datetime + , blacklistStatus :: Bool + , blacklistLastMatch :: String -- FIXME should be datetime + , blacklistMatchCount :: Int + , blacklistValue :: String + , blacklistReason :: Reason + , blacklistContext :: Context + , blacklistMatch :: Match + , blacklistNote :: String + } + +instance A.FromJSON BlacklistResponse where + parseJSON j = do + o <- A.parseJSON j + e <- o A..: "entry" + BlacklistResponse <$> + e A..: "id" <*> + e A..: "created" <*> + e A..: "status" <*> + e A..: "lastMatch" <*> + e A..: "matchCount" <*> + e A..: "value" <*> + e A..: "reason" <*> + e A..: "context" <*> + e A..: "match" <*> + e A..: "note" + + +instance A.FromJSON [BlacklistResponse] where + parseJSON j = do + o <- A.parseJSON j + ls <- o A..: "list" + mapM A.parseJSON ls + + +-- | Create a blacklist entry for the given site. +createBlacklist :: String -- ^ The value or string to blacklist + -> Maybe Reason -- ^ The reason for this blacklisting + -> Maybe Context -- ^ Where may the entry match + -> Maybe Match -- ^ How precise should the match be + -> Maybe Bool -- ^ Is the entry live or not + -> Maybe String -- ^ Note + -> Mollom (MollomResponse BlacklistResponse) +createBlacklist s reason context match status note = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "blacklist/" ++ pubKey + kvs = [ ("value", Just s) + , ("reason", fmap show reason) + , ("context", fmap show context) + , ("match", fmap show match) + , ("status", fmap boolToOneZeroString status) + , ("note", note) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + + +-- | Update an existing blacklist entry. All arguments that are provided as Nothing +-- default to keeping existing values. +updateBlacklist :: String -- ^ ID of the blacklisted entry to update + -> Maybe String -- ^ The blacklisted string or value. + -> Maybe Reason -- ^ The reason for this blacklisting + -> Maybe Context -- ^ Where may the entry match + -> Maybe Match -- ^ How precise should the match be + -> Maybe Bool -- ^ Is the entry live or not + -> Maybe String -- ^ Note + -> Mollom (MollomResponse ()) +updateBlacklist entryId s reason context match status note = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "blacklist/" ++ pubKey ++ "/" ++ entryId + kvs = [ ("value", s) + , ("reason", fmap show reason) + , ("context", fmap show context) + , ("match", fmap show match) + , ("status", fmap boolToOneZeroString status) + , ("note", note) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + +-- | Delete a blacklisted entry. +deleteBlacklist :: String -- ^ ID of the blacklisted entry to delete + -> Mollom (MollomResponse ()) +deleteBlacklist entryId = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "blacklist/" ++ pubKey ++ "/" ++ entryId ++ "/delete" + errors = generalErrors + mollomService pubKey privKey POST path [] [] errors + + +-- | List the entries in the blacklist for a given set of credentials, +-- identified by the site public key. +-- FIXME: the arguments determination is fugly. +listBlacklist :: Maybe Int -- ^ The offset from which to start listing entries. Defaults to 0 when Nothing is given as the argument. + -> Maybe Int -- ^ The number of entries that should be returned. Defaults to all. + -> Mollom (MollomResponse [BlacklistResponse]) +listBlacklist offset count = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + arguments = case offset `mplus` count of + Nothing -> "" + _ -> "/q?" ++ (intercalate "&" $ catMaybes [ fmap (\o -> "offset=" ++ show o) offset + , fmap (\c -> "count=" ++ show c) count + ]) + path = "blacklist/" ++ pubKey ++ arguments + errors = generalErrors + mollomService pubKey privKey GET path [] [] errors + + +-- | Read the information that is stored for a given blacklist entry. +readBlacklistEntry :: String -- ^ ID of the blacklisted entry to read + -> Mollom (MollomResponse BlacklistResponse) +readBlacklistEntry entryId = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "blacklist/" ++ pubKey ++ "/" ++ entryId + errors = generalErrors + mollomService pubKey privKey GET path [] [] errors + + diff --git a/src/Network/Mollom/Captcha.hs b/src/Network/Mollom/Captcha.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Captcha.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- + - (C) 2012, Andy Georges + - + - This modules provides the interface to the Mollom CAPTCHA API. + - + -} + +module Network.Mollom.Captcha + ( Type(..) + , CaptchaResponse(..) + , createCaptcha + , verifyCaptcha + ) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader +import qualified Data.Aeson as A +import Data.List (intercalate) +import Network.HTTP.Base (RequestMethod(..)) + +import Network.Mollom.Helper +import Network.Mollom.MollomMonad +import Network.Mollom.Types + + +-- | Data type representing the CAPTCHA types Mollom can serve. +data Type = Image + | Audio + deriving (Eq) + +instance Show Type where + show Image = "image" + show Audio = "audio" + +instance A.FromJSON Type where + parseJSON (A.String s) = return $ case s of + "image" -> Image + "audio" -> Audio + parseJSON _ = mzero + + +-- | Data type representing the response to a captcha API call +data CaptchaResponse = + CaptchaResponse { captchaId :: String + , captchaUrl :: String + , captchaSolved :: Bool + , captchaReason :: String + , captchaAuthorName :: String + , captchaAuthorUrl :: String + , captchaAuthorMail :: String + , captchaAuthorIP :: String + , captchaAuthorId :: String + , captchaAuthorOpenId :: String + } + + +instance A.FromJSON CaptchaResponse where + parseJSON j = do + o <- A.parseJSON j + s <- o A..: "captcha" + CaptchaResponse <$> + s A..: "captchaId" <*> + s A..: "url" <*> + s A..: "solved" <*> + s A..: "reason" <*> + s A..: "authorName" <*> + s A..: "authorUrl" <*> + s A..: "authorMail" <*> + s A..: "authorIp" <*> + s A..: "authorId" <*> + s A..: "authorOpenId" + + +createCaptcha :: Type -- ^ The type of captcha that should be created. + -> Maybe Bool -- ^ Use SSL if True (only for paid subscriptions). + -> Maybe String -- ^ Optional content ID to refer to. + -> Mollom (MollomResponse CaptchaResponse) +createCaptcha t ssl captchId = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "captcha" + kvs = [ ("type", Just $ show t) + , ("ssl", fmap boolToOneZeroString ssl) + , ("contentId", captchId) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + + + +verifyCaptcha :: String -- ^The captcha ID to be verified. + -> Maybe String -- ^The name of the content author filling out the captcha. + -> Maybe String -- ^The website URL of the content author . + -> Maybe String -- ^The email address of the content author. + -> Maybe [String] -- ^The openIDs (if any) of the content author. + -> Maybe String -- ^The IP-address of the content author. + -> Maybe String -- ^Content author's unique local site user ID. + -> Maybe Int -- ^The time that must have passed before the same author can post again. Defaults to 15. + -> Maybe String -- ^Client-side honeypot value, if any. + -> Mollom (MollomResponse CaptchaResponse) +verifyCaptcha captchId authorName authorURL authorEmail authorOpenIds authorIP authorSiteID rateLimit honeypot = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "captcha/" ++ captchId + kvs = [ ("authorName", authorName) + , ("authorUrl", authorURL) + , ("authorMail", authorEmail) + , ("authorOpenid", fmap (intercalate " ") authorOpenIds) + , ("authorIp", authorIP) + , ("authorId", authorSiteID) + , ("rateLimit", fmap show rateLimit) + , ("honeypot", honeypot) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + diff --git a/src/Network/Mollom/Content.hs b/src/Network/Mollom/Content.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Content.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{- + - (C) 2012, Andy Georges + - + - This modules provides the interface to the Mollom content API. + - + -} + +module Network.Mollom.Content + ( Check(..) + , ContentLanguage(..) + , ContentResponse(..) + , SpamClassification(..) + , Strictness(..) + , checkContent + ) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State +import qualified Data.Aeson as A +import Data.List (intercalate) +import Network.HTTP.Base (RequestMethod(..)) + +import Network.Mollom.Helper +import Network.Mollom.MollomMonad +import Network.Mollom.Types + +-- | Possible checks Mollom can perform on the provided content. +data Check = Spam | Quality | Profanity | Language | Sentiment | None deriving (Eq) + +instance Show Check where + show Spam = "spam" + show Quality = "quality" + show Profanity = "profanity" + show Language = "language" + show Sentiment = "sentiment" + show None = "none" + +-- | Strictness of the Mollom service analysis +data Strictness = Strict | Normal | Relaxed deriving (Eq) + +instance Show Strictness where + show Strict = "strict" + show Normal = "normal" + show Relaxed = "relaxed" + + +-- | Data type representing the language that was detected by +-- the Mollom service. +data ContentLanguage = + ContentLanguage { languageCode :: String + , languageScore :: Double + } + +instance A.FromJSON ContentLanguage where + parseJSON (A.Object o) = ContentLanguage <$> + o A..: "languageCode" <*> + o A..: "languageScore" + +-- | Data type representing the classification of the content +-- by the Mollom service. +data SpamClassification = SpamClass | HamClass | UnsureClass deriving (Eq, Show) + +instance A.FromJSON SpamClassification where + parseJSON (A.String s) = return $ case s of + "spam" -> SpamClass + "ham" -> HamClass + "unsure" -> UnsureClass + parseJSON _ = mzero + +-- | Data type representing a response in the content API. +data ContentResponse = + ContentResponse { contentId :: String + , contentSpamScore :: Maybe Double + , contentSpamClassification :: Maybe SpamClassification + , contentProfanityScore :: Maybe Double + , contentQualityScore :: Maybe Double + , contentSentimentScore :: Maybe Double + , contentReason :: Maybe String + , contentLanguages :: [ContentLanguage] + , contentPostTitle :: String + , contentPostBody :: String + , contentAuthorName :: String + , contentAuthorUrl :: String + , contentAuthorMail :: String + , contentAuthorIP :: String + , contentAuthorId :: String + , contentAuthorOpenId :: [String] + } + + +instance A.FromJSON ContentResponse where + parseJSON j = do + o <- A.parseJSON j + s <- o A..: "content" + ContentResponse <$> + s A..: "contentId" <*> + s A..:? "spamScore" <*> + s A..:? "spamClassification" <*> + s A..:? "profanityScore" <*> + s A..:? "qualityScore" <*> + s A..:? "sentimentScore" <*> + s A..:? "reason" <*> + s A..: "languages" <*> + s A..: "postTitle" <*> + s A..: "postBody" <*> + s A..: "authorName" <*> + s A..: "authorUrl" <*> + s A..: "authorMail" <*> + s A..: "authorIp" <*> + s A..: "authorId" <*> + s A..: "authorOpenId" + parseJSON _ = mzero + +-- | Asks Mollom whether the specified message is legitimate. +-- FIXME: contentID should be taken from the Mollom state +checkContent :: Maybe String -- ^Title of submitted post. + -> Maybe String -- ^Body of submitted post. + -> Maybe String -- ^Content author's name. + -> Maybe String -- ^Content author's URL or website. + -> Maybe String -- ^Content author's email address. + -> Maybe String -- ^Content author's openID. + -> Maybe String -- ^Content author's current IP. + -> Maybe String -- ^Content author's unique local site user ID. + -> Maybe [Check] -- ^The check(s) to perform. If Nothing or Just None, + -- this will default to Spam when the existing content ID is Nothing. + -> Maybe Bool -- ^Do we want to allow unsure results, leading to a CAPTCHA or not. + -> Maybe Strictness -- ^How strict should Mollom be when checking this content? + -> Maybe Int -- ^Rate limit imposing a bound on the time between submitted posts from the same author. + -> Maybe String -- ^Value of the honeypot form-element, if any. + -> Maybe Bool -- ^Was the content stored on the client-side? + -- Should be False during validation of a form, + -- True after a succesfull submission. + -> Maybe String -- ^Absolute URL for the stored content. + -> Maybe String -- ^Absolute URL to the content's parent context, e.g., + -- the article of forum thread a comment is placed on. + -> Maybe String -- ^Title of said parental context. + -> Mollom (MollomResponse ContentResponse) -- ^The monad in which the function is executing. +checkContent title body authorName authorURL authorEmail authorOpenID authorIP authorSiteID checks unsure strictness rateLimit honeypot stored storedURL storedParentURL parentTitle = do + config <- ask + contentID <- get + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + kvs = [ ("postTitle", title) + , ("postBody", body) + , ("authorName", authorName) + , ("authorUrl", authorURL) + , ("authorMail", authorEmail) + , ("authorOpenid", authorOpenID) + , ("authorIp", authorIP) + , ("authorId", authorSiteID) + , ("checks", fmap (intercalate "|" . map show) checks) + , ("unsure", fmap boolToOneZeroString unsure) + , ("strictness", fmap show strictness) + , ("rateLimit", fmap show rateLimit) + , ("honeypot", honeypot) + , ("stored", fmap boolToOneZeroString stored) + , ("url", storedURL) + , ("contextUrl", storedParentURL) + , ("contextTitle", parentTitle) + ] + path = case contentID of + Just cid -> "content/" ++ cid + Nothing -> "content" + errors = generalErrors + ms <- mollomService pubKey privKey POST path kvs [] errors + let contentID' = contentId . response $ ms + put $ Just contentID' + return ms + + + + + diff --git a/src/Network/Mollom/Feedback.hs b/src/Network/Mollom/Feedback.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Feedback.hs @@ -0,0 +1,58 @@ +{- + - (C) 2012, Andy Georges + - + - This modules provides the interface to the Mollom feedback API. + - + -} + +module Network.Mollom.Feedback + ( Reason(..) + , sendFeedback + ) where + +import Control.Monad.Error +import Control.Monad.Reader +import Network.HTTP.Base (RequestMethod(..)) + +import Network.Mollom.MollomMonad +import Network.Mollom.Types + + +-- | Data type representing the reasons the user can provide to +-- the Mollom service for blacklisting a string or a value. +data Reason = Approve + | Spam + | Profanity + | Quality + | Unwanted + | Delete + deriving (Eq) + +instance Show Reason where + show Approve = "approve" + show Spam = "spam" + show Profanity = "profanity" + show Quality = "quality" + show Unwanted = "unwanted" + show Delete = "delete" + + +sendFeedback :: Maybe String -- ^Existing content ID + -> Maybe String -- ^Existing captcha ID + -> Reason -- ^Reason of the feedback + -> Mollom (MollomResponse ()) +sendFeedback contentId captchaId reason = do + case contentId `mplus` captchaId of + Nothing -> undefined + Just _ -> do config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "feedback" + kvs = [ ("contentId", contentId) + , ("captchaId", captchaId) + , ("reason", Just $ show reason) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + + diff --git a/src/Network/Mollom/Helper.hs b/src/Network/Mollom/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Helper.hs @@ -0,0 +1,15 @@ +{- + - (C) 2012, Andy Georges + - + - This modules exports some helper functions. + - + -} + +module Network.Mollom.Helper + ( boolToOneZeroString + ) where + + +boolToOneZeroString :: Bool -> String +boolToOneZeroString True = "1" +boolToOneZeroString False = "0" diff --git a/src/Network/Mollom/Internals.hs b/src/Network/Mollom/Internals.hs --- a/src/Network/Mollom/Internals.hs +++ b/src/Network/Mollom/Internals.hs @@ -1,62 +1,99 @@ --- |Internal data structures and functions to the Mollom service +{-# LANGUAGE OverloadedStrings #-} +{- + - (C) 2012, Andy Georges + - + - This module provides internal functions to allow using the Mollom service + -} + module Network.Mollom.Internals ( mollomApiVersion - , mollomTimeFormat , MollomConfiguration(..) , MollomError(..) - , MollomValue(..) - , MollomServerList(..) + , MollomResponse(..) + , service ) where -import Control.Monad.Error -import Network.XmlRpc.Client -import Network.XmlRpc.Internals +import Control.Arrow (second) +import Control.Monad.Error +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.List (intercalate, lookup, sort) +import Data.Maybe(fromJust, isJust) +import Network.HTTP (getRequest, postRequestWithBody, simpleHTTP) +import Network.HTTP.Base (HTTPResponse, RequestMethod(..), Response(..), ResponseCode, urlEncode) +import Network.HTTP.Headers (HeaderName (HdrContentType, HdrAccept), replaceHeader) +import Network.HTTP.Stream (ConnError(..), Result) -mollomApiVersion :: String -mollomApiVersion = "1.0" +import Network.Mollom.OAuth +import Network.Mollom.Types --- FIXME: This should be specified in some configuration file --- or use the system locale -mollomTimeFormat = "%Y-%m-%dT%H:%M:%S.000+0200" +mollomServer :: String +mollomServer = "http://dev.mollom.com/v1" -data MollomConfiguration = MollomConfiguration - { mcPublicKey :: String - , mcPrivateKey :: String - , mcAPIVersion :: String - } deriving (Eq, Ord, Show) +catSecondMaybes :: [(k, Maybe v)] -> [(k, v)] +catSecondMaybes = map (second fromJust) . filter (isJust . snd) -data MollomServerList = UninitialisedServerList | MollomServerList [String] deriving (Eq, Ord, Show) -data MollomError = MollomInternalError - | MollomRefresh - | MollomServerBusy - | MollomNoMoreServers - | HMollomError String deriving (Eq, Ord, Show) +-- | Encode the parameters after sorting them. +buildEncodedQuery :: [(String, String)] -- ^ The name-value pairs for the query + -> String +buildEncodedQuery ps = + let sps = sort ps + in intercalate "&" $ map (\(n, v) -> intercalate "=" [urlEncode n, urlEncode v]) sps -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) +-- | Process the response from the Mollom server, checking the return code. +-- If there is a connection error, we immediately return the appropriate +-- error. Otherwise, in case of an error, we check the code and return +-- the appropriate instance. +processResponse :: A.FromJSON a => [(ResponseCode, MollomError)] -> Result (HTTPResponse String) -> Either MollomError (MollomResponse a) +processResponse errors result = + case result of + Left ce -> Left (ConnectionError ce) + Right r -> let code = rspCode r + message = rspReason r + in case lookup code errors of + Just e -> Left (addMessage e message) + Nothing -> let response = A.decode' . BS.pack $ rspBody r + in case response of + Nothing -> Left JSONParseError + Just r' -> Right MollomResponse { code = code + , message = message + , response = r' + } -instance XmlRpcType MollomValue where - toValue (MInt i) = toValue i - toValue (MBool b) = toValue b - toValue (MDouble d) = toValue d - toValue (MString s) = toValue s +-- | The service function is the common entrypoint to use the Mollom service. This +-- is where we actually send the data to Mollom. +-- FIXME: implement the maximal number of retries +service :: A.FromJSON a + => String -- ^Public key + -> String -- ^Private key + -> RequestMethod -- ^The HTTP method used in this request. + -> String -- ^The path to the requested resource + -> [(String, Maybe String)] -- ^Request parameters + -> [String] -- ^Expected returned values + -> [((Int, Int, Int), MollomError)] -- ^Possible error values + -> ErrorT MollomError IO (MollomResponse a)-- :: ErrorT (IO (Either MollomError (HTTPResponse String))) +service publicKey privateKey method path params expected errors = do + let params' = catSecondMaybes params + oauthHVs = oauthHeaderValues publicKey OAuthHmacSha1 + oauthSig = oauthSignature OAuthHmacSha1 privateKey method mollomServer path + (buildEncodedQuery $ params' ++ oauthHVs) + oauthH = oauthHeader (("oauth_signature", oauthSig) : oauthHVs) + contentH = replaceHeader HdrContentType "application/x-www-form-urlencoded" + acceptH = replaceHeader HdrAccept "application/json;q=0.8" + liftIO $ putStrLn $ "URI = " ++ (mollomServer ++ "/" ++ path) + result <- liftIO $ liftM (processResponse errors) $ simpleHTTP (oauthH . contentH . acceptH + $ case method of + POST -> let body = buildEncodedQuery params' + in postRequestWithBody (mollomServer ++ "/" ++ path) + "application/x-www-form-urlencoded" + body + GET -> getRequest (mollomServer ++ "/" ++ path) + _ -> undefined + ) + ErrorT { runErrorT = return result } - 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 diff --git a/src/Network/Mollom/MollomMonad.hs b/src/Network/Mollom/MollomMonad.hs --- a/src/Network/Mollom/MollomMonad.hs +++ b/src/Network/Mollom/MollomMonad.hs @@ -1,48 +1,59 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- |Module that implements the Mollom monad stack --- We wrap the configuration and the serverlist --- in a Reader and a State, respectively +-- We wrap the configuration in a Reader module Network.Mollom.MollomMonad - ( MollomMonad --- , createMollomMonad --- , runMollomMonad + ( Mollom , MollomState --- , runMollomState + , mollomService + , runMollom ) where - -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State -import Control.Monad.Error -import Data.Monoid +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Error +import qualified Data.Aeson as A +import Network.HTTP.Base (RequestMethod(..)) 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) +import Network.Mollom.Types +type ContentID = String +type MollomState = Maybe ContentID +-- | The MollomMonad type is a monad stack that can retain the content ID in its +-- state (Content, Captcha and Feedback APIs). We also need to have a configuration +-- that's towed along with the public and private keys. +newtype Mollom a = M { runM :: ErrorT MollomError + (StateT MollomState + (ReaderT MollomConfiguration IO)) a + } deriving (Monad, MonadIO, MonadReader MollomConfiguration, MonadState (Maybe ContentID), MonadError MollomError) -{- -newtype Eq a => MollomState a = MollomState { - runMollomState :: ReaderT MollomConfiguration (StateT MollomServerList IO) a - } deriving (Monad, MonadIO, MonadReader MollomConfiguration, MonadState MollomServerList) - -} +wrapMollom :: ErrorT MollomError IO a -> Mollom a +wrapMollom = M . ErrorT . liftIO . runErrorT -{- -newtype Eq a => MollomMonad a = MollomMonad { - runMollomMonad :: ErrorT String (StateT SessionID MollomState) a - } deriving (Monad, MonadIO, MonadState SessionID) +pJSON :: A.FromJSON b => MollomResponse A.Value -> Mollom (MollomResponse b) +pJSON mr = + case A.fromJSON (response mr) of + A.Success r' -> return $ mr { response = r' } + _ -> throwError JSONParseError --} +mollomService :: A.FromJSON a + => String -- ^ Public key + -> String -- ^ Private key + -> RequestMethod -- ^ The HTTP method used in this request. + -> String -- ^ The path to the requested resource + -> [(String, Maybe String)] -- ^ Request parameters + -> [String] -- ^ Expected returned values + -> [((Int, Int, Int), MollomError)] -- ^Possible error values + -> Mollom (MollomResponse a) +mollomService pubKey privKey method path params expected errors = + (wrapMollom $ service pubKey privKey method path params expected errors) >>= pJSON --- createMollomMonad :: MollomConfiguration -> MollomMonad () --- createMollomMonad configuration = MollomMonad $ +runMollom :: Mollom a -> MollomConfiguration -> MollomState -> IO (Either MollomError (Maybe ContentID, a)) +runMollom m config s = do + v <- runReaderT (runStateT (runErrorT $ runM m) s) config + return $ case v of + (Left err, _) -> Left err + (Right r, cid) -> Right (cid, r) diff --git a/src/Network/Mollom/OAuth.hs b/src/Network/Mollom/OAuth.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/OAuth.hs @@ -0,0 +1,115 @@ +{- + - (C) 2012, Andy Georges + - + - This modules takes care of preparing the OAuth 1.0 information that is to be sent + - along with each request to the Mollom service. + - + - For documentation about OAuth, see RFC 5849 (http://tools.ietf.org/html/rfc5849). + -} + + module Network.Mollom.OAuth + ( OAuthSignatureMethod (..) + , getMollomNonce + , getMollomTime + , oauthHeader + , oauthHeaderValues + , oauthSignature + ) where + +import Codec.Binary.Base64 (encode) +import Data.ByteString.Internal (c2w, w2c) +import Data.ByteString.Lazy.Char8 (pack) +import Data.Digest.Pure.MD5 (md5) +import Data.HMAC (hmac_sha1) +import Data.List (intercalate) +import Network.HTTP (RequestMethod, urlEncode) +import Network.HTTP.Headers (HasHeaders, HeaderName(HdrAuthorization), HeaderSetter, replaceHeader) +import System.IO.Unsafe (unsafePerformIO) +import System.Locale (defaultTimeLocale) +import System.Random +import System.Time + +import Network.Mollom.Types + +data OAuthSignatureMethod = OAuthHmacSha1 + | OAuthRsaSha1 + | OAuthPlainText + deriving (Eq) + +instance Show OAuthSignatureMethod where + show OAuthHmacSha1 = "HMAC-SHA1" + show OAuthRsaSha1 = "RSA-SHA1" + show OAuthPlainText = "PLAINTEXT" + +oauthVersion = "1.0" + +-- | Obtain a nonce for use in the request +getMollomNonce :: String -- ^ unique string across requests +getMollomNonce = show . md5 . pack . show $ (+) (getMollomTime) $ (unsafePerformIO $ getStdRandom (randomR (1,100000)) :: Integer) + +-- | Obtain the system time +getMollomTime :: Integer -- ^current time in the specified format +getMollomTime = let TOD s p = unsafePerformIO $ getClockTime + in s + + +-- | Compute the hashed and base64 encoded value for a (key, string) pair. +hash :: String -- ^ key + -> String -- ^ data to hash + -> String -- ^ resulting hashed value +hash key s = encode $ hmac_sha1 (map c2w key) (map c2w s) + + +-- | The headers for the OAuth protocol in the HTTP +-- Authorization field. See 3.5.1 +oauthHeaderValues :: String -- ^ Public key + -> OAuthSignatureMethod -- ^ Signature method + -> [(String, String)] -- ^ Name-value pairs (we need to be able to sort these later) +oauthHeaderValues key sig = + [ ("oauth_consumer_key", key) +-- , ("oauth_token", "") + , ("oauth_signature_method", show sig) + , ("oauth_timestamp", show $ getMollomTime) + , ("oauth_nonce", getMollomNonce) + , ("oauth_version", "1.0") + ] + +-- | Format the OAuth header, so it can be added to the +-- HTTP request header. +oauthHeader :: HasHeaders a -- ^ We must be applied to something that has headers + => [(String, String)] -- ^ Name-value pairs that need to be set in the header + -> (a -> a) -- ^ Continuation for changing the headers +oauthHeader pairs = + replaceHeader HdrAuthorization $ "OAuth " ++ oas + where oas = intercalate "," + $ map (\(n, v) -> intercalate "=" [ urlEncode n, "\"" ++ urlEncode v ++ "\"" ]) pairs + + +-- | Determine the signature for the OAuth headers in the +-- HTTP request sent to the Mollom server. See Section +-- 3.4 of RFC 5849. +oauthSignature :: OAuthSignatureMethod -- ^ Signing type + -> String -- ^ Private key + -> RequestMethod -- ^ HTTP method + -> String -- ^ server URI + -> String -- ^ request path + -> String -- ^ request parameters + -> String +oauthSignature sig privateKey method server path request = + -- The base string consists of the HTTP method (POST, GET, ...) + -- concatenated via &-symbols with the URI of the request and + -- the encoded request parameters. See 3.4.1. + let baseString = intercalate "&" + $ [ show method + , urlEncode (server ++ "/" ++ path) + , urlEncode request + ] + in case sig of + -- The signature must use the token secret, even if it is empty. + -- See 3.4.2. + OAuthHmacSha1 -> let key = intercalate "&" + $ [ urlEncode privateKey + , urlEncode "" + ] + in hash key baseString + diff --git a/src/Network/Mollom/Site.hs b/src/Network/Mollom/Site.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Site.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- + - (C) 2012, Andy Georges + - + - This module provides the interface to the Mollom site API. + -} + +module Network.Mollom.Site + ( SiteResponse(..) + , readSite + , deleteSite + , listSites + ) where + +import Control.Applicative ((<*>), (<$>)) +import Control.Monad.Error +import Control.Monad.Reader +import qualified Data.Aeson as A +import Data.List(intercalate) +import Data.Maybe(catMaybes) +import Network.HTTP.Base (RequestMethod(..)) + +import Network.Mollom.MollomMonad +import Network.Mollom.Types + +type SiteLanguage = String + +data SiteResponse = + SiteResponse { siteId :: String + , sitePublicKey :: String + , sitePrivateKey :: String + , siteURL :: String + , siteEmail :: String + , siteLanguages :: [SiteLanguage] + , siteSubscription :: String -- FIXME: I have no idea what this should be + , sitePlatformName :: String + , sitePlatformVersion :: String + , siteClientName :: String + , siteClientVersion :: String + } + deriving (Eq, Show) + +instance A.FromJSON SiteResponse where + parseJSON j = do + o <- A.parseJSON j + s <- o A..: "site" + SiteResponse <$> + s A..: "siteId" <*> + s A..: "publicKey" <*> + s A..: "privateKey" <*> + s A..: "url" <*> + s A..: "email" <*> + s A..: "languages" <*> + s A..: "subscription" <*> + s A..: "platforName" <*> + s A..: "platformVersion" <*> + s A..: "clientName" <*> + s A..: "clientVersion" + +instance A.FromJSON [SiteResponse] where + parseJSON j = do + o <- A.parseJSON j + ls <- o A..: "list" + mapM A.parseJSON ls + + +-- | Request the information Mollom has about a specific site +readSite :: Mollom (MollomResponse SiteResponse) -- ^ The Mollom monad in which the request is made +readSite = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "content/" ++ ( mcPublicKey config) + errors = generalErrors + mollomService pubKey privKey GET path [] [] errors + + +-- | Request that a specific site is deleted from the Mollom service +deleteSite :: A.FromJSON a + => Mollom (MollomResponse a) +deleteSite = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "content/" ++ ( mcPublicKey config) ++ "/delete" + errors = [((4,0,4), SiteError SiteUnknown "")] + mollomService pubKey privKey POST path [] [] errors + + +-- | List all sites that can be accessed with the given authentication +-- FIXME: need to incorporate the offset and count parameters +listSites :: + Maybe Int -- ^ The offset from which to start listing sites. Defaults to 0 when Nothing is given as the argument. + -> Maybe Int -- ^ The number of sites that should be returned. Defaults to all. + -> Mollom (MollomResponse [SiteResponse]) +listSites offset count = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + arguments = case offset `mplus` count of + Nothing -> "" + _ -> "/q?" ++ (intercalate "&" $ catMaybes [ fmap (\o -> "offset=" ++ show o) offset + , fmap (\c -> "count=" ++ show c) count + ]) + path = "site" ++ arguments + errors = generalErrors + mollomService pubKey privKey GET path [] [] errors + diff --git a/src/Network/Mollom/Types.hs b/src/Network/Mollom/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Types.hs @@ -0,0 +1,116 @@ +{- + - (C) 2012, Andy Georges + - + - This module provides the interface to the Mollom site API. + -} + +module Network.Mollom.Types + ( mollomApiVersion + , addMessage + , generalErrors + , MollomConfiguration(..) + , MollomError(..) + , MollomResponse(..) + , BlacklistError(..) + , CaptchaError(..) + , ContentError(..) + , FeedbackError(..) + , SiteError(..) + , WhitelistError(..) + ) where + +import Control.Monad.Error +import qualified Data.Aeson as A +import Network.HTTP.Base (ResponseCode) +import Network.HTTP.Stream (ConnError(..)) + +mollomApiVersion :: String +mollomApiVersion = "1.0" + + +data MollomConfiguration = MollomConfiguration + { mcPublicKey :: String + , mcPrivateKey :: String + , mcAPIVersion :: String + } deriving (Eq, Ord, Show) + + +generalErrors :: [(ResponseCode, MollomError)] +generalErrors = [ ((4,0,1), Unauthorised "") + , ((4,0,3), Forbidden "") + , ((4,0,4), NotFound "") + ] + +data MollomError = ConnectionError ConnError -- ^HTTP connection error + | BlacklistError BlacklistError String + | CaptchaError CaptchaError String + | ContentError ContentError String + | FeedbackError FeedbackError String + | SiteError SiteError String + | WhitelistError WhitelistError String + | Unauthorised String -- ^General unauthorised request error. 401. + | Forbidden String -- ^Unauthorised to make this request. 403. + | NotFound String -- ^Your general oops, you're making the wrong request. 404. + | JSONParseError + | Message String + deriving (Eq, Show) + +instance Error MollomError where + noMsg = Message "" + strMsg s = Message s + +-- | Errors returned by the blacklist API +data BlacklistError = UnknownBlacklistEntry -- The specified entry does not exist. 404. + deriving (Eq, Show) + +-- | Errors returned by the captcha API +data CaptchaError = CaptchaDoesNotExist -- ^The resource was never created. 404. + | CaptchaAlreadyProcessed -- ^The resource was created but was already processed and can thus no longer be solved. 409. + | CaptchaExpired -- ^The resource was created but can no longer be solved since it expired. 410. + deriving (Eq, Show) + +-- | Errors returned bu the content API +data ContentError = Whoops + deriving (Eq, Show) + +-- | Errors returned by the feedback API +data FeedbackError = FeedbackMissingID -- ^The request did not specify either a content or captcha ID. 400. + | FeedbackUnknownReason -- ^The reason is not one that is supported by Mollom. 400. FIXME: this should be a different HTTP code. + deriving (Eq, Show) + +-- | Errors returned by the site API +data SiteError = SiteUnknown -- ^ We have no clue who you are. 404. + deriving (Eq, Show) + +-- | Errors returned by the whitelist API +data WhitelistError = UnknownWhitelistEntry -- ^The specified entry does not exist. 404. + deriving (Eq, Show) + + + +-- | Replace the String message in the error +addMessage :: MollomError -> String -> MollomError +addMessage (BlacklistError b _) s = BlacklistError b s +addMessage (CaptchaError c _) s = CaptchaError c s +addMessage (ContentError c _) s = ContentError c s +addMessage (FeedbackError f _) s = FeedbackError f s +addMessage (SiteError s' _) s = SiteError s' s +addMessage (WhitelistError w _) s = WhitelistError w s +addMessage (Unauthorised _) s = Unauthorised s +addMessage (Forbidden _) s = Forbidden s +addMessage (NotFound _) s = NotFound s +addMessage (Message _) s = Message s + + + + + +data (A.FromJSON a) => MollomResponse a = MollomResponse + { code :: ResponseCode + , message :: String + , response :: a + } deriving (Eq, Show) + + + + diff --git a/src/Network/Mollom/Whitelist.hs b/src/Network/Mollom/Whitelist.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mollom/Whitelist.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- + - (C) 2012, Andy Georges + - + - This module provides the interface to the Mollom whitelisting API. + -} + +module Network.Mollom.Whitelist + ( Reason(..) + , Context(..) + , WhitelistResponse(..) + , createWhitelist + , updateWhitelist + , deleteWhitelist + , listWhitelist + , readWhitelistEntry + ) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader +import qualified Data.Aeson as A +import Data.List(intercalate) +import Data.Maybe(catMaybes) +import Network.HTTP.Base (RequestMethod(..)) + +import Network.Mollom.Helper +import Network.Mollom.MollomMonad +import Network.Mollom.Types + +-- | Data type representing the reasons the user can provide to +-- the Mollom service for whitelisting a string or a value. +data Reason = Spam + | Profanity + | Quality + | Unwanted + deriving (Eq) + +instance Show Reason where + show Spam = "spam" + show Profanity = " profanity" + show Quality = "quality" + show Unwanted = "unwanted" + +instance A.FromJSON Reason where + parseJSON (A.String s) = return $ case s of + "spam" -> Spam + "profanity" -> Profanity + "quality" -> Quality + "unwanted" -> Unwanted + parseJSON _ = mzero + + +-- | Data type representing the context in which the Mollom +-- service is allowed to look for a whitelisted term (to be +-- provided at the creation of said term). +data Context = AuthorName + | AuthorMail + | AuthorIp + | AuthorId + deriving (Eq) + +instance Show Context where + show AuthorName = "authorName" + show AuthorMail = "authorMail" + show AuthorIp = "authorIp" + show AuthorId = "authorId" + + +instance A.FromJSON Context where + parseJSON (A.String s) = return $ case s of + "authorName" -> AuthorName + "authorMail" -> AuthorMail + "authorIp" -> AuthorIp + "authorId" -> AuthorId + parseJSON _ = mzero + + +-- | Data type indicating how well a specific match should be. +data Match = Exact + | Contains + deriving Eq + +instance Show Match where + show Exact = "exact" + show Contains = "contains" + +instance A.FromJSON Match where + parseJSON (A.String s) = return $ case s of + "exact" -> Exact + "contains" -> Contains + parseJSON _ = mzero + + +-- | Data type representing the response in the blacklist API. +data WhitelistResponse = + WhitelistResponse { whitelistId :: String + , whitelistCreated :: String -- FIXME should be datetime + , whitelistStatus :: Bool + , whitelistLastMatch :: String -- FIXME should be datetime + , whitelistMatchCount :: Int + , whitelistValue :: String + , whitelistContext :: Context + , whitelistNote :: String + } + +instance A.FromJSON WhitelistResponse where + parseJSON j = do + o <- A.parseJSON j + e <- o A..: "entry" + WhitelistResponse <$> + e A..: "id" <*> + e A..: "created" <*> + e A..: "status" <*> + e A..: "lastMatch" <*> + e A..: "matchCount" <*> + e A..: "value" <*> + e A..: "context" <*> + e A..: "note" + + +instance A.FromJSON [WhitelistResponse] where + parseJSON j = do + o <- A.parseJSON j + ls <- o A..: "list" + mapM A.parseJSON ls + + + + +-- | Create a whitelist entry for the given site. +createWhitelist :: String -- ^ The value or string to whitelist + -> Maybe Context -- ^ Where may the entry match + -> Maybe Bool -- ^ Is the entry live or not + -> Maybe String -- ^ Note + -> Mollom (MollomResponse WhitelistResponse) +createWhitelist s context status note = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "whitelist/" ++ pubKey + kvs = [ ("value", Just s) + , ("context", fmap show context) + , ("status", fmap boolToOneZeroString status) + , ("note", note) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + + +-- | Update an existing whitelist entry. All arguments that are provided as Nothing +-- default to keeping existing values. +updateWhitelist :: String -- ^ ID of the whitelisted entry to update + -> Maybe String -- ^ The whitelisted string or value. + -> Maybe Context -- ^ Where may the entry match + -> Maybe Bool -- ^ Is the entry live or not + -> Maybe String -- ^ Note + -> Mollom (MollomResponse ()) +updateWhitelist entryId s context status note = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "whitelist/" ++ pubKey ++ "/" ++ entryId + kvs = [ ("value", s) + , ("context", fmap show context) + , ("status", fmap boolToOneZeroString status) + , ("note", note) + ] + errors = generalErrors + mollomService pubKey privKey POST path kvs [] errors + +-- | Delete a whitelisted entry. +deleteWhitelist :: String -- ^ ID of the whitelisted entry to delete + -> Mollom (MollomResponse ()) +deleteWhitelist entryId = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "whitelist/" ++ pubKey ++ "/" ++ entryId ++ "/delete" + errors = generalErrors + mollomService pubKey privKey POST path [] [] errors + + +-- | List the entries in the whitelist for a given set of credentials, +-- identified by the site public key. +-- FIXME: the arguments determination is fugly. +listWhitelist :: Maybe Int -- ^ The offset from which to start listing entries. Defaults to 0 when Nothing is given as the argument. + -> Maybe Int -- ^ The number of entries that should be returned. Defaults to all. + -> Mollom (MollomResponse [WhitelistResponse]) +listWhitelist offset count = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + arguments = case offset `mplus` count of + Nothing -> "" + _ -> "/q?" ++ (intercalate "&" $ catMaybes [ fmap (\o -> "offset=" ++ show o) offset + , fmap (\c -> "count=" ++ show c) count + ]) + path = "whitelist/" ++ pubKey ++ arguments + errors = generalErrors + mollomService pubKey privKey GET path [] [] errors + + +-- | Read the information that is stored for a given whitelist entry. +readWhitelistEntry :: String -- ^ ID of the whitelisted entry to read + -> Mollom (MollomResponse WhitelistResponse) +readWhitelistEntry entryId = do + config <- ask + let pubKey = mcPublicKey config + privKey = mcPrivateKey config + path = "whitelist/" ++ pubKey ++ "/" ++ entryId + errors = generalErrors + mollomService pubKey privKey GET path [] [] errors + +