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 -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
 107                                         , (MIMEType "application" "rss+xml"   [], entityToRSS   env)
 108                                         ]
 109
 110
 111 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 112 entityToXHTML env
 113     = proc page
 114     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 115           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 116           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 117           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 118
 119           name     <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 120           isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
 121
 122           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 123               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 124
 125           feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
 126
 127           pageTitle    <- listA (readSubPage env) -< (Just name, Just page, "PageTitle")
 128           leftSideBar  <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left")
 129           rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right")
 130           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 131
 132           ( eelem "/"
 133             += ( eelem "html"
 134                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 135                  += ( getXPathTreesInDoc "/page/@lang"
 136                       `guards`
 137                       qattr (QN "xml" "lang" "")
 138                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 139                     )
 140                  += ( eelem "head"
 141                       += ( eelem "title"
 142                            += txt siteName
 143                            += txt " - "
 144                            += getXPathTreesInDoc "/page/@name/text()"
 145                          )
 146                       += ( constL cssHref
 147                            >>>
 148                            eelem "link"
 149                            += sattr "rel"  "stylesheet"
 150                            += sattr "type" "text/css"
 151                            += attr "href" (arr id >>> mkText)
 152                          )
 153                       += ( constL feeds
 154                            >>>
 155                            eelem "link"
 156                            += sattr "rel"   "alternate"
 157                            += sattr "type"  "application/rss+xml"
 158                            += attr  "title" (txt siteName <+> txt " - " <+> mkText)
 159                            += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText)
 160                          )
 161                       += ( constL scriptSrc
 162                            >>>
 163                            eelem "script"
 164                            += sattr "type" "text/javascript"
 165                            += attr "src" (arr id >>> mkText)
 166                          )
 167                       += ( eelem "script"
 168                            += sattr "type" "text/javascript"
 169                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 170                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
 171                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 172                          )
 173                     )
 174                  += ( eelem "body"
 175                       += ( eelem "div"
 176                            += sattr "class" "header"
 177                          )
 178                       += ( eelem "div"
 179                            += sattr "class" "center"
 180                            += ( eelem "div"
 181                                 += sattr "class" "title"
 182                                 += constL pageTitle
 183                               )
 184                            += ( eelem "div"
 185                                 += sattr "class" "body"
 186                                 += constL pageBody
 187                               )
 188                          )
 189                       += ( eelem "div"
 190                            += sattr "class" "footer"
 191                          )
 192                       += ( eelem "div"
 193                            += sattr "class" "left sideBar"
 194                            += ( eelem "div"
 195                                 += sattr "class" "content"
 196                                 += constL leftSideBar
 197                               )
 198                          )
 199                       += ( eelem "div"
 200                            += sattr "class" "right sideBar"
 201                            += ( eelem "div"
 202                                 += sattr "class" "content"
 203                                 += constL rightSideBar
 204                               )
 205                          )
 206                     )
 207                  >>>
 208                  uniqueNamespacesFromDeclAndQNames
 209                ) ) -<< page
 210
 211
 212 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 213 entityToRSS env
 214     = proc page
 215     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 216           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 217
 218           name    <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 219           summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
 220           pages   <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
 221
 222           ( eelem "/"
 223             += ( eelem "rdf:RDF"
 224                  += sattr "xmlns"           "http://purl.org/rss/1.0/"
 225                  += sattr "xmlns:rdf"       "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
 226                  += sattr "xmlns:dc"        "http://purl.org/dc/elements/1.1/"
 227                  += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
 228                  += ( eelem "channel"
 229                       += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
 230                       += ( eelem "title"
 231                            += txt siteName
 232                            += txt " - "
 233                            += getXPathTreesInDoc "/page/@name/text()"
 234                          )
 235                       += ( eelem "link"
 236                            += txt (uriToString id baseURI "")
 237                          )
 238                       += ( eelem "description"
 239                            += txt (case summary of
 240                                      Nothing -> "RSS Feed for " ++ siteName
 241                                      Just s  -> s)
 242                          )
 243                       += ( eelem "items"
 244                            += ( eelem "rdf:Seq"
 245                                 += ( constL pages
 246                                      >>>
 247                                      eelem "rdf:li"
 248                                      += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
 249                                    )
 250                               )
 251                          )
 252                     )
 253                  += ( constL pages
 254                       >>>
 255                       arr (\ n -> (n, Nothing))
 256                       >>>
 257                       getPageA (envStorage env)
 258                       >>>
 259                       arr fromJust
 260                       >>>
 261                       eelem "item"
 262                       += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
 263                       += ( eelem "title"
 264                            += (arr entityName >>> mkText)
 265                          )
 266                       += ( eelem "link"
 267                            += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
 268                          )
 269                       += ( arrL (\ p -> case entitySummary p of
 270                                           Nothing -> []
 271                                           Just s  -> [s])
 272                            >>>
 273                            eelem "description"
 274                            += mkText
 275                          )
 276                       += ( eelem "dc:date"
 277                            += ( arrIO (utcToLocalZonedTime . entityLastMod)
 278                                 >>>
 279                                 arr formatW3CDateTime
 280                                 >>>
 281                                 mkText
 282                               )
 283                          )
 284                       += ( eelem "trackback:ping"
 285                            += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
 286                          )
 287                     )
 288                  >>>
 289                  uniqueNamespacesFromDeclAndQNames
 290                ) ) -<< page
 291     where
 292       mkPageURIStr :: URI -> PageName -> String
 293       mkPageURIStr baseURI name
 294             = uriToString id (mkPageURI baseURI name) ""
 295
 296       mkTrackbackURIStr :: URI -> PageName -> String
 297       mkTrackbackURIStr baseURI name
 298             = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
 299
 300
 301 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 302                Environment
 303             -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
 304 readSubPage env
 305     = proc (mainPageName, mainPage, subPageName) ->
 306       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 307          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 308                      -< (mainPageName, mainPage, subPage)
 309          returnA -< subXHTML
 310
 311
 312 {-
 313   <pageListing path="Foo">
 314     <page name="Foo/Bar" />
 315     <page name="Foo/Baz" />
 316   </pageListing>
 317 -}
 318 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
 319 handleGetPageListing env
 320     = proc (dir, items)
 321     -> do tree <- ( eelem "/"
 322                     += ( eelem "pageListing"
 323                          += attr "path" (arr fst >>> mkText)
 324                          += ( arrL snd
 325                               >>>
 326                               ( eelem "page"
 327                                 += attr "name" (arr id >>> mkText)
 328                               )
 329                             )
 330                        )
 331                   ) -< (dir, items)
 332           returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
 333
 334
 335 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 336 pageListingToXHTML env
 337     = proc pageListing
 338     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 339           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 340           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 341           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 342
 343           name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
 344
 345           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 346               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 347
 348           pageTitle    <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
 349           leftSideBar  <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
 350           rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
 351
 352           ( eelem "/"
 353             += ( eelem "html"
 354                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 355                  += ( eelem "head"
 356                       += ( eelem "title"
 357                            += txt siteName
 358                            += txt " - "
 359                            += getXPathTreesInDoc "/pageListing/@path/text()"
 360                          )
 361                       += ( constL cssHref
 362                            >>>
 363                            eelem "link"
 364                            += sattr "rel"  "stylesheet"
 365                            += sattr "type" "text/css"
 366                            += attr "href" (arr id >>> mkText)
 367                          )
 368                       += ( constL scriptSrc
 369                            >>>
 370                            eelem "script"
 371                            += sattr "type" "text/javascript"
 372                            += attr "src" (arr id >>> mkText)
 373                          )
 374                       += ( eelem "script"
 375                            += sattr "type" "text/javascript"
 376                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 377                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 378                          )
 379                     )
 380                  += ( eelem "body"
 381                       += ( eelem "div"
 382                            += sattr "class" "header"
 383                          )
 384                       += ( eelem "div"
 385                            += sattr "class" "center"
 386                            += ( eelem "div"
 387                                 += sattr "class" "title"
 388                                 += constL pageTitle
 389                               )
 390                            += ( eelem "div"
 391                                 += sattr "class" "body"
 392                                 += ( eelem "ul"
 393                                      += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
 394                                           >>>
 395                                           eelem "li"
 396                                           += ( eelem "a"
 397                                                += attr "href" ( getText
 398                                                                 >>>
 399                                                                 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 400                                                                 >>>
 401                                                                 mkText
 402                                                               )
 403                                                += this
 404                                              )
 405                                         )
 406                                    )
 407                               )
 408                          )
 409                       += ( eelem "div"
 410                            += sattr "class" "footer"
 411                          )
 412                       += ( eelem "div"
 413                            += sattr "class" "left sideBar"
 414                            += ( eelem "div"
 415                                 += sattr "class" "content"
 416                                 += constL leftSideBar
 417                               )
 418                          )
 419                       += ( eelem "div"
 420                            += sattr "class" "right sideBar"
 421                            += ( eelem "div"
 422                                 += sattr "class" "content"
 423                                 += constL rightSideBar
 424                               )
 425                          )
 426                     )
 427                  >>>
 428                  uniqueNamespacesFromDeclAndQNames
 429                ) ) -<< pageListing
 430
 431
 432 {-
 433   <pageNotFound name="Foo/Bar" />
 434 -}
 435 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 436 handlePageNotFound env
 437     = proc name
 438     -> do tree <- ( eelem "/"
 439                     += ( eelem "pageNotFound"
 440                          += attr "name" (arr id >>> mkText)
 441                        )
 442                   ) -< name
 443           returnA -< do setStatus NotFound
 444                         outputXmlPage' tree (notFoundToXHTML env)
 445
 446
 447 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 448 notFoundToXHTML env
 449     = proc pageNotFound
 450     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 451           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 452           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 453           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 454
 455           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 456
 457           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 458               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 459
 460           pageTitle    <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
 461           leftSideBar  <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
 462           rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
 463
 464           ( eelem "/"
 465             += ( eelem "html"
 466                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 467                  += ( eelem "head"
 468                       += ( eelem "title"
 469                            += txt siteName
 470                            += txt " - "
 471                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 472                          )
 473                       += ( constL cssHref
 474                            >>>
 475                            eelem "link"
 476                            += sattr "rel"  "stylesheet"
 477                            += sattr "type" "text/css"
 478                            += attr "href" (arr id >>> mkText)
 479                          )
 480                       += ( constL scriptSrc
 481                            >>>
 482                            eelem "script"
 483                            += sattr "type" "text/javascript"
 484                            += attr "src" (arr id >>> mkText)
 485                          )
 486                       += ( eelem "script"
 487                            += sattr "type" "text/javascript"
 488                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 489                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 490                          )
 491                     )
 492                  += ( eelem "body"
 493                       += ( eelem "div"
 494                            += sattr "class" "header"
 495                          )
 496                       += ( eelem "div"
 497                            += sattr "class" "center"
 498                            += ( eelem "div"
 499                                 += sattr "class" "title"
 500                                 += constL pageTitle
 501                               )
 502                            += ( eelem "div"
 503                                 += sattr "class" "body"
 504                                 += txt "404 Not Found (FIXME)" -- FIXME
 505                               )
 506                          )
 507                       += ( eelem "div"
 508                            += sattr "class" "footer"
 509                          )
 510                       += ( eelem "div"
 511                            += sattr "class" "left sideBar"
 512                            += ( eelem "div"
 513                                 += sattr "class" "content"
 514                                 += constL leftSideBar
 515                               )
 516                          )
 517                       += ( eelem "div"
 518                            += sattr "class" "right sideBar"
 519                            += ( eelem "div"
 520                                 += sattr "class" "content"
 521                                 += constL rightSideBar
 522                               )
 523                          )
 524                     )
 525                  >>>
 526                  uniqueNamespacesFromDeclAndQNames
 527                ) ) -<< pageNotFound
 528
 529
 530 handlePut :: Environment -> PageName -> Resource ()
 531 handlePut env name
 532     = do userID <- getUserID env
 533          runXmlA env "rakka-page-1.0.rng" $ proc tree
 534              -> do page   <- parseXmlizedPage -< (name, tree)
 535                    status <- putPageA (envStorage env) -< (userID, page)
 536                    returnA  -< setStatus status
 537
 538
 539 handleDelete :: Environment -> PageName -> Resource ()
 540 handleDelete env name
 541     = do userID <- getUserID env
 542          status <- deletePage (envStorage env) userID name
 543          setStatus status
 544
 545
 546 findFeeds :: Storage -> IO [PageName]
 547 findFeeds sto
 548     = do cond <- newCondition
 549          setPhrase   cond "[UVSET]"
 550          addAttrCond cond "rakka:isFeed STREQ yes"
 551          setOrder    cond "@uri STRA"
 552          result <- searchPages sto cond
 553          return (map srPageName result)
 554
 555
 556 mkFeedURIStr :: URI -> PageName -> String
 557 mkFeedURIStr baseURI name
 558     = uriToString id (mkFeedURI baseURI name) ""