X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=1388f71cc78024f144b7ad44f9a6dcdfc7b6f250;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=8f63bbaad3b9c6f68748530ccc261cd68c0bb5d2;hpb=443af4d3304139bb2187a0c726327b9c05829810;p=Rakka.git
diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 8f63bba..1388f71 100644
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -1,320 +1,633 @@
+{-# 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 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.W3CDateTime
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)
+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
- | 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 = Just $ handleDelete env (toPageName path)
+ , 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 page -> if isEntity page then
- handleGetEntity env -< page
- else
- handleRedirect env -< page
-
+ = 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)
-
- outputXmlPage tree (entityToXHTML env)
+ 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 â· (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
- )
- )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- ) ) -<< 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/"
+ += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
+ += ( 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 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 (â), 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
+
+{-
+
+
+
+
+-}
+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 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)
-
-
-notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+ â 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) -< ()
-
- 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
- )
- )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- ) ) -<< 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
- = 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
+ = 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 â· Environment â PageName â Resource ()
handleDelete env name
- = do userID <- getUserID env
- status <- deletePage (envStorage env) userID 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