module Rakka.Resource.PageEntity
( fallbackPageEntity
)
where
import Control.Monad.Trans
import Data.Char
import qualified Data.Map as M
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
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
= 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
{-
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)) -< ()
javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
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 "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( getXPathTreesInDoc "/page/@lang"
`guards`
qattr (mkQName "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 ++ ";")
)
+= ( constL javaScripts
>>>
eelem "script"
+= sattr "type" "text/javascript"
+= attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
)
)
+= ( 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 (PageName, Maybe XmlTree, PageName) XmlTree
readSubPage env
= proc (mainPageName, mainPage, subPageName) ->
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
{-
-}
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" }) ""]
feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
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"
+= 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 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.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
)
+= ( constL javaScripts
>>>
eelem "script"
+= sattr "type" "text/javascript"
+= attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
)
)
+= ( 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" }) ""]
feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
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"
+= 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 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.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
)
+= ( constL javaScripts
>>>
eelem "script"
+= sattr "type" "text/javascript"
+= attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
)
)
+= ( 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 hpPageName $ srPages result)
findJavaScripts :: Storage -> IO [PageName]
findJavaScripts sto
= do cond <- newCondition
setPhrase cond "[UVSET]"
addAttrCond cond "@title STRBW Global/"
addAttrCond cond "@type STRBW text/javascript"
setOrder cond "@uri STRA"
result <- searchPages sto cond
return (map hpPageName $ srPages result)
mkFeedURIStr :: URI -> PageName -> String
mkFeedURIStr baseURI name
= uriToString id (mkFeedURI baseURI name) ""
mkObjectURIStr :: URI -> PageName -> String
mkObjectURIStr baseURI name
= uriToString id (mkObjectURI baseURI name) ""