import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowList
import Data.Char
-import qualified Data.Map as M
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
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 System.Time
fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
fallbackRender env path
- | null path = return Nothing
- | null $ head path = return Nothing
- | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
+ | null path = return Nothing
+ | null $ head path = return Nothing
+ | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
| otherwise
= return $ Just $ ResourceDef {
resUsesNativeThread = False
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
= runIdempotentA $ proc ()
- -> do pageM <- getPageA (envStorage env) -< name
+ -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
case pageM of
Nothing
-> handlePageNotFound env -< name
Just redir@(Redirection _ _ _ _)
-> handleRedirect env -< redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env -< entity
{-
{-
<page site="CieloNegro"
- styleSheet="http://example.org/object/StyleSheet/Default"
name="Foo/Bar"
type="text/x-rakka"
- lang="ja" -- 存在しない場合もある
- isTheme="no" -- text/css の場合のみ存在
- isFeed="no" -- text/x-rakka の場合のみ存在
+ lang="ja" -- 存在しない場合もある
+ fileName="bar.rakka" -- 存在しない場合もある
+ isTheme="no" -- text/css の場合のみ存在
+ isFeed="no" -- text/x-rakka の場合のみ存在
isLocked="no"
- revision="112"> -- デフォルトでない場合のみ存在
+ isBinary="no"
+ revision="112"> -- デフォルトでない場合のみ存在
lastModified="2000-01-01T00:00:00">
+ <styleSheets>
+ <styleSheet src="http://example.org/object/StyleSheet/Default" />
+ </styleSheets>
+
+ <scripts>
+ <script src="http://example.org/js" />
+ </scripts>
+
<summary>
blah blah...
</summary> -- 存在しない場合もある
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
= proc page
- -> do SiteName siteName <- getSysConfA sysConf -< ()
- BaseURI baseURI <- getSysConfA sysConf -< ()
- StyleSheet cssName <- getSysConfA sysConf -< ()
-
- Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
- Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
- Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
-
- tree <- ( eelem "/"
- += ( eelem "page"
- += sattr "site" siteName
- += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
- += sattr "name" (pageName page)
- += sattr "type" (show $ pageType page)
- += ( case pageLanguage page of
- Just x -> sattr "lang" x
- _ -> none
- )
- += ( case pageType page of
- MIMEType "text" "css" _
- -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
- _ -> none
- )
- += ( case pageType page of
- MIMEType "text" "x-rakka" _
- -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
- _ -> none
- )
- += sattr "isLocked" (yesOrNo $ pageIsLocked page)
- += ( case pageRevision page of
- Nothing -> none
- Just rev -> sattr "revision" (show rev)
- )
- += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
-
- += ( case pageSummary page of
- Nothing -> none
- Just s -> eelem "summary" += txt s
- )
-
- += ( if M.null (pageOtherLang page) then
- none
- else
- selem "otherLang"
- [ eelem "link"
- += sattr "lang" lang
- += sattr "page" page
- | (lang, page) <- M.toList (pageOtherLang page) ]
- )
- += ( eelem "pageTitle"
- += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "sideBar"
- += ( eelem "left"
- += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "right"
- += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
- >>>
- formatSubPage env
- )
- )
- )
- += ( eelem "body"
- += (constA page >>> formatPage env)
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )
- ) -<< ()
-
+ -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
returnA -< do let lastMod = toClockTime $ pageLastMod page
-- text/x-rakka の場合は、内容が動的に生成され
MIMEType "text" "x-rakka" _
-> return ()
_ -> case pageRevision page of
- Nothing -> foundTimeStamp lastMod
- Just rev -> foundEntity (strongETag $ show rev) lastMod
+ 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) lastMod
outputXmlPage tree entityToXHTML
- where
- sysConf :: SystemConfig
- sysConf = envSysConf env
entityToXHTML :: ArrowXml a => a XmlTree XmlTree
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
- += ( eelem "link"
+ += ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
+ >>>
+ eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
- ( getXPathTreesInDoc "/page/@styleSheet/text()" )
+ ( getXPathTrees "/styleSheet/@src/text()" )
+ )
+ += ( getXPathTreesInDoc "/page/scripts/script"
+ >>>
+ eelem "script"
+ += sattr "type" "text/javascript"
+ += attr "src"
+ ( getXPathTrees "/script/@src/text()" )
)
)
+= ( eelem "body"
handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
handlePageNotFound env
= proc name
- -> do SiteName siteName <- getSysConfA sysConf -< ()
- BaseURI baseURI <- getSysConfA sysConf -< ()
- StyleSheet cssName <- getSysConfA sysConf -< ()
-
- Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
- Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
- Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
-
- tree <- ( eelem "/"
- += ( eelem "pageNotFound"
- += sattr "site" siteName
- += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
- += sattr "name" name
-
- += ( eelem "pageTitle"
- += ( (constA name &&& constA Nothing &&& constA pageTitle)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "sideBar"
- += ( eelem "left"
- += ( (constA name &&& constA Nothing &&& constA leftSideBar)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "right"
- += ( (constA name &&& constA Nothing &&& constA rightSideBar)
- >>>
- formatSubPage env
- )
- )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )
- ) -<< ()
-
+ -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
returnA -< do setStatus NotFound
outputXmlPage tree notFoundToXHTML
- where
- sysConf :: SystemConfig
- sysConf = envSysConf env
notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
projects / Rakka.git / blobdiff