X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=1dd185f3b8d4e3269d401c412545c918897ed619;hb=e751af5e3d23d7757f363bf4e86f9d732d90be7f;hp=d84ddc7b6af0024b9792aafff1d1c835fb29ead6;hpb=d6f5dd9adfa8bccc7799396554dfaf80d9522a38;p=Rakka.git
diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index d84ddc7..1dd185f 100644
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -10,6 +10,7 @@ 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)
@@ -18,8 +19,12 @@ 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
@@ -37,11 +42,11 @@ fallbackPageEntity env path
= return $ Just $ ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
- , resGet = Just $ handleGet env (toPageName path)
+ , resGet = Just $ handleGet env (toPageName path)
, resHead = Nothing
, resPost = Nothing
- , resPut = Just $ handlePut env (toPageName path)
- , resDelete = Nothing
+ , resPut = Just $ handlePut env (toPageName path)
+ , resDelete = Just $ handleDelete env (toPageName path)
}
where
toPageName :: [String] -> PageName
@@ -54,13 +59,16 @@ handleGet env name
-> do pageM <- getPageA (envStorage env) -< (name, Nothing)
case pageM of
Nothing
- -> handlePageNotFound env -< name
+ -> 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
- Just redir@(Redirection _ _ _ _ _)
- -> handleRedirect env -< redir
-
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
- -> handleGetEntity env -< entity
{-
HTTP/1.1 302 Found
@@ -71,14 +79,6 @@ handleRedirect env
= proc redir
-> returnA -< do mType <- getEntityType
case mType of
- MIMEType "application" "xhtml+xml" _
- -> do BaseURI baseURI <- getSysConf (envSysConf env)
- let uri = mkPageFragmentURI
- baseURI
- (redirDest redir)
- ("Redirect:" ++ redirName redir)
- redirect Found uri
-
MIMEType "text" "xml" _
-> do setContentType mType
[resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
@@ -91,24 +91,21 @@ handleRedirect env
)
output resultStr
- _ -> fail ("internal error: getEntityType returned " ++ show mType)
+ _ -> 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 -< 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 (entityToXHTML 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
@@ -117,15 +114,19 @@ entityToXHTML env
-> 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
+ 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" }) ""]
- 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")
+ 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 "/"
@@ -149,12 +150,26 @@ entityToXHTML env
+= 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"
@@ -189,12 +204,103 @@ entityToXHTML env
)
)
)
+ >>>
+ 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 (PageName, Maybe XmlTree, PageName) XmlTree
+ -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
readSubPage env
= proc (mainPageName, mainPage, subPageName) ->
do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
@@ -203,6 +309,126 @@ readSubPage env
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
+
+
{-
-}
@@ -215,7 +441,7 @@ handlePageNotFound env
)
) -< name
returnA -< do setStatus NotFound
- outputXmlPage tree (notFoundToXHTML env)
+ outputXmlPage' tree (notFoundToXHTML env)
notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
@@ -224,15 +450,16 @@ notFoundToXHTML env
-> 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) -< (name, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
+ 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"
@@ -256,6 +483,11 @@ notFoundToXHTML env
+= 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"
@@ -290,12 +522,37 @@ notFoundToXHTML env
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< pageNotFound
handlePut :: Environment -> PageName -> Resource ()
handlePut env name
- = runXmlA env "rakka-page-1.0.rng" $ proc tree
- -> do page <- parseXmlizedPage -< (name, tree)
- status <- putPageA (envStorage env) -< page
- returnA -< setStatus status
+ = 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) ""
\ No newline at end of file