+++ /dev/null
-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