{-# LANGUAGE
Arrows
, OverloadedStrings
, TypeOperators
, UnicodeSyntax
#-}
module Rakka.Resource.PageEntity
( fallbackPageEntity
)
where
import Control.Applicative
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
import Control.Arrow.Unicode
import qualified Codec.Binary.UTF8.String as UTF8
import Control.Monad.Trans
import qualified Data.ByteString.Lazy as L hiding (ByteString)
import qualified Data.CaseInsensitive as CI
import Data.Char
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Text as T
import Data.Time
import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.URI hiding (path)
import Prelude.Unicode
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.Posix
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.XmlState
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.XPath
fallbackPageEntity ∷ Environment → [String] → IO (Maybe ResourceDef)
fallbackPageEntity env path
| T.null name = return Nothing
| isLower $ T.head name = return Nothing -- 先頭の文字が小文字であってはならない
| otherwise
= pure $ Just ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
, resGet = Just $ handleGet env name
, resHead = Nothing
, resPost = Nothing
, resPut = Just $ handlePut env name
, resDelete = Just $ handleDelete env name
}
where
name ∷ PageName
name = T.pack ∘ dropExtension ∘ UTF8.decodeString $ joinPath path
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 (⇝), ArrowIO (⇝)) ⇒ Environment → 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
[ withIndent yes
, withXmlPi yes
]
)
output $ UTF8.encodeString 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 (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ 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) ⤙ (T.pack name, Just page, "PageTitle")
leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Left")
rightSideBar ← listA (readSubPage env) ⤙ (T.pack 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 (T.unpack siteName)
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
+= ( constL cssHref
⋙
eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href" (arr id ⋙ mkText)
)
+= mkFeedList env
+= ( 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 ⊕ ";" )
)
+= mkGlobalJSList env
)
+= ( 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 (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ 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/"
+= ( eelem "channel"
+= sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "")
+= ( eelem "title"
+= txt (T.unpack siteName)
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
+= ( eelem "link"
+= txt (uriToString id baseURI "")
)
+= ( eelem "description"
+= txt (case summary of
Nothing → "RSS Feed for " ⊕ T.unpack 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 (T.unpack ∘ 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 W3C.format
⋙
mkText
)
)
)
⋙
uniqueNamespacesFromDeclAndQNames
) ) ⤛ page
where
mkPageURIStr :: URI → PageName → String
mkPageURIStr baseURI name
= uriToString id (mkPageURI baseURI name) ""
readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ (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) ⤙ (CI.mk $ T.pack l, subPage)
subPageXml ← xmlizePage ⤙ localSubPage
subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
⤙ (Just mainPageName, mainPage, subPageXml)
returnA ⤙ subXHTML
where
localize ∷ (ArrowChoice (⇝), ArrowIO (⇝)) ⇒ Storage → (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 (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ (PageName, [PageName]) ⇝ Resource ()
handleGetPageListing env
= proc (dir, items)
→ do tree ← ( eelem "/"
+= ( eelem "pageListing"
+= attr "path" (arr (T.unpack ∘ fst) ⋙ mkText)
+= ( arrL snd
⋙
( eelem "page"
+= attr "name" (arr (T.unpack ∘ id) ⋙ mkText)
)
)
)
) ⤙ (dir, items)
returnA ⤙ outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
pageListingToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ 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) ⤙ (T.pack name, Nothing, "PageTitle")
leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left")
rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
+= txt (T.unpack siteName)
+= txt " - "
+= getXPathTreesInDoc "/pageListing/@path/text()"
)
+= ( constL cssHref
⋙
eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href" (arr id ⋙ mkText)
)
+= mkFeedList env
+= ( 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 ++ ";")
)
+= mkGlobalJSList env
)
+= ( 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 (T.pack 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 (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ PageName ⇝ Resource ()
handlePageNotFound env
= proc name
→ do tree ← ( eelem "/"
+= ( eelem "pageNotFound"
+= attr "name" (arr T.unpack ⋙ mkText)
)
) ⤙ name
returnA ⤙ do setStatus NotFound
outputXmlPage' tree (notFoundToXHTML env)
notFoundToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ 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) ⤙ (T.pack name, Nothing, "PageTitle" )
leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left" )
rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
+= txt (T.unpack siteName)
+= txt " - "
+= getXPathTreesInDoc "/pageNotFound/@name/text()"
)
+= ( constL cssHref
⋙
eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href" (arr id ⋙ mkText)
)
+= mkFeedList env
+= ( 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 ++ ";")
)
+= mkGlobalJSList env
)
+= ( 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 "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
mkFeedList ∷ (ArrowIO (⇝), ArrowXml (⇝)) ⇒ Environment → β ⇝ XmlTree
mkFeedList env
= proc _
→ do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
feed ← unlistA ⋘ arrIO0 (findFeeds $ envStorage env) ⤙ ()
( eelem "link"
+= sattr "rel" "alternate"
+= sattr "type" "application/rss+xml"
+= attr "title" (txt (T.unpack siteName) <+> txt " - " <+> (arr T.unpack ⋙ mkText))
+= attr "href" (arr (mkFeedURIStr baseURI) ⋙ mkText) ) ⤛ feed
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)
mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree
mkGlobalJSList env
= proc _ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< ()
pageM <- getPageA (envStorage env) -< (scriptName, Nothing)
case pageM of
Nothing -> none -< ()
Just page
| isEntity page
-> ( if entityIsBinary page then
( eelem "script"
+= sattr "type" "text/javascript"
+= attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) )
else
( eelem "script"
+= sattr "type" "text/javascript"
+= (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) )
) -<< page
| otherwise
-> none -< ()
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 = flip flip "" ∘ (uriToString id ∘) ∘ mkFeedURI
mkObjectURIStr ∷ URI → PageName → String
mkObjectURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkObjectURI