X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource%2FPage%2FGet.hs;h=30da9b97f9b9dbf626f049d4f595ff9d28e1cfd1;hp=322e9db9f06abaf287685b44a9a2b45c24604cb0;hb=885faf1cabc3f79c90e1885268e2a9138b1ddefb;hpb=03585f9c5773f6c0b59497f4f563909576c402b5

diff --git a/Rakka/Resource/Page/Get.hs b/Rakka/Resource/Page/Get.hs
index 322e9db..30da9b9 100644
--- a/Rakka/Resource/Page/Get.hs
+++ b/Rakka/Resource/Page/Get.hs
@@ -4,35 +4,56 @@ module Rakka.Resource.Page.Get
     where
 
 import           Control.Arrow
+import           Control.Arrow.ArrowIf
+import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
+import           Data.Encoding
+import           Data.Encoding.UTF8
 import           Network.HTTP.Lucu
 import           Network.URI
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource
 import           Rakka.Storage
+import           Rakka.SystemConfig
 import           Rakka.Utils
+import           System.Time
 import           Text.XML.HXT.Arrow.XmlArrow
+import           Text.XML.HXT.Arrow.XmlNodeSet
 import           Text.XML.HXT.DOM.TypeDefs
 
 
+handleGet :: Environment -> PageName -> Resource ()
+handleGet env name
+    = runIdempotentA $ proc ()
+    -> do pageM <- getPageA (envStorage env) -< name
+          case pageM of
+            Nothing
+                -> returnA -< foundNoEntity Nothing
+
+            Just redir@(Redirection _ _ _ _)
+                -> handleRedirect env -< redir
+
+            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
+                -> handleGetEntity env -< entity
+
 {-
-  [リダイレクトの場合]
   HTTP/1.1 302 Found
   Location: http://example.org/Destination?from=Source&revision=112
-
-  <page site="CieloNegro"
-        baseURI="http://example.org/"
-        name="Source"
-        redirect="Destination"
-        revision="112"         -- デフォルトでない場合のみ存在
-        lastModified="2000-01-01T00:00:00" />
+-}
+handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
+handleRedirect env
+    = proc redir
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+          returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
 
 
-  [text/* の場合]
+{-
+  [pageIsBinary が False の場合]
 
   <page site="CieloNegro"
         baseURI="http://example.org/"
+        styleSheet="StyleSheet/Default"
         name="Foo/Bar"
         type="text/x-rakka"
         isTheme="no"        -- text/css の場合のみ存在
@@ -45,7 +66,7 @@ import           Text.XML.HXT.DOM.TypeDefs
         blah blah...
     </summary> -- 存在しない場合もある
 
-    <otherLang>
+    <otherLang> -- 存在しない場合もある
       <link lang="ja" page="Bar/Baz" />
     </otherLang>
 
@@ -55,40 +76,144 @@ import           Text.XML.HXT.DOM.TypeDefs
   </page>
 
   
-  [text/* 以外の場合: content 要素の代はりに object 要素]
+  [pageIsBinary が True の場合: content 要素の代はりに object 要素]
   
   <object data="/object/Foo/Bar" /> -- data 屬性に URI
 -}
-handleGet :: Environment -> PageName -> Resource ()
-handleGet env name
-    = let sto = envStorage env
-      in 
-        runIdempotentA $ proc ()
-          -> do siteName <- getSiteNameA env -< ()
-                baseURI  <- getBaseURIA  env -< ()
-
-                pageM <- getPageA sto -< name
-                case pageM of
-                  Nothing
-                      -> returnA -< foundNoEntity Nothing
-
-                  Just redir@(Redirection _ _ _ _)
-                      -> do tree <- ( eelem "/"
-                                      += ( eelem "page"
-                                           += sattr "site"     siteName
-                                           += sattr "baseURI"  (uriToString id baseURI "")
-                                           += sattr "name"     name
-                                           += sattr "redirect" (redirDest redir)
-                                           += ( case redirRevision redir of
-                                                  Nothing  -> none
-                                                  Just rev -> sattr "revision" (show rev)
-                                              )
-                                           += sattr "lastModified" (formatW3CDateTime $ redirLastMod redir)
-                                         )
-                                    ) -<< ()
-                            returnA -< do redirect SeeOther (mkPageURI baseURI name)
-                                          outputXmlPage tree redirToXHTML
-
-
-redirToXHTML :: ArrowXml a => a XmlTree XmlTree
-redirToXHTML = error "not implemented"
\ No newline at end of file
+handleGetEntity :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
+handleGetEntity env
+    = let sysConf = envSysConf env
+      in
+        proc page
+          -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
+                BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
+                StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
+
+                tree <- ( eelem "/"
+                          += ( eelem "page"
+                               += sattr "site"       siteName
+                               += sattr "baseURI"    (uriToString id baseURI "")
+                               += sattr "styleSheet" cssName
+                               += sattr "name"       (pageName page)
+                               += sattr "type"       (show $ pageType page)
+                               += ( 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
+                                  )
+
+                               += ( case pageOtherLang page of
+                                      [] -> none
+                                      xs -> selem "otherLang"
+                                            [ eelem "link"
+                                              += sattr "lang" lang
+                                              += sattr "page" page
+                                                  | (lang, page) <- xs ]
+                                  )
+                                                  
+                               += ( case pageIsBinary page of
+                                      False -> eelem "content"
+                                               += txt (decodeLazy UTF8 $ pageContent page)
+
+                                      True  -> eelem "object"
+                                               += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
+                                  )
+                             )
+                        ) -<< ()
+
+                returnA -< do let lastMod = toClockTime $ pageLastMod page
+
+                              case pageRevision page of
+                                Nothing  -> foundTimeStamp lastMod
+                                Just rev -> foundEntity (strongETag $ show rev) lastMod
+
+                              outputXmlPage tree entityToXHTML
+
+
+entityToXHTML :: ArrowXml a => a XmlTree XmlTree
+entityToXHTML
+    = eelem "/"
+      += ( eelem "html"
+           += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+           += ( eelem "head"
+                += ( eelem "title"
+                     += getXPathTreesInDoc "/page/@site/text()"
+                     += txt " - "
+                     += getXPathTreesInDoc "/page/@name/text()"
+                   )
+                += ( eelem "base"
+                     += attr "href"
+                            ( getXPathTreesInDoc "/page/@baseURI/text()" )
+                   )
+                += ( eelem "link"
+                     += sattr "rel"  "stylesheet"
+                     += sattr "type" "text/css"
+                     += attr "href"
+                            ( txt "./object/"
+                              <+>
+                              getXPathTreesInDoc "/page/@styleSheet/text()"
+                              >>>
+                              getText
+                              >>>
+                              arr encodePageName
+                              >>>
+                              mkText
+                            )
+                   )
+              )
+           += ( eelem "body"
+                += ( eelem "div"
+                     += sattr "class" "header"
+                   )
+                += ( eelem "div"
+                     += sattr "class" "center"
+                     += ( eelem "div"
+                          += sattr "class" "title"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "body"
+                          += ( getXPathTreesInDoc "/page/content"
+                               `guards`
+                               getXPathTreesInDoc "/page/content/text()" -- FIXME
+                             )
+                          += ( getXPathTreesInDoc "/page/object"
+                               `guards`
+                               eelem "object"
+                               += attr "data"
+                                      ( getXPathTreesInDoc "/page/object/@data/text()" )
+                             )
+                        )
+                   )
+                += ( eelem "div"
+                     += sattr "class" "footer"
+                   )
+                += ( eelem "div"
+                     += sattr "class" "left side-bar"
+                     += ( eelem "div"
+                          += sattr "class" "content"
+                        )
+                   )
+                += ( eelem "div"
+                     += sattr "class" "right side-bar"
+                     += ( eelem "div"
+                          += sattr "class" "content"
+                        )
+                   )
+              )
+         )