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