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