+module Rakka.Resource.TrackBack
+ ( resTrackBack
+ )
+ where
+
+import qualified Codec.Binary.UTF8.String as UTF8
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Monad.Trans
+import Data.List
+import Data.Maybe
+import Network.Browser
+import Network.HTTP
+import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Utils
+import Network.URI
+import Rakka.Environment
+import Rakka.Page
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+data TBParam
+ = TBParam {
+ tbTitle :: !(Maybe String)
+ , tbExcerpt :: !(Maybe String)
+ , tbURL :: !URI
+ , tbBlogName :: !(Maybe String)
+ }
+ deriving (Show, Eq)
+
+
+data TBResponse
+ = NoError
+ | Error !Int !String
+ deriving (Show, Eq)
+
+
+resTrackBack :: Environment -> ResourceDef
+resTrackBack env
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Nothing
+ , resHead = Nothing
+ , resPost = Just $ getPathInfo >>= handlePost env . toPageName
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+ where
+ toPageName :: [String] -> PageName
+ toPageName = decodePageName . joinWith "/"
+
+
+handlePost :: Environment -> PageName -> Resource ()
+handlePost env name
+ = do form <- inputForm defaultLimit
+ tbParamM <- validateTBParam form
+ case tbParamM of
+ Nothing
+ -> return ()
+ Just tbParam
+ -> do cited <- liftIO $ checkCitation tbParam name
+ if cited then
+ fail "not impl"
+ else
+ outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
+
+
+validateTBParam :: [(String, String)] -> Resource (Maybe TBParam)
+validateTBParam form
+ = do let title = get' "title"
+ excerpt = get' "excerpt"
+ blogName = get' "blogName"
+ case get' "url" of
+ Nothing
+ -> do outputResponse (Error 1 "Parameter `url' is missing.")
+ return Nothing
+ Just u
+ -> case parseURI u of
+ Nothing
+ -> do outputResponse (Error 1 "Parameter `url' is malformed.")
+ return Nothing
+ Just url
+ -> return $ Just TBParam {
+ tbTitle = title
+ , tbExcerpt = excerpt
+ , tbURL = url
+ , tbBlogName = blogName
+ }
+ where
+ get' :: String -> Maybe String
+ get' = fmap UTF8.decodeString . flip lookup form
+
+
+outputResponse :: TBResponse -> Resource ()
+outputResponse res
+ = do setContentType $ read "text/xml"
+ [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ mkResponseTree
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ output xmlStr
+ where
+ mkResponseTree :: ArrowXml a => a b XmlTree
+ mkResponseTree
+ = proc _
+ -> ( eelem "/"
+ += ( eelem "response"
+ += ( eelem "error"
+ += txt (case res of
+ NoError -> "0"
+ Error code _ -> show code)
+ )
+ += ( case res of
+ NoError -> none
+ Error _ msg -> ( eelem "message"
+ += txt msg
+ )
+ )
+ )
+ ) -< ()
+
+
+checkCitation :: TBParam -> PageName -> IO Bool
+checkCitation param name
+ = do (_, res) <- browse $
+ do setAllowRedirects True
+ setErrHandler (\ _ -> return ())
+ setOutHandler (\ _ -> return ())
+ request $ defaultGETRequest $ tbURL param
+ case rspCode res of
+ (2, 0, 0)
+ -> return (encodePageName name `isInfixOf` rspBody res)
+ _ -> return False
projects / Rakka.git / commitdiff