)
where
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowList
+import qualified Codec.Binary.UTF8.String as UTF8
import Control.Monad.Trans
+import qualified Data.ByteString.Lazy as L hiding (ByteString)
import Data.Char
+import qualified Data.Map as M
import Data.Maybe
+import Data.Time
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
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.HyperEstraier hiding (getText)
+import Text.XML.HXT.Arrow
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.DOM.XmlKeywords
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
- = runIdempotentA $ proc ()
- -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
- case pageM of
- Nothing
- -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
- case items of
- [] -> handlePageNotFound env -< name
- _ -> handleGetPageListing env -< (name, items)
- Just page
- -> if isEntity page then
- handleGetEntity env -< page
- else
- handleRedirect env -< page
+ = 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
{-
= 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
)
output resultStr
- _ -> fail ("internal error: getEntityType returned " ++ show mType)
+ _ -> 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
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( getXPathTreesInDoc "/page/@lang"
`guards`
- qattr (QN "xml" "lang" "")
+ qattr (mkQName "xml" "lang" "")
( getXPathTreesInDoc "/page/@lang/text()" )
)
+= ( eelem "head"
+= sattr "type" "text/css"
+= attr "href" (arr id >>> mkText)
)
+ += mkFeedList env
+= ( constL scriptSrc
>>>
eelem "script"
+= txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
+= txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
)
+ += mkGlobalJSList env
)
+= ( eelem "body"
+= ( eelem "div"
) ) -<< page
+entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a 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 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 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 a, ArrowChoice a, ArrowIO a) =>
Environment
-> a (PageName, Maybe XmlTree, PageName) XmlTree
readSubPage env
= proc (mainPageName, mainPage, subPageName) ->
- do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
- subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
- -< (mainPageName, mainPage, subPage)
+ 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) -< (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 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
{-
)
)
) -< (dir, items)
- returnA -< outputXmlPage tree (pageListingToXHTML env)
+ returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+= sattr "type" "text/css"
+= attr "href" (arr id >>> mkText)
)
+ += mkFeedList env
+= ( constL scriptSrc
>>>
eelem "script"
+= txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+= txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
)
+ += mkGlobalJSList env
)
+= ( eelem "body"
+= ( eelem "div"
)
) -< name
returnA -< do setStatus NotFound
- outputXmlPage tree (notFoundToXHTML env)
+ outputXmlPage' tree (notFoundToXHTML env)
notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+= sattr "type" "text/css"
+= attr "href" (arr id >>> mkText)
)
+ += mkFeedList env
+= ( constL scriptSrc
>>>
eelem "script"
+= txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+= txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
)
+ += mkGlobalJSList env
)
+= ( eelem "body"
+= ( eelem "div"
= do userID <- getUserID env
status <- deletePage (envStorage env) userID name
setStatus status
+
+
+mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b 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
+
+
+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 baseURI name
+ = uriToString id (mkFeedURI baseURI name) ""
+
+
+mkObjectURIStr :: URI -> PageName -> String
+mkObjectURIStr baseURI name
+ = uriToString id (mkObjectURI baseURI name) ""
projects / Rakka.git / blobdiff