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.Utils
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 = decodePageName . joinWith "/"
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)
80 validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
81 validateTrackBack form
82 = do let title = get' "title"
83 excerpt = get' "excerpt"
84 blogName = get' "blogName"
87 -> do outputResponse (Error 1 "Parameter `url' is missing.")
92 -> do outputResponse (Error 1 "Parameter `url' is malformed.")
95 -> do time <- liftIO getCurrentTime
96 return $ Just TrackBack {
100 , tbBlogName = blogName
104 get' :: String -> Maybe String
105 get' = fmap UTF8.decodeString . flip lookup form
108 outputResponse :: TBResponse -> Resource ()
110 = do setContentType $ read "text/xml"
111 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
115 writeDocumentToString [ (a_indent, v_1) ]
119 mkResponseTree :: ArrowXml a => a b XmlTree
123 += ( eelem "response"
127 Error code _ -> show code)
131 Error _ msg -> ( eelem "message"
139 checkCitation :: TrackBack -> PageName -> IO Bool
140 checkCitation param name
141 = do (_, res) <- browse $
142 do setAllowRedirects True
143 setErrHandler (\ _ -> return ())
144 setOutHandler (\ _ -> return ())
145 request $ defaultGETRequest $ tbURL param
148 -> return (encodePageName name `isInfixOf` rspBody res)