module Rakka.Resource.PageEntity ( fallbackPageEntity ) where import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowIf import Control.Arrow.ArrowList import Control.Monad.Trans import Data.Char import Data.Maybe import Data.Time import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI hiding (path) import Rakka.Environment import Rakka.Page import Rakka.Resource import Rakka.Storage import Rakka.SystemConfig import Rakka.Utils import Rakka.W3CDateTime 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.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef) fallbackPageEntity env path | null path = return Nothing | null $ head path = return Nothing | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない | otherwise = return $ Just $ ResourceDef { resUsesNativeThread = False , resIsGreedy = True , resGet = Just $ handleGet env (toPageName path) , resHead = Nothing , resPost = Nothing , resPut = Just $ handlePut env (toPageName path) , resDelete = Just $ handleDelete env (toPageName path) } where toPageName :: [String] -> PageName toPageName = decodePageName . dropExtension . joinWith "/" 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 {- HTTP/1.1 302 Found Location: http://example.org/Destination.html#Redirect:Source -} handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ()) handleRedirect env = proc redir -> returnA -< do mType <- getEntityType case mType of MIMEType "text" "xml" _ -> do setContentType mType [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail >>> constA redir >>> xmlizePage >>> writeDocumentToString [ (a_indent, v_1) ] ) output resultStr _ -> do BaseURI baseURI <- getSysConf (envSysConf env) let uri = mkPageFragmentURI baseURI (redirDest redir) ("Redirect:" ++ redirName redir) redirect Found uri handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ()) handleGetEntity env = proc page -> do tree <- xmlizePage -< page 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 entityToXHTML env = proc page -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] 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") pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( getXPathTreesInDoc "/page/@lang" `guards` qattr (QN "xml" "lang" "") ( getXPathTreesInDoc "/page/@lang/text()" ) ) += ( eelem "head" += ( eelem "title" += txt siteName += txt " - " += getXPathTreesInDoc "/page/@name/text()" ) += ( constL cssHref >>> eelem "link" += sattr "rel" "stylesheet" += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) += ( constL feeds >>> eelem "link" += sattr "rel" "alternate" += sattr "type" "application/rss+xml" += attr "title" (txt siteName <+> txt " - " <+> mkText) += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText) ) += ( constL scriptSrc >>> eelem "script" += sattr "type" "text/javascript" += attr "src" (arr id >>> mkText) ) += ( eelem "script" += sattr "type" "text/javascript" += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) ) += ( eelem "body" += ( eelem "div" += sattr "class" "header" ) += ( eelem "div" += sattr "class" "center" += ( eelem "div" += sattr "class" "title" += constL pageTitle ) += ( eelem "div" += sattr "class" "body" += constL pageBody ) ) += ( eelem "div" += sattr "class" "footer" ) += ( eelem "div" += sattr "class" "left sideBar" += ( eelem "div" += sattr "class" "content" += constL leftSideBar ) ) += ( eelem "div" += sattr "class" "right sideBar" += ( eelem "div" += sattr "class" "content" += constL rightSideBar ) ) ) >>> uniqueNamespacesFromDeclAndQNames ) ) -<< page entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree entityToRSS env = proc page -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page ( eelem "/" += ( eelem "rdf:RDF" += sattr "xmlns" "http://purl.org/rss/1.0/" += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/" += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/" += ( eelem "channel" += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "") += ( eelem "title" += txt siteName += txt " - " += getXPathTreesInDoc "/page/@name/text()" ) += ( eelem "link" += txt (uriToString id baseURI "") ) += ( eelem "description" += txt (case summary of Nothing -> "RSS Feed for " ++ siteName Just s -> s) ) += ( eelem "items" += ( eelem "rdf:Seq" += ( constL pages >>> eelem "rdf:li" += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText) ) ) ) ) += ( constL pages >>> arr (\ n -> (n, Nothing)) >>> getPageA (envStorage env) >>> arr fromJust >>> eelem "item" += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText) += ( eelem "title" += (arr entityName >>> mkText) ) += ( eelem "link" += (arr (mkPageURIStr baseURI . entityName) >>> mkText) ) += ( arrL (\ p -> case entitySummary p of Nothing -> [] Just s -> [s]) >>> eelem "description" += mkText ) += ( eelem "dc:date" += ( arrIO (utcToLocalZonedTime . entityLastMod) >>> arr formatW3CDateTime >>> mkText ) ) += ( eelem "trackback:ping" += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText) ) ) >>> uniqueNamespacesFromDeclAndQNames ) ) -<< page where mkPageURIStr :: URI -> PageName -> String mkPageURIStr baseURI name = uriToString id (mkPageURI baseURI name) "" mkTrackbackURIStr :: URI -> PageName -> String mkTrackbackURIStr baseURI name = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) "" readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (Maybe 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) returnA -< subXHTML {- -} handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ()) handleGetPageListing env = proc (dir, items) -> do tree <- ( eelem "/" += ( eelem "pageListing" += attr "path" (arr fst >>> mkText) += ( arrL snd >>> ( eelem "page" += attr "name" (arr id >>> mkText) ) ) ) ) -< (dir, items) returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree pageListingToXHTML env = proc pageListing -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing 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") ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" += txt siteName += txt " - " += getXPathTreesInDoc "/pageListing/@path/text()" ) += ( constL cssHref >>> eelem "link" += sattr "rel" "stylesheet" += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) += ( constL scriptSrc >>> eelem "script" += sattr "type" "text/javascript" += attr "src" (arr id >>> mkText) ) += ( eelem "script" += sattr "type" "text/javascript" += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) ) += ( eelem "body" += ( eelem "div" += sattr "class" "header" ) += ( eelem "div" += sattr "class" "center" += ( eelem "div" += sattr "class" "title" += constL pageTitle ) += ( eelem "div" += sattr "class" "body" += ( eelem "ul" += ( getXPathTreesInDoc "/pageListing/page/@name/text()" >>> eelem "li" += ( eelem "a" += attr "href" ( getText >>> arr (\ x -> uriToString id (mkPageURI baseURI x) "") >>> mkText ) += this ) ) ) ) ) += ( eelem "div" += sattr "class" "footer" ) += ( eelem "div" += sattr "class" "left sideBar" += ( eelem "div" += sattr "class" "content" += constL leftSideBar ) ) += ( eelem "div" += sattr "class" "right sideBar" += ( eelem "div" += sattr "class" "content" += constL rightSideBar ) ) ) >>> uniqueNamespacesFromDeclAndQNames ) ) -<< pageListing {- -} handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ()) handlePageNotFound env = proc name -> do tree <- ( eelem "/" += ( eelem "pageNotFound" += attr "name" (arr id >>> mkText) ) ) -< name returnA -< do setStatus NotFound outputXmlPage' tree (notFoundToXHTML env) notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree notFoundToXHTML env = proc pageNotFound -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound 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") ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" += txt siteName += txt " - " += getXPathTreesInDoc "/pageNotFound/@name/text()" ) += ( constL cssHref >>> eelem "link" += sattr "rel" "stylesheet" += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) += ( constL scriptSrc >>> eelem "script" += sattr "type" "text/javascript" += attr "src" (arr id >>> mkText) ) += ( eelem "script" += sattr "type" "text/javascript" += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) ) += ( eelem "body" += ( eelem "div" += sattr "class" "header" ) += ( eelem "div" += sattr "class" "center" += ( eelem "div" += sattr "class" "title" += constL pageTitle ) += ( eelem "div" += sattr "class" "body" += txt "404 Not Found (FIXME)" -- FIXME ) ) += ( eelem "div" += sattr "class" "footer" ) += ( eelem "div" += sattr "class" "left sideBar" += ( eelem "div" += sattr "class" "content" += constL leftSideBar ) ) += ( eelem "div" += sattr "class" "right sideBar" += ( eelem "div" += sattr "class" "content" += constL rightSideBar ) ) ) >>> uniqueNamespacesFromDeclAndQNames ) ) -<< pageNotFound handlePut :: Environment -> PageName -> Resource () handlePut env name = do userID <- getUserID env runXmlA env "rakka-page-1.0.rng" $ proc tree -> do page <- parseXmlizedPage -< (name, tree) status <- putPageA (envStorage env) -< (userID, page) returnA -< setStatus status handleDelete :: Environment -> PageName -> Resource () handleDelete env name = do userID <- getUserID env status <- deletePage (envStorage env) userID name setStatus status findFeeds :: Storage -> IO [PageName] findFeeds sto = do cond <- newCondition setPhrase cond "[UVSET]" addAttrCond cond "rakka:isFeed STREQ yes" setOrder cond "@uri STRA" result <- searchPages sto cond return (map srPageName result) mkFeedURIStr :: URI -> PageName -> String mkFeedURIStr baseURI name = uriToString id (mkFeedURI baseURI name) ""