Rakka/Resource/Render.hs

   1 module Rakka.Resource.Render
   2     ( fallbackRender
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowIO
   8 import           Control.Arrow.ArrowIf
   9 import           Data.Char
  10 import           Network.HTTP.Lucu
  11 import           Network.HTTP.Lucu.Utils
  12 import           Rakka.Environment
  13 import           Rakka.Page
  14 import           Rakka.Resource
  15 import           Rakka.Storage
  16 import           Rakka.SystemConfig
  17 import           Rakka.Wiki.Engine
  18 import           System.FilePath
  19 import           System.Time
  20 import           Text.XML.HXT.Arrow.Namespace
  21 import           Text.XML.HXT.Arrow.XmlArrow
  22 import           Text.XML.HXT.Arrow.XmlNodeSet
  23 import           Text.XML.HXT.DOM.TypeDefs
  24
  25
  26 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
  27 fallbackRender env path
  28     | null path                  = return Nothing
  29     | null $ head path           = return Nothing
  30     | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
  31     | otherwise
  32         = return $ Just $ ResourceDef {
  33             resUsesNativeThread = False
  34           , resIsGreedy         = True
  35           , resGet              = Just $ handleGet env (toPageName path)
  36           , resHead             = Nothing
  37           , resPost             = Nothing
  38           , resPut              = Nothing
  39           , resDelete           = Nothing
  40           }
  41     where
  42       toPageName :: [String] -> PageName
  43       toPageName = decodePageName . dropExtension . joinWith "/"
  44
  45
  46 handleGet :: Environment -> PageName -> Resource ()
  47 handleGet env name
  48     = runIdempotentA $ proc ()
  49     -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
  50           case pageM of
  51             Nothing
  52                 -> handlePageNotFound env -< name
  53
  54             Just redir@(Redirection _ _ _ _)
  55                 -> handleRedirect env -< redir
  56
  57             Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
  58                 -> handleGetEntity env -< entity
  59
  60 {-
  61   HTTP/1.1 302 Found
  62   Location: http://example.org/Destination?from=Source
  63 -}
  64 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  65 handleRedirect env
  66     = proc redir
  67     -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
  68           returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
  69
  70
  71 {-
  72   <page site="CieloNegro"
  73         baseURI="http://example.org"
  74         name="Foo/Bar"
  75         type="text/x-rakka"
  76         lang="ja"            -- 存在しない場合もある
  77         fileName="bar.rakka" -- 存在しない場合もある
  78         isTheme="no"         -- text/css の場合のみ存在
  79         isFeed="no"          -- text/x-rakka の場合のみ存在
  80         isLocked="no"
  81         isBinary="no"
  82         revision="112">      -- デフォルトでない場合のみ存在
  83         lastModified="2000-01-01T00:00:00">
  84
  85     <styleSheets>
  86       <styleSheet src="http://example.org/object/StyleSheet/Default" />
  87     </styleSheets>
  88
  89     <scripts>
  90       <script src="http://example.org/js" />
  91     </scripts>
  92
  93     <summary>
  94         blah blah...
  95     </summary> -- 存在しない場合もある
  96
  97     <otherLang> -- 存在しない場合もある
  98       <link lang="ja" page="Bar/Baz" />
  99     </otherLang>
 100
 101     <pageTitle>
 102       blah blah...
 103     </pageTitle>
 104
 105     <sideBar>
 106       <left>
 107         blah blah...
 108       </left>
 109       <right>
 110         blah blah...
 111       </right>
 112     </sideBar>
 113
 114     <body>
 115       blah blah...
 116     </body>
 117
 118     <source><!-- isBinary="no" の場合にのみ存在 -->
 119       blah blah...
 120     </source>
 121   </page>
 122 -}
 123 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 124 handleGetEntity env
 125     = proc page
 126     -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
 127           returnA -< do let lastMod = toClockTime $ pageLastMod page
 128
 129                         -- text/x-rakka の場合は、内容が動的に生成され
 130                         -- てゐる可能性があるので、ETag も
 131                         -- Last-Modified も返す事が出來ない。
 132                         case pageType page of
 133                           MIMEType "text" "x-rakka" _
 134                               -> return ()
 135                           _   -> case pageRevision page of
 136                                    0   -> foundTimeStamp lastMod -- 0 はデフォルトページ
 137                                    rev -> foundEntity (strongETag $ show rev) lastMod
 138
 139                         outputXmlPage tree entityToXHTML
 140
 141
 142 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
 143 entityToXHTML
 144     = eelem "/"
 145       += ( eelem "html"
 146            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 147            += ( getXPathTreesInDoc "/page/@lang"
 148                 `guards`
 149                 qattr (QN "xml" "lang" "")
 150                           ( getXPathTreesInDoc "/page/@lang/text()" )
 151               )
 152            += ( eelem "head"
 153                 += ( eelem "title"
 154                      += getXPathTreesInDoc "/page/@site/text()"
 155                      += txt " - "
 156                      += getXPathTreesInDoc "/page/@name/text()"
 157                    )
 158                 += ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
 159                      >>>
 160                      eelem "link"
 161                      += sattr "rel"  "stylesheet"
 162                      += sattr "type" "text/css"
 163                      += attr "href"
 164                             ( getXPathTrees "/styleSheet/@src/text()" )
 165                    )
 166                 += ( getXPathTreesInDoc "/page/scripts/script"
 167                      >>>
 168                      eelem "script"
 169                      += sattr "type" "text/javascript"
 170                      += attr "src"
 171                             ( getXPathTrees "/script/@src/text()" )
 172                    )
 173               )
 174            += ( eelem "body"
 175                 += ( eelem "div"
 176                      += sattr "class" "header"
 177                    )
 178                 += ( eelem "div"
 179                      += sattr "class" "center"
 180                      += ( eelem "div"
 181                           += sattr "class" "title"
 182                           += getXPathTreesInDoc "/page/pageTitle/*"
 183                         )
 184                      += ( eelem "div"
 185                           += sattr "class" "body"
 186                           += getXPathTreesInDoc "/page/body/*"
 187                         )
 188                    )
 189                 += ( eelem "div"
 190                      += sattr "class" "footer"
 191                    )
 192                 += ( eelem "div"
 193                      += sattr "class" "left sideBar"
 194                      += ( eelem "div"
 195                           += sattr "class" "content"
 196                           += getXPathTreesInDoc "/page/sideBar/left/*"
 197                         )
 198                    )
 199                 += ( eelem "div"
 200                      += sattr "class" "right sideBar"
 201                      += ( eelem "div"
 202                           += sattr "class" "content"
 203                           += getXPathTreesInDoc "/page/sideBar/right/*"
 204                         )
 205                    )
 206               )
 207            >>>
 208            uniqueNamespacesFromDeclAndQNames
 209          )
 210
 211
 212 {-
 213   <pageNotFound site="CieloNegro"
 214                 baseURI="http://example.org"
 215                 name="Foo/Bar">
 216
 217     <styleSheets>
 218       <styleSheet src="http://example.org/object/StyleSheet/Default" />
 219     </styleSheets>
 220
 221     <scripts>
 222       <script src="http://example.org/js" />
 223     </scripts>
 224
 225     <pageTitle>
 226       blah blah...
 227     </pageTitle>
 228
 229     <sideBar>
 230       <left>
 231         blah blah...
 232       </left>
 233       <right>
 234         blah blah...
 235       </right>
 236     </sideBar>
 237   </pageNotFound>
 238 -}
 239 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 240 handlePageNotFound env
 241     = proc name
 242     -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
 243           returnA -< do setStatus NotFound
 244                         outputXmlPage tree notFoundToXHTML
 245
 246
 247 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
 248 notFoundToXHTML
 249     = eelem "/"
 250       += ( eelem "html"
 251            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 252            += ( eelem "head"
 253                 += ( eelem "title"
 254                      += getXPathTreesInDoc "/pageNotFound/@site/text()"
 255                      += txt " - "
 256                      += getXPathTreesInDoc "/pageNotFound/@name/text()"
 257                    )
 258                 += ( getXPathTreesInDoc "/pageNotFound/styleSheets/styleSheet"
 259                      >>>
 260                      eelem "link"
 261                      += sattr "rel"  "stylesheet"
 262                      += sattr "type" "text/css"
 263                      += attr "href"
 264                             ( getXPathTrees "/styleSheet/@src/text()" )
 265                    )
 266                 += ( getXPathTreesInDoc "/pageNotFound/scripts/script"
 267                      >>>
 268                      eelem "script"
 269                      += sattr "type" "text/javascript"
 270                      += attr "src"
 271                             ( getXPathTrees "/script/@src/text()" )
 272                    )
 273               )
 274            += ( eelem "body"
 275                 += ( eelem "div"
 276                      += sattr "class" "header"
 277                    )
 278                 += ( eelem "div"
 279                      += sattr "class" "center"
 280                      += ( eelem "div"
 281                           += sattr "class" "title"
 282                           += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
 283                         )
 284                      += ( eelem "div"
 285                           += sattr "class" "body"
 286                           += txt "404 Not Found (FIXME)" -- FIXME
 287                         )
 288                    )
 289                 += ( eelem "div"
 290                      += sattr "class" "footer"
 291                    )
 292                 += ( eelem "div"
 293                      += sattr "class" "left sideBar"
 294                      += ( eelem "div"
 295                           += sattr "class" "content"
 296                           += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
 297                         )
 298                    )
 299                 += ( eelem "div"
 300                      += sattr "class" "right sideBar"
 301                      += ( eelem "div"
 302                           += sattr "class" "content"
 303                           += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
 304                         )
 305                    )
 306               )
 307            >>>
 308            uniqueNamespacesFromDeclAndQNames
 309          )