)
where
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowList
import Control.Monad.Trans
import Data.Char
+import qualified Data.Map as M
import Data.Maybe
import Data.Time
import Network.HTTP.Lucu
import Rakka.Wiki.Engine
import System.FilePath
import Text.HyperEstraier hiding (getText)
-import Text.XML.HXT.Arrow.Namespace
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlIOStateArrow
-import Text.XML.HXT.Arrow.XmlNodeSet
+import Text.XML.HXT.Arrow
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.DOM.XmlKeywords
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
- = runIdempotentA $ proc ()
- -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
- case pageM of
- Nothing
- -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
- case items of
- [] -> handlePageNotFound env -< name
- _ -> handleGetPageListing env -< (name, items)
- Just page
- -> if isEntity page then
- handleGetEntity env -< page
- else
- handleRedirect env -< page
+ = do BaseURI baseURI <- getSysConf (envSysConf env)
+ runIdempotentA baseURI $ proc ()
+ -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
+ case pageM of
+ Nothing
+ -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
+ case items of
+ [] -> handlePageNotFound env -< name
+ _ -> handleGetPageListing env -< (name, items)
+ Just page
+ -> if isEntity page then
+ handleGetEntity env -< page
+ else
+ handleRedirect env -< page
{-
handleGetEntity env
= proc page
-> do tree <- xmlizePage -< page
- returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
- -- てゐる可能性があるので、ETag も
- -- Last-Modified も返す事が出來ない。
- case entityType page of
- MIMEType "text" "x-rakka" _
- -> return ()
- _ -> case entityRevision page of
- 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
- rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
-
- outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
- , (MIMEType "application" "rss+xml" [], entityToRSS env)
- ]
+ returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
+ , (MIMEType "application" "rss+xml" [], entityToRSS env)
+ ]
entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
- pageTitle <- listA (readSubPage env) -< (Just name, Just page, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right")
+ pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
( eelem "/"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( getXPathTreesInDoc "/page/@lang"
`guards`
- qattr (QN "xml" "lang" "")
+ qattr (mkQName "xml" "lang" "")
( getXPathTreesInDoc "/page/@lang/text()" )
)
+= ( eelem "head"
readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
- -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
+ -> a (PageName, Maybe XmlTree, PageName) XmlTree
readSubPage env
= proc (mainPageName, mainPage, subPageName) ->
- do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
- subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
- -< (mainPageName, mainPage, subPage)
+ do langM <- case mainPage of
+ Nothing
+ -> returnA -< Nothing
+ Just p
+ -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
+ subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
+ localSubPage <- case langM of
+ Nothing
+ -> returnA -< subPage
+ Just l
+ -> localize (envStorage env) -< (l, subPage)
+ subPageXml <- xmlizePage -< localSubPage
+ subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
+ -< (Just mainPageName, mainPage, subPageXml)
returnA -< subXHTML
+ where
+ localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
+ localize sto
+ = proc (lang, origPage)
+ -> do let otherLang = entityOtherLang origPage
+ localName = M.lookup lang otherLang
+ case localName of
+ Nothing
+ -> returnA -< origPage
+ Just ln
+ -> do localPage <- getPageA sto -< (ln, Nothing)
+ returnA -< case localPage of
+ Nothing -> origPage
+ Just p -> p
{-
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
+ pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
( eelem "/"
+= ( eelem "html"
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
+ pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
( eelem "/"
+= ( eelem "html"
addAttrCond cond "rakka:isFeed STREQ yes"
setOrder cond "@uri STRA"
result <- searchPages sto cond
- return (map fst result)
+ return (map hpPageName $ srPages result)
mkFeedURIStr :: URI -> PageName -> String
mkFeedURIStr baseURI name
- = uriToString id (mkFeedURI baseURI name) ""
\ No newline at end of file
+ = uriToString id (mkFeedURI baseURI name) ""