+{-# LANGUAGE
+ Arrows
+ , OverloadedStrings
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Resource.PageEntity
( fallbackPageEntity
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowList
+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.HTTP.Lucu.Utils
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
-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
-
+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 ∷ Environment → [String] → IO (Maybe ResourceDef)
fallbackPageEntity env path
- | null path = return Nothing
- | null $ head path = return Nothing
- | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
+ | T.null name = return Nothing
+ | isLower $ T.head name = return Nothing -- 先頭の文字が小文字であってはならない
| otherwise
- = return $ Just $ ResourceDef {
+ = pure $ Just ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
- , resGet = Just $ handleGet env (toPageName path)
+ , resGet = Just $ handleGet env name
, resHead = Nothing
, resPost = Nothing
- , resPut = Just $ handlePut env (toPageName path)
- , resDelete = Nothing
+ , resPut = Just $ handlePut env name
+ , resDelete = Just $ handleDelete env name
}
where
- toPageName :: [String] -> PageName
- toPageName = decodePageName . dropExtension . joinWith "/"
-
+ name ∷ PageName
+ name = T.pack ∘ dropExtension ∘ UTF8.decodeString $ joinPath path
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
- = runIdempotentA $ proc ()
- -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
- case pageM of
- Nothing
- -> handlePageNotFound env -< name
-
- Just redir@(Redirection _ _ _ _ _)
- -> handleRedirect env -< redir
-
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
- -> handleGetEntity env -< entity
+ = 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 ∷ (ArrowXml (⇝), ArrowIO (⇝)) ⇒ Environment → 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)
-
+ → 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 -< 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)
+ returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
+ , (MIMEType "application" "rss+xml" [], entityToRSS env)
+ ]
- outputXmlPage tree (entityToXHTML env)
-
-entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+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) -< ()
-
- name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< 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 "" ++ "\";")
- )
- )
- += ( 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
- )
- )
- )
- ) ) -<< page
-
-
-readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a (PageName, Maybe XmlTree, PageName) XmlTree
+ → 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 subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
- subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
- -< (mainPageName, mainPage, subPage)
- returnA -< subXHTML
+ = 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
+{-
+ <pageListing path="Foo">
+ <page name="Foo/Bar" />
+ <page name="Foo/Baz" />
+ </pageListing>
+-}
+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
+
{-
<pageNotFound name="Foo/Bar" />
-}
-handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
+handlePageNotFound ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ Environment
+ → 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)
-
+ → do tree ← ( eelem "/"
+ += ( eelem "pageNotFound"
+ += attr "name" (arr T.unpack ⋙ mkText)
+ )
+ ) ⤙ name
+ returnA ⤙ do setStatus NotFound
+ outputXmlPage' tree (notFoundToXHTML env)
-notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+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) -< ()
-
- 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 "" ++ "\";")
- )
- )
- += ( 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
- )
- )
- )
- ) ) -<< pageNotFound
-
-
-handlePut :: Environment -> PageName -> Resource ()
+ → 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
- = 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 "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
projects / Rakka.git / blobdiff