1 module Rakka.Resource.TrackBack
6 import qualified Codec.Binary.UTF8.String as UTF8
8 import Control.Arrow.ArrowList
9 import Control.Monad.Trans
13 import Network.Browser
15 import Network.HTTP.Lucu
16 import Network.HTTP.Lucu.Response
18 import Rakka.Environment
21 import Rakka.SystemConfig
22 import Rakka.TrackBack
23 import Text.XML.HXT.Arrow.WriteDocument
24 import Text.XML.HXT.Arrow.XmlArrow
25 import Text.XML.HXT.Arrow.XmlIOStateArrow
26 import Text.XML.HXT.DOM.TypeDefs
27 import Text.XML.HXT.DOM.XmlKeywords
36 resTrackBack :: Environment -> ResourceDef
39 resUsesNativeThread = False
43 , resPost = Just $ getPathInfo >>= handlePost env . toPageName
48 toPageName :: [String] -> PageName
49 toPageName = UTF8.decodeString . joinPath
52 handlePost :: Environment -> PageName -> Resource ()
54 = do form <- inputForm defaultLimit
55 tbParamM <- validateTrackBack form
60 -> do cited <- liftIO $ checkCitation tbParam name
62 do pageM <- getPage (envStorage env) name Nothing
64 Nothing -> setStatus NotFound
65 Just page -> addTB tbParam page
67 outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
69 addTB :: TrackBack -> Page -> Resource ()
72 = do BaseURI baseURI <- getSysConf (envSysConf env)
73 redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
75 = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
76 st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
77 if isSuccessful st then
78 outputResponse NoError
83 validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
84 validateTrackBack form
85 = do let title = get' "title"
86 excerpt = get' "excerpt"
87 blogName = get' "blog_name"
90 -> do outputResponse (Error 1 "Parameter `url' is missing.")
95 -> do outputResponse (Error 1 "Parameter `url' is malformed.")
98 -> do time <- liftIO getCurrentTime
99 return $ Just TrackBack {
101 , tbExcerpt = excerpt
103 , tbBlogName = blogName
107 get' :: String -> Maybe String
108 get' = fmap UTF8.decodeString . flip lookup form
111 outputResponse :: TBResponse -> Resource ()
113 = do setContentType $ read "text/xml"
114 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
118 writeDocumentToString [ (a_indent , v_1 )
119 , (a_output_encoding, utf8)
120 , (a_no_xml_pi , v_0 ) ]
124 mkResponseTree :: ArrowXml a => a b XmlTree
128 += ( eelem "response"
132 Error code _ -> show code)
136 Error _ msg -> ( eelem "message"
144 checkCitation :: TrackBack -> PageName -> IO Bool
145 checkCitation param name
146 = do (_, res) <- browse $
147 do setAllowRedirects True
148 setErrHandler (\ _ -> return ())
149 setOutHandler (\ _ -> return ())
150 request $ defaultGETRequest $ tbURL param
153 -> return (encodePageName name `isInfixOf` rspBody res)