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) ""