X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;fp=Rakka%2FResource%2FPageEntity.hs;h=397f8d4dd5e04436a47638abfdd2c3a3606a3986;hp=c805ae5fe9af0ec4f44152c8a7e2278523ecb7a8;hb=HEAD;hpb=9932fbe6504e8b812703291e2497a5f010880d3b
diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index c805ae5..397f8d4 100644
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -1,16 +1,33 @@
+{-# 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
@@ -20,15 +37,19 @@ import Rakka.Utils
import Rakka.Wiki.Engine
import System.FilePath.Posix
import Text.HyperEstraier hiding (getText)
-import Text.XML.HXT.XPath
-
-
-fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
+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 name = return Nothing
- | isLower $ head name = 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 name
@@ -38,9 +59,8 @@ fallbackPageEntity env path
, resDelete = Just $ handleDelete env name
}
where
- name :: PageName
- name = (dropExtension . UTF8.decodeString . joinPath) path
-
+ name â· PageName
+ name = T.pack â dropExtension â UTF8.decodeString $ joinPath path
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
@@ -59,37 +79,36 @@ handleGet env name
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 "text" "xml" _
- -> do setContentType mType
- [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
- >>>
- constA redir
- >>>
- xmlizePage
- >>>
- writeDocumentToString [ (a_indent , v_1 )
- , (a_output_encoding, utf8)
- , (a_no_xml_pi , v_0 ) ]
- )
- output resultStr
-
- _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
- let uri = mkPageFragmentURI
- baseURI
- (redirDest redir)
- ("Redirect:" ++ redirName redir)
- redirect Found uri
-
+ â 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
@@ -100,222 +119,212 @@ handleGetEntity 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) -< ()
- 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 (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)
- )
- += 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 a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree 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) -< ()
+ â 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
+ 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 W3C.format
- >>>
- mkText
- )
- )
- += ( eelem "trackback:ping"
- += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
- )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- ) ) -<< 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 :: 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 â· (ArrowXml (â), ArrowChoice (â), ArrowIO (â))
+ â Environment
+ â (PageName, Maybe XmlTree, PageName) â XmlTree
readSubPage env
- = proc (mainPageName, mainPage, subPageName) ->
- do langM <- case mainPage of
+ = proc (mainPageName, mainPage, subPageName) â
+ do langM â case mainPage of
Nothing
- -> returnA -< Nothing
+ â returnA ⤠Nothing
Just p
- -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
- subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
- localSubPage <- case langM of
+ â maybeA (getXPathTreesInDoc "/page/@lang/text()" â getText) ⤠p
+ subPage â getPageA (envStorage env) â arr fromJust ⤠(subPageName, Nothing)
+ localSubPage â case langM of
Nothing
- -> returnA -< subPage
+ â 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
+ â 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 a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
+ 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
+ â 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
{-
@@ -324,251 +333,247 @@ readSubPage env
-}
-handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
+handleGetPageListing â· (ArrowXml (â), ArrowChoice (â), ArrowIO (â))
+ â Environment
+ â (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)
- )
+ â 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 a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+ )
+ )
+ ) ⤠(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) -< (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)
- )
- += 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 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
-
+ â 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) -< ()
- 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)
- )
- += 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 ()
+ â 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 a, ArrowXml a) => Environment -> a b XmlTree
+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 siteName <+> txt " - " <+> mkText)
- += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText) ) -<< feed
-
+ = 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
@@ -603,23 +608,18 @@ mkGlobalJSList env
| otherwise
-> none -< ()
-
-findJavaScripts :: Storage -> IO [PageName]
+findJavaScripts â· Storage â IO [PageName]
findJavaScripts sto
- = do cond <- newCondition
+ = 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
+ result â searchPages sto cond
return (map hpPageName $ srPages result)
+mkFeedURIStr â· URI â PageName â String
+mkFeedURIStr = flip flip "" â (uriToString id â) â mkFeedURI
-mkFeedURIStr :: URI -> PageName -> String
-mkFeedURIStr baseURI name
- = uriToString id (mkFeedURI baseURI name) ""
-
-
-mkObjectURIStr :: URI -> PageName -> String
-mkObjectURIStr baseURI name
- = uriToString id (mkObjectURI baseURI name) ""
+mkObjectURIStr â· URI â PageName â String
+mkObjectURIStr = flip flip "" â (uriToString id â) â mkObjectURI