hMollom 0.2.2 → 0.3.1
raw patch · 14 files changed
+1318/−409 lines, 14 filesdep +HTTPdep +aesondep +attoparsecdep −haxr
Dependencies added: HTTP, aeson, attoparsec, ghc-prim, old-time, pureMD5, random
Dependencies removed: haxr
Files
- hMollom.cabal +30/−8
- src/Network/Mollom.hs +4/−278
- src/Network/Mollom/Auth.hs +0/−47
- src/Network/Mollom/Blacklist.hs +234/−0
- src/Network/Mollom/Captcha.hs +121/−0
- src/Network/Mollom/Content.hs +176/−0
- src/Network/Mollom/Feedback.hs +58/−0
- src/Network/Mollom/Helper.hs +15/−0
- src/Network/Mollom/Internals.hs +81/−44
- src/Network/Mollom/MollomMonad.hs +43/−32
- src/Network/Mollom/OAuth.hs +115/−0
- src/Network/Mollom/Site.hs +109/−0
- src/Network/Mollom/Types.hs +116/−0
- src/Network/Mollom/Whitelist.hs +216/−0
hMollom.cabal view
@@ -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
src/Network/Mollom.hs view
@@ -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--- <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 - -> 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 [])
− src/Network/Mollom/Auth.hs
@@ -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)]-
+ src/Network/Mollom/Blacklist.hs view
@@ -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++
+ src/Network/Mollom/Captcha.hs view
@@ -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+
+ src/Network/Mollom/Content.hs view
@@ -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+++++
+ src/Network/Mollom/Feedback.hs view
@@ -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++
+ src/Network/Mollom/Helper.hs view
@@ -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"
src/Network/Mollom/Internals.hs view
@@ -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
src/Network/Mollom/MollomMonad.hs view
@@ -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)
+ src/Network/Mollom/OAuth.hs view
@@ -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+
+ src/Network/Mollom/Site.hs view
@@ -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+
+ src/Network/Mollom/Types.hs view
@@ -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)++++
+ src/Network/Mollom/Whitelist.hs view
@@ -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++