+++ /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 Data.Time
-import Network.Browser
-import Network.HTTP
-import Network.HTTP.Lucu
-import Network.HTTP.Lucu.Response
-import Network.URI
-import Rakka.Environment
-import Rakka.Page
-import Rakka.Storage
-import Rakka.SystemConfig
-import Rakka.TrackBack
-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 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 = UTF8.decodeString . joinPath
-
-
-handlePost :: Environment -> PageName -> Resource ()
-handlePost env name
- = do form <- inputForm defaultLimit
- tbParamM <- validateTrackBack form
- case tbParamM of
- Nothing
- -> return ()
- Just tbParam
- -> do cited <- liftIO $ checkCitation tbParam name
- if cited then
- do pageM <- getPage (envStorage env) name Nothing
- case pageM of
- Nothing -> setStatus NotFound
- Just page -> addTB tbParam page
- else
- outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
- where
- addTB :: TrackBack -> Page -> Resource ()
- addTB tbParam page
- | isRedirect page
- = do BaseURI baseURI <- getSysConf (envSysConf env)
- redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
- | otherwise
- = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
- st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
- if isSuccessful st then
- outputResponse NoError
- else
- setStatus st
-
-
-validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
-validateTrackBack form
- = do let title = get' "title"
- excerpt = get' "excerpt"
- blogName = get' "blog_name"
- 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
- -> do time <- liftIO getCurrentTime
- return $ Just TrackBack {
- tbTitle = title
- , tbExcerpt = excerpt
- , tbURL = url
- , tbBlogName = blogName
- , tbTime = time
- }
- 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 )
- , (a_output_encoding, utf8)
- , (a_no_xml_pi , v_0 ) ]
- )
- output $ UTF8.encodeString 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 :: TrackBack -> 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