Rakka/Resource/PageEntity.hs

   1 module Rakka.Resource.PageEntity
   2     ( fallbackPageEntity
   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           Control.Monad.Trans
  11 import           Data.Char
  12 import           Data.Maybe
  13 import           Data.Time
  14 import           Network.HTTP.Lucu
  15 import           Network.HTTP.Lucu.Utils
  16 import           Network.URI hiding (path)
  17 import           Rakka.Environment
  18 import           Rakka.Page
  19 import           Rakka.Resource
  20 import           Rakka.Storage
  21 import           Rakka.SystemConfig
  22 import           Rakka.Utils
  23 import           Rakka.W3CDateTime
  24 import           Rakka.Wiki.Engine
  25 import           System.FilePath
  26 import           Text.HyperEstraier hiding (getText)
  27 import           Text.XML.HXT.Arrow.Namespace
  28 import           Text.XML.HXT.Arrow.WriteDocument
  29 import           Text.XML.HXT.Arrow.XmlArrow
  30 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  31 import           Text.XML.HXT.Arrow.XmlNodeSet
  32 import           Text.XML.HXT.DOM.TypeDefs
  33 import           Text.XML.HXT.DOM.XmlKeywords
  34
  35
  36 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
  37 fallbackPageEntity env path
  38     | null path                  = return Nothing
  39     | null $ head path           = return Nothing
  40     | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
  41     | otherwise
  42         = return $ Just $ ResourceDef {
  43             resUsesNativeThread = False
  44           , resIsGreedy         = True
  45           , resGet              = Just $ handleGet    env (toPageName path)
  46           , resHead             = Nothing
  47           , resPost             = Nothing
  48           , resPut              = Just $ handlePut    env (toPageName path)
  49           , resDelete           = Just $ handleDelete env (toPageName path)
  50           }
  51     where
  52       toPageName :: [String] -> PageName
  53       toPageName = decodePageName . dropExtension . joinWith "/"
  54
  55
  56 handleGet :: Environment -> PageName -> Resource ()
  57 handleGet env name
  58     = runIdempotentA $ proc ()
  59     -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
  60           case pageM of
  61             Nothing
  62                 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
  63                       case items of
  64                         [] -> handlePageNotFound   env -< name
  65                         _  -> handleGetPageListing env -< (name, items)
  66             Just page
  67                 -> if isEntity page then
  68                        handleGetEntity env -< page
  69                    else
  70                        handleRedirect env -< page
  71
  72
  73 {-
  74   HTTP/1.1 302 Found
  75   Location: http://example.org/Destination.html#Redirect:Source
  76 -}
  77 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  78 handleRedirect env
  79     = proc redir
  80     -> returnA -< do mType <- getEntityType
  81                      case mType of
  82                        MIMEType "text" "xml" _
  83                            -> do setContentType mType
  84                                  [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  85                                                                 >>>
  86                                                                 constA redir
  87                                                                 >>>
  88                                                                 xmlizePage
  89                                                                 >>>
  90                                                                 writeDocumentToString [ (a_indent, v_1) ]
  91                                                               )
  92                                  output resultStr
  93
  94                        _   -> do BaseURI baseURI <- getSysConf (envSysConf env)
  95                                  let uri = mkPageFragmentURI
  96                                            baseURI
  97                                            (redirDest redir)
  98                                            ("Redirect:" ++ redirName redir)
  99                                  redirect Found uri
 100
 101
 102 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 103 handleGetEntity env
 104     = proc page
 105     -> do tree <- xmlizePage -< page
 106           returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
 107                         -- てゐる可能性があるので、ETag も
 108                         -- Last-Modified も返す事が出來ない。
 109                         case entityType page of
 110                           MIMEType "text" "x-rakka" _
 111                               -> return ()
 112                           _   -> case entityRevision page of
 113                                    0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
 114                                    rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
 115
 116                         outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
 117                                            , (MIMEType "application" "rss+xml"   [], entityToRSS   env)
 118                                            ]
 119
 120
 121 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 122 entityToXHTML env
 123     = proc page
 124     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 125           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 126           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 127           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 128
 129           name     <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 130           isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
 131
 132           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 133               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 134
 135           feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
 136
 137           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
 138           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
 139           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
 140           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 141
 142           ( eelem "/"
 143             += ( eelem "html"
 144                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 145                  += ( getXPathTreesInDoc "/page/@lang"
 146                       `guards`
 147                       qattr (QN "xml" "lang" "")
 148                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 149                     )
 150                  += ( eelem "head"
 151                       += ( eelem "title"
 152                            += txt siteName
 153                            += txt " - "
 154                            += getXPathTreesInDoc "/page/@name/text()"
 155                          )
 156                       += ( constL cssHref
 157                            >>>
 158                            eelem "link"
 159                            += sattr "rel"  "stylesheet"
 160                            += sattr "type" "text/css"
 161                            += attr "href" (arr id >>> mkText)
 162                          )
 163                       += ( constL feeds
 164                            >>>
 165                            eelem "link"
 166                            += sattr "rel"   "alternate"
 167                            += sattr "type"  "application/rss+xml"
 168                            += attr  "title" (txt siteName <+> txt " - " <+> mkText)
 169                            += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText)
 170                          )
 171                       += ( constL scriptSrc
 172                            >>>
 173                            eelem "script"
 174                            += sattr "type" "text/javascript"
 175                            += attr "src" (arr id >>> mkText)
 176                          )
 177                       += ( eelem "script"
 178                            += sattr "type" "text/javascript"
 179                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 180                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
 181                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 182                          )
 183                     )
 184                  += ( eelem "body"
 185                       += ( eelem "div"
 186                            += sattr "class" "header"
 187                          )
 188                       += ( eelem "div"
 189                            += sattr "class" "center"
 190                            += ( eelem "div"
 191                                 += sattr "class" "title"
 192                                 += constL pageTitle
 193                               )
 194                            += ( eelem "div"
 195                                 += sattr "class" "body"
 196                                 += constL pageBody
 197                               )
 198                          )
 199                       += ( eelem "div"
 200                            += sattr "class" "footer"
 201                          )
 202                       += ( eelem "div"
 203                            += sattr "class" "left sideBar"
 204                            += ( eelem "div"
 205                                 += sattr "class" "content"
 206                                 += constL leftSideBar
 207                               )
 208                          )
 209                       += ( eelem "div"
 210                            += sattr "class" "right sideBar"
 211                            += ( eelem "div"
 212                                 += sattr "class" "content"
 213                                 += constL rightSideBar
 214                               )
 215                          )
 216                     )
 217                  >>>
 218                  uniqueNamespacesFromDeclAndQNames
 219                ) ) -<< page
 220
 221
 222 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 223 entityToRSS env
 224     = proc page
 225     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 226           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 227
 228           name    <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 229           summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
 230           pages   <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
 231
 232           ( eelem "/"
 233             += ( eelem "rdf:RDF"
 234                  += sattr "xmlns"           "http://purl.org/rss/1.0/"
 235                  += sattr "xmlns:rdf"       "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
 236                  += sattr "xmlns:dc"        "http://purl.org/dc/elements/1.1/"
 237                  += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
 238                  += ( eelem "channel"
 239                       += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
 240                       += ( eelem "title"
 241                            += txt siteName
 242                            += txt " - "
 243                            += getXPathTreesInDoc "/page/@name/text()"
 244                          )
 245                       += ( eelem "link"
 246                            += txt (uriToString id baseURI "")
 247                          )
 248                       += ( eelem "description"
 249                            += txt (case summary of
 250                                      Nothing -> "RSS Feed for " ++ siteName
 251                                      Just s  -> s)
 252                          )
 253                       += ( eelem "items"
 254                            += ( eelem "rdf:Seq"
 255                                 += ( constL pages
 256                                      >>>
 257                                      eelem "rdf:li"
 258                                      += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
 259                                    )
 260                               )
 261                          )
 262                     )
 263                  += ( constL pages
 264                       >>>
 265                       arr (\ n -> (n, Nothing))
 266                       >>>
 267                       getPageA (envStorage env)
 268                       >>>
 269                       arr fromJust
 270                       >>>
 271                       eelem "item"
 272                       += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
 273                       += ( eelem "title"
 274                            += (arr entityName >>> mkText)
 275                          )
 276                       += ( eelem "link"
 277                            += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
 278                          )
 279                       += ( arrL (\ p -> case entitySummary p of
 280                                           Nothing -> []
 281                                           Just s  -> [s])
 282                            >>>
 283                            eelem "description"
 284                            += mkText
 285                          )
 286                       += ( eelem "dc:date"
 287                            += ( arrIO (utcToLocalZonedTime . entityLastMod)
 288                                 >>>
 289                                 arr formatW3CDateTime
 290                                 >>>
 291                                 mkText
 292                               )
 293                          )
 294                       += ( eelem "trackback:ping"
 295                            += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
 296                          )
 297                     )
 298                  >>>
 299                  uniqueNamespacesFromDeclAndQNames
 300                ) ) -<< page
 301     where
 302       mkPageURIStr :: URI -> PageName -> String
 303       mkPageURIStr baseURI name
 304             = uriToString id (mkPageURI baseURI name) ""
 305
 306       mkTrackbackURIStr :: URI -> PageName -> String
 307       mkTrackbackURIStr baseURI name
 308             = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
 309
 310
 311 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 312                Environment
 313             -> a (PageName, Maybe XmlTree, PageName) XmlTree
 314 readSubPage env
 315     = proc (mainPageName, mainPage, subPageName) ->
 316       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 317          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 318                      -< (mainPageName, mainPage, subPage)
 319          returnA -< subXHTML
 320
 321
 322 {-
 323   <pageListing path="Foo">
 324     <page name="Foo/Bar" />
 325     <page name="Foo/Baz" />
 326   </pageListing>
 327 -}
 328 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
 329 handleGetPageListing env
 330     = proc (dir, items)
 331     -> do tree <- ( eelem "/"
 332                     += ( eelem "pageListing"
 333                          += attr "path" (arr fst >>> mkText)
 334                          += ( arrL snd
 335                               >>>
 336                               ( eelem "page"
 337                                 += attr "name" (arr id >>> mkText)
 338                               )
 339                             )
 340                        )
 341                   ) -< (dir, items)
 342           returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
 343
 344
 345 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 346 pageListingToXHTML env
 347     = proc pageListing
 348     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 349           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 350           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 351           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 352
 353           name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
 354
 355           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 356               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 357
 358           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 359           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 360           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 361
 362           ( eelem "/"
 363             += ( eelem "html"
 364                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 365                  += ( eelem "head"
 366                       += ( eelem "title"
 367                            += txt siteName
 368                            += txt " - "
 369                            += getXPathTreesInDoc "/pageListing/@path/text()"
 370                          )
 371                       += ( constL cssHref
 372                            >>>
 373                            eelem "link"
 374                            += sattr "rel"  "stylesheet"
 375                            += sattr "type" "text/css"
 376                            += attr "href" (arr id >>> mkText)
 377                          )
 378                       += ( constL scriptSrc
 379                            >>>
 380                            eelem "script"
 381                            += sattr "type" "text/javascript"
 382                            += attr "src" (arr id >>> mkText)
 383                          )
 384                       += ( eelem "script"
 385                            += sattr "type" "text/javascript"
 386                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 387                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 388                          )
 389                     )
 390                  += ( eelem "body"
 391                       += ( eelem "div"
 392                            += sattr "class" "header"
 393                          )
 394                       += ( eelem "div"
 395                            += sattr "class" "center"
 396                            += ( eelem "div"
 397                                 += sattr "class" "title"
 398                                 += constL pageTitle
 399                               )
 400                            += ( eelem "div"
 401                                 += sattr "class" "body"
 402                                 += ( eelem "ul"
 403                                      += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
 404                                           >>>
 405                                           eelem "li"
 406                                           += ( eelem "a"
 407                                                += attr "href" ( getText
 408                                                                 >>>
 409                                                                 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 410                                                                 >>>
 411                                                                 mkText
 412                                                               )
 413                                                += this
 414                                              )
 415                                         )
 416                                    )
 417                               )
 418                          )
 419                       += ( eelem "div"
 420                            += sattr "class" "footer"
 421                          )
 422                       += ( eelem "div"
 423                            += sattr "class" "left sideBar"
 424                            += ( eelem "div"
 425                                 += sattr "class" "content"
 426                                 += constL leftSideBar
 427                               )
 428                          )
 429                       += ( eelem "div"
 430                            += sattr "class" "right sideBar"
 431                            += ( eelem "div"
 432                                 += sattr "class" "content"
 433                                 += constL rightSideBar
 434                               )
 435                          )
 436                     )
 437                  >>>
 438                  uniqueNamespacesFromDeclAndQNames
 439                ) ) -<< pageListing
 440
 441
 442 {-
 443   <pageNotFound name="Foo/Bar" />
 444 -}
 445 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 446 handlePageNotFound env
 447     = proc name
 448     -> do tree <- ( eelem "/"
 449                     += ( eelem "pageNotFound"
 450                          += attr "name" (arr id >>> mkText)
 451                        )
 452                   ) -< name
 453           returnA -< do setStatus NotFound
 454                         outputXmlPage' tree (notFoundToXHTML env)
 455
 456
 457 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 458 notFoundToXHTML env
 459     = proc pageNotFound
 460     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 461           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 462           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 463           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 464
 465           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 466
 467           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 468               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 469
 470           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 471           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 472           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 473
 474           ( eelem "/"
 475             += ( eelem "html"
 476                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 477                  += ( eelem "head"
 478                       += ( eelem "title"
 479                            += txt siteName
 480                            += txt " - "
 481                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 482                          )
 483                       += ( constL cssHref
 484                            >>>
 485                            eelem "link"
 486                            += sattr "rel"  "stylesheet"
 487                            += sattr "type" "text/css"
 488                            += attr "href" (arr id >>> mkText)
 489                          )
 490                       += ( constL scriptSrc
 491                            >>>
 492                            eelem "script"
 493                            += sattr "type" "text/javascript"
 494                            += attr "src" (arr id >>> mkText)
 495                          )
 496                       += ( eelem "script"
 497                            += sattr "type" "text/javascript"
 498                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 499                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 500                          )
 501                     )
 502                  += ( eelem "body"
 503                       += ( eelem "div"
 504                            += sattr "class" "header"
 505                          )
 506                       += ( eelem "div"
 507                            += sattr "class" "center"
 508                            += ( eelem "div"
 509                                 += sattr "class" "title"
 510                                 += constL pageTitle
 511                               )
 512                            += ( eelem "div"
 513                                 += sattr "class" "body"
 514                                 += txt "404 Not Found (FIXME)" -- FIXME
 515                               )
 516                          )
 517                       += ( eelem "div"
 518                            += sattr "class" "footer"
 519                          )
 520                       += ( eelem "div"
 521                            += sattr "class" "left sideBar"
 522                            += ( eelem "div"
 523                                 += sattr "class" "content"
 524                                 += constL leftSideBar
 525                               )
 526                          )
 527                       += ( eelem "div"
 528                            += sattr "class" "right sideBar"
 529                            += ( eelem "div"
 530                                 += sattr "class" "content"
 531                                 += constL rightSideBar
 532                               )
 533                          )
 534                     )
 535                  >>>
 536                  uniqueNamespacesFromDeclAndQNames
 537                ) ) -<< pageNotFound
 538
 539
 540 handlePut :: Environment -> PageName -> Resource ()
 541 handlePut env name
 542     = do userID <- getUserID env
 543          runXmlA env "rakka-page-1.0.rng" $ proc tree
 544              -> do page   <- parseXmlizedPage -< (name, tree)
 545                    status <- putPageA (envStorage env) -< (userID, page)
 546                    returnA  -< setStatus status
 547
 548
 549 handleDelete :: Environment -> PageName -> Resource ()
 550 handleDelete env name
 551     = do userID <- getUserID env
 552          status <- deletePage (envStorage env) userID name
 553          setStatus status
 554
 555
 556 findFeeds :: Storage -> IO [PageName]
 557 findFeeds sto
 558     = do cond <- newCondition
 559          setPhrase   cond "[UVSET]"
 560          addAttrCond cond "rakka:isFeed STREQ yes"
 561          setOrder    cond "@uri STRA"
 562          result <- searchPages sto cond
 563          return (map fst result)
 564
 565
 566 mkFeedURIStr :: URI -> PageName -> String
 567 mkFeedURIStr baseURI name
 568     = uriToString id (mkFeedURI baseURI name) ""