From: pho Date: Mon, 24 Dec 2007 04:20:10 +0000 (+0900) Subject: improvements related to redirection X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=701592b0fae35ebc8cb4f855c7701c88fc75566b;p=Rakka.git improvements related to redirection darcs-hash:20071224042010-62b54-d5e5e823565ca4d896a8afef375e57966533e2bb.gz --- diff --git a/Rakka/Page.hs b/Rakka/Page.hs index b293b1f..2462bab 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -211,7 +211,7 @@ mkRakkaURI name = URI { isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" isBinary="no" - revision="112"> -- デフォルトでない場合のみ存在 + revision="112" lastModified="2000-01-01T00:00:00"> @@ -230,59 +230,84 @@ mkRakkaURI name = URI { SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS... + + -} xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree xmlizePage = proc page - -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page - ( eelem "/" - += ( eelem "page" - += sattr "name" (pageName page) - += sattr "type" (show $ entityType page) - += ( case entityLanguage page of - Just x -> sattr "lang" x - Nothing -> none - ) - += ( case entityFileName page of - Just x -> sattr "fileName" x - Nothing -> none - ) - += ( case entityType page of - MIMEType "text" "css" _ - -> sattr "isTheme" (yesOrNo $ entityIsTheme page) - MIMEType "text" "x-rakka" _ - -> sattr "isFeed" (yesOrNo $ entityIsFeed page) - _ - -> none - ) - += sattr "isLocked" (yesOrNo $ entityIsLocked page) - += sattr "isBoring" (yesOrNo $ entityIsBoring page) - += sattr "isBinary" (yesOrNo $ entityIsBinary page) - += sattr "revision" (show $ entityRevision page) - += sattr "lastModified" (formatW3CDateTime lastMod) - += ( case entitySummary page of - Just s -> eelem "summary" += txt s - Nothing -> none - ) - += ( if M.null (entityOtherLang page) then - none - else - selem "otherLang" - [ eelem "link" - += sattr "lang" lang - += sattr "page" name - | (lang, name) <- M.toList (entityOtherLang page) ] - ) - += ( if entityIsBinary page then - ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ entityContent page) + -> if isRedirect page then + xmlizeRedirection -< page + else + xmlizeEntity -< page + where + xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree + xmlizeRedirection + = proc page + -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page + ( eelem "/" + += ( eelem "page" + += sattr "name" (redirName page) + += sattr "redirect" (redirDest page) + += sattr "revision" (show $ redirRevision page) + += sattr "lastModified" (formatW3CDateTime lastMod) + )) -<< () + + xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree + xmlizeEntity + = proc page + -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page + ( eelem "/" + += ( eelem "page" + += sattr "name" (pageName page) + += sattr "type" (show $ entityType page) + += ( case entityLanguage page of + Just x -> sattr "lang" x + Nothing -> none + ) + += ( case entityFileName page of + Just x -> sattr "fileName" x + Nothing -> none + ) + += ( case entityType page of + MIMEType "text" "css" _ + -> sattr "isTheme" (yesOrNo $ entityIsTheme page) + MIMEType "text" "x-rakka" _ + -> sattr "isFeed" (yesOrNo $ entityIsFeed page) + _ + -> none + ) + += sattr "isLocked" (yesOrNo $ entityIsLocked page) + += sattr "isBoring" (yesOrNo $ entityIsBoring page) + += sattr "isBinary" (yesOrNo $ entityIsBinary page) + += sattr "revision" (show $ entityRevision page) + += sattr "lastModified" (formatW3CDateTime lastMod) + += ( case entitySummary page of + Just s -> eelem "summary" += txt s + Nothing -> none + ) + += ( if M.null (entityOtherLang page) then + none + else + selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" name + | (lang, name) <- M.toList (entityOtherLang page) ] ) - else - ( eelem "textData" - += txt (decode $ L.unpack $ entityContent page) + += ( if entityIsBinary page then + ( eelem "binaryData" + += txt (B64.encode $ L.unpack $ entityContent page) + ) + else + ( eelem "textData" + += txt (decode $ L.unpack $ entityContent page) + ) ) - ) - )) -<< () + )) -<< () parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 7c4487a..47ae110 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,6 +1,5 @@ module Rakka.Wiki.Engine ( InterpTable - , xmlizePage , makeMainXHTML , makeSubXHTML , makeDraft @@ -192,63 +191,92 @@ interpretCommands sto sysConf interpTable makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document makeDraft interpTable = proc tree -> - do doc <- arrIO0 newDocument -< () + do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree + case redir of + Nothing -> makeEntityDraft -< tree + Just _ -> makeRedirectDraft -< tree + where + makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document + makeEntityDraft + = proc tree -> + do doc <- arrIO0 newDocument -< () - pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree - pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree - pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree - pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree - pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()" >>> getText -< tree - pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree - pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree - pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree - pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree - pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree - pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree - pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree - - arrIO2 setURI -< (doc, Just $ mkRakkaURI pName) - arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName) - arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType) - arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) - arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang) - arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName) - arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked) - arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring) - arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary) - arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) - arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary) - - arrIO2 addHiddenText -< (doc, pName) - - case pSummary of - Just s -> arrIO2 addHiddenText -< (doc, s) - Nothing -> returnA -< () - - -- otherLang はリンク先ページ名を hidden text で入れる。 - otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree - listA ( (arr fst &&& arrL snd) - >>> - arrIO2 addHiddenText - >>> - none - ) -< (doc, otherLangs) - - case read pType of - MIMEType "text" "css" _ - -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme) + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree + pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree + pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree + pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()" >>> getText -< tree + pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree + pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree + pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree + pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree + pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree + pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree + pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree + + arrIO2 setURI -< (doc, Just $ mkRakkaURI pName) + arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName) + arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType) + arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) + arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang) + arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName) + arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked) + arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring) + arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary) + arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) + arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary) + + arrIO2 addHiddenText -< (doc, pName) + + case pSummary of + Just s -> arrIO2 addHiddenText -< (doc, s) + Nothing -> returnA -< () + + -- otherLang はリンク先ページ名を hidden text で入れる。 + otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree + listA ( (arr fst &&& arrL snd) + >>> + arrIO2 addHiddenText + >>> + none + ) -< (doc, otherLangs) + + case read pType of + MIMEType "text" "css" _ + -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme) - MIMEType "text" "x-rakka" _ - -- wikify して興味のある部分を addText する。 - -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed) - wiki <- wikifyPage interpTable -< tree - arrIO2 (mapM_ . addBlockText) -< (doc, wiki) + MIMEType "text" "x-rakka" _ + -- wikify して興味のある部分を addText する。 + -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed) + wiki <- wikifyPage interpTable -< tree + arrIO2 (mapM_ . addBlockText) -< (doc, wiki) - MIMEType _ _ _ - -> returnA -< () + MIMEType _ _ _ + -> returnA -< () + + returnA -< doc + + makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document + makeRedirectDraft + = proc tree -> + do doc <- arrIO0 newDocument -< () + + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree + pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree + pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree + + arrIO2 setURI -< (doc, Just $ mkRakkaURI pName) + arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName) + arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection") + arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) + arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) + + -- リダイレクト先ページ名はテキストとして入れる + arrIO2 addText -< (doc, pRedir) + + returnA -< doc - returnA -< doc - where addElemText :: Document -> Element -> IO () addElemText doc (Block b) = addBlockText doc b addElemText doc (Inline i) = addInlineText doc i