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 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.Wiki.Engine
import System.FilePath
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 "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
>>>
constA redir
>>>
xmlizePage
>>>
writeDocumentToString [ (a_indent, v_1) ]
)
output resultStr
_ -> fail ("internal error: getEntityType returned " ++ show mType)
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)
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" }) ""]
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 (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 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
readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
-> 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)
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)
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) -< (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 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) -< (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 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