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
17 import Network.HTTP.Lucu.Utils
19 import Rakka.Environment
22 import Rakka.SystemConfig
23 import Rakka.TrackBack
24 import Text.XML.HXT.Arrow.WriteDocument
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlIOStateArrow
27 import Text.XML.HXT.DOM.TypeDefs
28 import Text.XML.HXT.DOM.XmlKeywords
37 resTrackBack :: Environment -> ResourceDef
40 resUsesNativeThread = False
44 , resPost = Just $ getPathInfo >>= handlePost env . toPageName
49 toPageName :: [String] -> PageName
50 toPageName = decodePageName . joinWith "/"
53 handlePost :: Environment -> PageName -> Resource ()
55 = do form <- inputForm defaultLimit
56 tbParamM <- validateTrackBack form
61 -> do cited <- liftIO $ checkCitation tbParam name
63 do pageM <- getPage (envStorage env) name Nothing
65 Nothing -> setStatus NotFound
66 Just page -> addTB tbParam page
68 outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
70 addTB :: TrackBack -> Page -> Resource ()
73 = do BaseURI baseURI <- getSysConf (envSysConf env)
74 redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
76 = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
77 st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
78 if isSuccessful st then
79 outputResponse NoError
84 validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
85 validateTrackBack form
86 = do let title = get' "title"
87 excerpt = get' "excerpt"
88 blogName = get' "blog_name"
91 -> do outputResponse (Error 1 "Parameter `url' is missing.")
96 -> do outputResponse (Error 1 "Parameter `url' is malformed.")
99 -> do time <- liftIO getCurrentTime
100 return $ Just TrackBack {
102 , tbExcerpt = excerpt
104 , tbBlogName = blogName
108 get' :: String -> Maybe String
109 get' = fmap UTF8.decodeString . flip lookup form
112 outputResponse :: TBResponse -> Resource ()
114 = do setContentType $ read "text/xml"
115 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
119 writeDocumentToString [ (a_indent , v_1 )
120 , (a_output_encoding, utf8)
121 , (a_no_xml_pi , v_0 ) ]
125 mkResponseTree :: ArrowXml a => a b XmlTree
129 += ( eelem "response"
133 Error code _ -> show code)
137 Error _ msg -> ( eelem "message"
145 checkCitation :: TrackBack -> PageName -> IO Bool
146 checkCitation param name
147 = do (_, res) <- browse $
148 do setAllowRedirects True
149 setErrHandler (\ _ -> return ())
150 setOutHandler (\ _ -> return ())
151 request $ defaultGETRequest $ tbURL param
154 -> return (encodePageName name `isInfixOf` rspBody res)