Rakka/Resource/PageEntity.hs

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