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