1 module Rakka.Resource.TrackBack
6 import qualified Codec.Binary.UTF8.String as UTF8
8 import Control.Arrow.ArrowList
9 import Control.Monad.Trans
12 import Network.Browser
14 import Network.HTTP.Lucu
15 import Network.HTTP.Lucu.Utils
17 import Rakka.Environment
19 import Text.XML.HXT.Arrow.WriteDocument
20 import Text.XML.HXT.Arrow.XmlArrow
21 import Text.XML.HXT.Arrow.XmlIOStateArrow
22 import Text.XML.HXT.DOM.TypeDefs
23 import Text.XML.HXT.DOM.XmlKeywords
28 tbTitle :: !(Maybe String)
29 , tbExcerpt :: !(Maybe String)
31 , tbBlogName :: !(Maybe String)
42 resTrackBack :: Environment -> ResourceDef
45 resUsesNativeThread = False
49 , resPost = Just $ getPathInfo >>= handlePost env . toPageName
54 toPageName :: [String] -> PageName
55 toPageName = decodePageName . joinWith "/"
58 handlePost :: Environment -> PageName -> Resource ()
60 = do form <- inputForm defaultLimit
61 tbParamM <- validateTBParam form
66 -> do cited <- liftIO $ checkCitation tbParam name
70 outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
73 validateTBParam :: [(String, String)] -> Resource (Maybe TBParam)
75 = do let title = get' "title"
76 excerpt = get' "excerpt"
77 blogName = get' "blogName"
80 -> do outputResponse (Error 1 "Parameter `url' is missing.")
85 -> do outputResponse (Error 1 "Parameter `url' is malformed.")
88 -> return $ Just TBParam {
92 , tbBlogName = blogName
95 get' :: String -> Maybe String
96 get' = fmap UTF8.decodeString . flip lookup form
99 outputResponse :: TBResponse -> Resource ()
101 = do setContentType $ read "text/xml"
102 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
106 writeDocumentToString [ (a_indent, v_1) ]
110 mkResponseTree :: ArrowXml a => a b XmlTree
114 += ( eelem "response"
118 Error code _ -> show code)
122 Error _ msg -> ( eelem "message"
130 checkCitation :: TBParam -> PageName -> IO Bool
131 checkCitation param name
132 = do (_, res) <- browse $
133 do setAllowRedirects True
134 setErrHandler (\ _ -> return ())
135 setOutHandler (\ _ -> return ())
136 request $ defaultGETRequest $ tbURL param
139 -> return (encodePageName name `isInfixOf` rspBody res)