( fallbackPageEntity
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowList
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 qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
-import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
import Rakka.Environment
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
import Rakka.Wiki.Engine
-import System.FilePath
+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.XmlIOStateArrow
-import Text.XML.HXT.Arrow.XmlNodeSet
-import Text.XML.HXT.DOM.TypeDefs
-import Text.XML.HXT.DOM.XmlKeywords
+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 -- 先頭の文字が小文字であってはならない
+ | null name = return Nothing
+ | isLower $ head name = return Nothing -- 先頭の文字が小文字であってはならない
| otherwise
= return $ 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 = (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
- -> 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
{-
>>>
xmlizePage
>>>
- writeDocumentToString [ (a_indent, v_1) ]
+ writeDocumentToString [ (a_indent , v_1 )
+ , (a_output_encoding, utf8)
+ , (a_no_xml_pi , v_0 ) ]
)
output resultStr
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
-
- pageTitle <- listA (readSubPage env) -< (Just name, Just page, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right")
+ 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 "/"
+= sattr "type" "text/css"
+= attr "href" (arr id >>> mkText)
)
- += ( constL feeds
- >>>
- eelem "link"
- += sattr "rel" "alternate"
- += sattr "type" "application/rss+xml"
- += attr "title" (txt siteName <+> txt " - " <+> mkText)
- += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
- )
+ += mkFeedList env
+= ( constL scriptSrc
>>>
eelem "script"
+= txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
+= txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
)
+ += mkGlobalJSList env
)
+= ( eelem "body"
+= ( eelem "div"
+= ( eelem "dc:date"
+= ( arrIO (utcToLocalZonedTime . entityLastMod)
>>>
- arr formatW3CDateTime
+ arr W3C.format
>>>
mkText
)
readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
- -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
+ -> 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
{-
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
+ 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 "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"
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
+ 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 "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"
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
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) ""
\ No newline at end of file
+ = uriToString id (mkFeedURI baseURI name) ""
+
+
+mkObjectURIStr :: URI -> PageName -> String
+mkObjectURIStr baseURI name
+ = uriToString id (mkObjectURI baseURI name) ""
projects / Rakka.git / blobdiff