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           Control.Arrow.ArrowList
  10 import           Data.Char
  11 import qualified Data.Map as M
  12 import           Network.HTTP.Lucu
  13 import           Network.HTTP.Lucu.Utils
  14 import           Network.URI
  15 import           Rakka.Environment
  16 import           Rakka.Page
  17 import           Rakka.Resource
  18 import           Rakka.Storage
  19 import           Rakka.SystemConfig
  20 import           Rakka.Utils
  21 import           Rakka.Wiki.Engine
  22 import           System.FilePath
  23 import           System.Time
  24 import           Text.XML.HXT.Arrow.Namespace
  25 import           Text.XML.HXT.Arrow.XmlArrow
  26 import           Text.XML.HXT.Arrow.XmlNodeSet
  27 import           Text.XML.HXT.DOM.TypeDefs
  28
  29
  30 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
  31 fallbackRender env path
  32     | null path                        = return Nothing
  33     | null $ head path                 = return Nothing
  34     | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
  35     | otherwise
  36         = return $ Just $ ResourceDef {
  37             resUsesNativeThread = False
  38           , resIsGreedy         = True
  39           , resGet              = Just $ handleGet env (toPageName path)
  40           , resHead             = Nothing
  41           , resPost             = Nothing
  42           , resPut              = Nothing
  43           , resDelete           = Nothing
  44           }
  45     where
  46       toPageName :: [String] -> PageName
  47       toPageName = decodePageName . dropExtension . joinWith "/"
  48
  49
  50 handleGet :: Environment -> PageName -> Resource ()
  51 handleGet env name
  52     = runIdempotentA $ proc ()
  53     -> do pageM <- getPageA (envStorage env) -< name
  54           case pageM of
  55             Nothing
  56                 -> handlePageNotFound env -< name
  57
  58             Just redir@(Redirection _ _ _ _)
  59                 -> handleRedirect env -< redir
  60
  61             Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
  62                 -> handleGetEntity env -< entity
  63
  64 {-
  65   HTTP/1.1 302 Found
  66   Location: http://example.org/Destination?from=Source
  67 -}
  68 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  69 handleRedirect env
  70     = proc redir
  71     -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
  72           returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
  73
  74
  75 {-
  76   <page site="CieloNegro"
  77         styleSheet="http://example.org/object/StyleSheet/Default"
  78         name="Foo/Bar"
  79         type="text/x-rakka"
  80         lang="ja"           -- 存在しない場合もある
  81         isTheme="no"        -- text/css の場合のみ存在
  82         isFeed="no"         -- text/x-rakka の場合のみ存在
  83         isLocked="no"
  84         revision="112">     -- デフォルトでない場合のみ存在
  85         lastModified="2000-01-01T00:00:00">
  86
  87     <summary>
  88         blah blah...
  89     </summary> -- 存在しない場合もある
  90
  91     <otherLang> -- 存在しない場合もある
  92       <link lang="ja" page="Bar/Baz" />
  93     </otherLang>
  94
  95     <pageTitle>
  96       blah blah...
  97     </pageTitle>
  98
  99     <sideBar>
 100       <left>
 101         blah blah...
 102       </left>
 103       <right>
 104         blah blah...
 105       </right>
 106     </sideBar>
 107
 108     <body>
 109       blah blah...
 110     </body>
 111   </page>
 112 -}
 113 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 114 handleGetEntity env
 115     = proc page
 116     -> do SiteName   siteName <- getSysConfA sysConf -< ()
 117           BaseURI    baseURI  <- getSysConfA sysConf -< ()
 118           StyleSheet cssName  <- getSysConfA sysConf -< ()
 119
 120           Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
 121           Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
 122           Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
 123
 124           tree <- ( eelem "/"
 125                     += ( eelem "page"
 126                          += sattr "site"       siteName
 127                          += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
 128                          += sattr "name"       (pageName page)
 129                          += sattr "type"       (show $ pageType page)
 130                          += ( case pageLanguage page of
 131                                 Just x -> sattr "lang" x
 132                                 _      -> none
 133                             )
 134                          += ( case pageType page of
 135                                 MIMEType "text" "css" _
 136                                     -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
 137                                 _   -> none
 138                             )
 139                          += ( case pageType page of
 140                                 MIMEType "text" "x-rakka" _
 141                                     -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
 142                                 _   -> none
 143                             )
 144                          += sattr "isLocked" (yesOrNo $ pageIsLocked page)
 145                          += ( case pageRevision page of
 146                                 Nothing  -> none
 147                                 Just rev -> sattr "revision" (show rev)
 148                             )
 149                          += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
 150
 151                          += ( case pageSummary page of
 152                                 Nothing -> none
 153                                 Just s  -> eelem "summary" += txt s
 154                             )
 155
 156                          += ( if M.null (pageOtherLang page) then
 157                                   none
 158                               else
 159                                   selem "otherLang"
 160                                             [ eelem "link"
 161                                               += sattr "lang" lang
 162                                               += sattr "page" page
 163                                                   | (lang, page) <- M.toList (pageOtherLang page) ]
 164                             )
 165                          += ( eelem "pageTitle"
 166                               += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
 167                                    >>>
 168                                    formatSubPage env
 169                                  )
 170                             )
 171                          += ( eelem "sideBar"
 172                               += ( eelem "left"
 173                                    += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
 174                                         >>>
 175                                         formatSubPage env
 176                                       )
 177                                  )
 178                               += ( eelem "right"
 179                                    += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
 180                                         >>>
 181                                         formatSubPage env
 182                                       )
 183                                  )
 184                             )
 185                          += ( eelem "body"
 186                               += (constA page >>> formatPage env)
 187                             )
 188                          >>>
 189                          uniqueNamespacesFromDeclAndQNames
 190                        )
 191                   ) -<< ()
 192
 193           returnA -< do let lastMod = toClockTime $ pageLastMod page
 194
 195                         -- text/x-rakka の場合は、内容が動的に生成され
 196                         -- てゐる可能性があるので、ETag も
 197                         -- Last-Modified も返す事が出來ない。
 198                         case pageType page of
 199                           MIMEType "text" "x-rakka" _
 200                               -> return ()
 201                           _   -> case pageRevision page of
 202                                    Nothing  -> foundTimeStamp lastMod
 203                                    Just rev -> foundEntity (strongETag $ show rev) lastMod
 204
 205                         outputXmlPage tree entityToXHTML
 206     where
 207       sysConf :: SystemConfig
 208       sysConf = envSysConf env
 209
 210
 211 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
 212 entityToXHTML
 213     = eelem "/"
 214       += ( eelem "html"
 215            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 216            += ( getXPathTreesInDoc "/page/@lang"
 217                 `guards`
 218                 qattr (QN "xml" "lang" "")
 219                           ( getXPathTreesInDoc "/page/@lang/text()" )
 220               )
 221            += ( eelem "head"
 222                 += ( eelem "title"
 223                      += getXPathTreesInDoc "/page/@site/text()"
 224                      += txt " - "
 225                      += getXPathTreesInDoc "/page/@name/text()"
 226                    )
 227                 += ( eelem "link"
 228                      += sattr "rel"  "stylesheet"
 229                      += sattr "type" "text/css"
 230                      += attr "href"
 231                             ( getXPathTreesInDoc "/page/@styleSheet/text()" )
 232                    )
 233               )
 234            += ( eelem "body"
 235                 += ( eelem "div"
 236                      += sattr "class" "header"
 237                    )
 238                 += ( eelem "div"
 239                      += sattr "class" "center"
 240                      += ( eelem "div"
 241                           += sattr "class" "title"
 242                           += getXPathTreesInDoc "/page/pageTitle/*"
 243                         )
 244                      += ( eelem "div"
 245                           += sattr "class" "body"
 246                           += getXPathTreesInDoc "/page/body/*"
 247                         )
 248                    )
 249                 += ( eelem "div"
 250                      += sattr "class" "footer"
 251                    )
 252                 += ( eelem "div"
 253                      += sattr "class" "left sideBar"
 254                      += ( eelem "div"
 255                           += sattr "class" "content"
 256                           += getXPathTreesInDoc "/page/sideBar/left/*"
 257                         )
 258                    )
 259                 += ( eelem "div"
 260                      += sattr "class" "right sideBar"
 261                      += ( eelem "div"
 262                           += sattr "class" "content"
 263                           += getXPathTreesInDoc "/page/sideBar/right/*"
 264                         )
 265                    )
 266               )
 267            >>>
 268            uniqueNamespacesFromDeclAndQNames
 269          )
 270
 271
 272 {-
 273   <pageNotFound site="CieloNegro"
 274                 styleSheet="http://example.org/object/StyleSheet/Default"
 275                 name="Foo/Bar">
 276
 277     <pageTitle>
 278       blah blah...
 279     </pageTitle>
 280
 281     <sideBar>
 282       <left>
 283         blah blah...
 284       </left>
 285       <right>
 286         blah blah...
 287       </right>
 288     </sideBar>
 289   </pageNotFound>
 290 -}
 291 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 292 handlePageNotFound env
 293     = proc name
 294     -> do SiteName   siteName <- getSysConfA sysConf -< ()
 295           BaseURI    baseURI  <- getSysConfA sysConf -< ()
 296           StyleSheet cssName  <- getSysConfA sysConf -< ()
 297
 298           Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
 299           Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
 300           Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
 301
 302           tree <- ( eelem "/"
 303                     += ( eelem "pageNotFound"
 304                          += sattr "site"       siteName
 305                          += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
 306                          += sattr "name"       name
 307
 308                          += ( eelem "pageTitle"
 309                               += ( (constA name &&& constA Nothing &&& constA pageTitle)
 310                                    >>>
 311                                    formatSubPage env
 312                                  )
 313                             )
 314                          += ( eelem "sideBar"
 315                               += ( eelem "left"
 316                                    += ( (constA name &&& constA Nothing &&& constA leftSideBar)
 317                                         >>>
 318                                         formatSubPage env
 319                                       )
 320                                  )
 321                               += ( eelem "right"
 322                                    += ( (constA name &&& constA Nothing &&& constA rightSideBar)
 323                                         >>>
 324                                         formatSubPage env
 325                                       )
 326                                  )
 327                             )
 328                          >>>
 329                          uniqueNamespacesFromDeclAndQNames
 330                        )
 331                   ) -<< ()
 332
 333           returnA -< do setStatus NotFound
 334                         outputXmlPage tree notFoundToXHTML
 335     where
 336       sysConf :: SystemConfig
 337       sysConf = envSysConf env
 338
 339
 340 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
 341 notFoundToXHTML
 342     = eelem "/"
 343       += ( eelem "html"
 344            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 345            += ( eelem "head"
 346                 += ( eelem "title"
 347                      += getXPathTreesInDoc "/pageNotFound/@site/text()"
 348                      += txt " - "
 349                      += getXPathTreesInDoc "/pageNotFound/@name/text()"
 350                    )
 351                 += ( eelem "link"
 352                      += sattr "rel"  "stylesheet"
 353                      += sattr "type" "text/css"
 354                      += attr "href"
 355                             ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
 356                    )
 357               )
 358            += ( eelem "body"
 359                 += ( eelem "div"
 360                      += sattr "class" "header"
 361                    )
 362                 += ( eelem "div"
 363                      += sattr "class" "center"
 364                      += ( eelem "div"
 365                           += sattr "class" "title"
 366                           += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
 367                         )
 368                      += ( eelem "div"
 369                           += sattr "class" "body"
 370                           += txt "404 Not Found (FIXME)" -- FIXME
 371                         )
 372                    )
 373                 += ( eelem "div"
 374                      += sattr "class" "footer"
 375                    )
 376                 += ( eelem "div"
 377                      += sattr "class" "left sideBar"
 378                      += ( eelem "div"
 379                           += sattr "class" "content"
 380                           += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
 381                         )
 382                    )
 383                 += ( eelem "div"
 384                      += sattr "class" "right sideBar"
 385                      += ( eelem "div"
 386                           += sattr "class" "content"
 387                           += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
 388                         )
 389                    )
 390               )
 391            >>>
 392            uniqueNamespacesFromDeclAndQNames
 393          )