Wrote many

[Rakka.git] / Rakka / Wiki / Engine.hs

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 8d5c8eecc0fa87ffbf53812a8916aece7cb1fa72..07eaff4a594ed5c5ff112f1550997e533bffe6df 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -46,20 +46,24 @@ formatEntirePage sto sysConf interpTable
           BaseURI    baseURI  <- getSysConfA sysConf -< ()
           StyleSheet cssName  <- getSysConfA sysConf -< ()
 
-          Just pageTitle    <- getPageA sto -< "PageTitle"
-          Just leftSideBar  <- getPageA sto -< "SideBar/Left"
-          Just rightSideBar <- getPageA sto -< "SideBar/Right"
+          Just pageTitle    <- getPageA sto -< ("PageTitle"    , Nothing)
+          Just leftSideBar  <- getPageA sto -< ("SideBar/Left" , Nothing)
+          Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
 
           tree <- ( eelem "/"
                     += ( eelem "page"
                          += sattr "site"       siteName
-                         += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+                         += sattr "baseURI"    (uriToString id baseURI "")
                          += sattr "name"       (pageName page)
                          += sattr "type"       (show $ pageType page)
                          += ( case pageLanguage page of
                                 Just x -> sattr "lang" x
                                 _      -> none
                             )
+                         += ( case pageFileName page of
+                                Just x -> sattr "fileName" x
+                                _      -> none
+                            )
                          += ( case pageType page of
                                 MIMEType "text" "css" _
                                     -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
@@ -76,6 +80,18 @@ formatEntirePage sto sysConf interpTable
                          += sattr "revision" (show $ pageRevision page)
                          += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
 
+                         += ( eelem "styleSheets"
+                              += ( eelem "styleSheet"
+                                   += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
+                                 )
+                            )
+
+                         += ( eelem "scripts"
+                              += ( eelem "script"
+                                   += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
+                                 )
+                            )
+
                          += ( case pageSummary page of
                                 Nothing -> none
                                 Just s  -> eelem "summary" += txt s
@@ -113,6 +129,7 @@ formatEntirePage sto sysConf interpTable
                          += ( eelem "body"
                               += (constA page >>> formatMainPage sto sysConf interpTable)
                             )
+                         += (constA page >>> formatSource)
                          >>>
                          uniqueNamespacesFromDeclAndQNames
                        )
@@ -120,6 +137,16 @@ formatEntirePage sto sysConf interpTable
           returnA -< tree
 
 
+formatSource :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
+formatSource = proc page
+             -> if pageIsBinary page then
+                    none -< ()
+                else
+                    let source = decodeLazy UTF8 (pageContent page)
+                    in
+                      ( eelem "source" += mkText ) -< source
+
+
 formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                         Storage
                      -> SystemConfig
@@ -131,15 +158,27 @@ formatUnexistentPage sto sysConf interpTable
           BaseURI    baseURI  <- getSysConfA sysConf -< ()
           StyleSheet cssName  <- getSysConfA sysConf -< ()
 
-          Just pageTitle    <- getPageA sto -< "PageTitle"
-          Just leftSideBar  <- getPageA sto -< "SideBar/Left"
-          Just rightSideBar <- getPageA sto -< "SideBar/Right"
+          Just pageTitle    <- getPageA sto -< ("PageTitle"    , Nothing)
+          Just leftSideBar  <- getPageA sto -< ("SideBar/Left" , Nothing)
+          Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
 
           tree <- ( eelem "/"
                     += ( eelem "pageNotFound"
-                         += sattr "site"       siteName
-                         += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
-                         += sattr "name"       name
+                         += sattr "site"    siteName
+                         += sattr "baseURI" (uriToString id baseURI "")
+                         += sattr "name"    name
+
+                         += ( eelem "styleSheets"
+                              += ( eelem "styleSheet"
+                                   += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
+                                 )
+                            )
+
+                         += ( eelem "scripts"
+                              += ( eelem "script"
+                                   += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
+                                 )
+                            )
                          
                          += ( eelem "pageTitle"
                               += ( (constA name &&& constA Nothing &&& constA pageTitle)
@@ -212,6 +251,18 @@ wikifyPage interpTable page
                  case parse parser "" source of
                    Left err -> wikifyParseError err
                    Right xs -> xs
+
+        MIMEType "image" _ _
+            -> [ Paragraph [ Image (pageName page) Nothing ] ]
+
+        _   -> if pageIsBinary page then
+                   -- object へのリンクのみ
+                   [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ]
+               else
+                   -- pre
+                   let text = decodeLazy UTF8 (pageContent page)
+                   in
+                     [ Preformatted [ Text text ] ]
     where
       tableToFunc :: String -> Maybe CommandType
       tableToFunc name
@@ -288,10 +339,14 @@ makeDraft interpTable page
          setAttribute doc "@lang"          $ pageLanguage page
          setAttribute doc "@type"          $ Just $ show $ pageType page
          setAttribute doc "@mdate"         $ Just $ formatW3CDateTime $ pageLastMod page
+         setAttribute doc "rakka:fileName" $ pageFileName page
          setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page
          setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page
          setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page
          setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page
+         setAttribute doc "rakka:summary"  $ pageSummary page
+
+         addHiddenText doc (pageName page)
 
          case pageType page of
             MIMEType "text" "css" _
@@ -328,6 +383,11 @@ makeDraft interpTable page
           = do case i of
                  Text text
                      -> addText doc text
+                 ObjectLink page Nothing
+                     -> addText doc page
+                 ObjectLink page (Just text)
+                     -> do addHiddenText doc page
+                           addText doc text
                  PageLink page fragment Nothing
                      -> addText doc (fromMaybe "" page ++
                                      fromMaybe "" fragment)
@@ -352,4 +412,4 @@ everywhereM' f x = f x >>= gmapM (everywhereM' f)
 wikifyParseError :: ParseError -> WikiPage
 wikifyParseError err
     = [Div [("class", "error")]
-               [ Preformatted [Text (show err)] ]]
+               [ Block (Preformatted [Text (show err)]) ]]