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           javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
 121
 122           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
 123           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
 124           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
 125           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 126
 127           ( eelem "/"
 128             += ( eelem "html"
 129                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 130                  += ( getXPathTreesInDoc "/page/@lang"
 131                       `guards`
 132                       qattr (mkQName "xml" "lang" "")
 133                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 134                     )
 135                  += ( eelem "head"
 136                       += ( eelem "title"
 137                            += txt siteName
 138                            += txt " - "
 139                            += getXPathTreesInDoc "/page/@name/text()"
 140                          )
 141                       += ( constL cssHref
 142                            >>>
 143                            eelem "link"
 144                            += sattr "rel"  "stylesheet"
 145                            += sattr "type" "text/css"
 146                            += attr "href" (arr id >>> mkText)
 147                          )
 148                       += ( constL feeds
 149                            >>>
 150                            eelem "link"
 151                            += sattr "rel"   "alternate"
 152                            += sattr "type"  "application/rss+xml"
 153                            += attr  "title" (txt siteName <+> txt " - " <+> mkText)
 154                            += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText)
 155                          )
 156                       += ( constL scriptSrc
 157                            >>>
 158                            eelem "script"
 159                            += sattr "type" "text/javascript"
 160                            += attr "src" (arr id >>> mkText)
 161                          )
 162                       += ( eelem "script"
 163                            += sattr "type" "text/javascript"
 164                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 165                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
 166                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 167                          )
 168                       += ( constL javaScripts
 169                            >>>
 170                            eelem "script"
 171                            += sattr "type" "text/javascript"
 172                            += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
 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 (PageName, Maybe XmlTree, PageName) XmlTree
 305 readSubPage env
 306     = proc (mainPageName, mainPage, subPageName) ->
 307       do langM        <- case mainPage of
 308                            Nothing
 309                                -> returnA -< Nothing
 310                            Just p
 311                                -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
 312          subPage      <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
 313          localSubPage <- case langM of
 314                            Nothing
 315                                -> returnA -< subPage
 316                            Just l
 317                                -> localize (envStorage env) -< (l, subPage)
 318          subPageXml   <- xmlizePage -< localSubPage
 319          subXHTML     <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 320                          -< (Just mainPageName, mainPage, subPageXml)
 321          returnA -< subXHTML
 322     where
 323       localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
 324       localize sto
 325           = proc (lang, origPage)
 326           -> do let otherLang = entityOtherLang origPage
 327                     localName = M.lookup lang otherLang
 328                 case localName of
 329                   Nothing
 330                       -> returnA -< origPage
 331                   Just ln
 332                       -> do localPage <- getPageA sto -< (ln, Nothing)
 333                             returnA -< case localPage of
 334                                          Nothing -> origPage
 335                                          Just p  -> p
 336
 337
 338 {-
 339   <pageListing path="Foo">
 340     <page name="Foo/Bar" />
 341     <page name="Foo/Baz" />
 342   </pageListing>
 343 -}
 344 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
 345 handleGetPageListing env
 346     = proc (dir, items)
 347     -> do tree <- ( eelem "/"
 348                     += ( eelem "pageListing"
 349                          += attr "path" (arr fst >>> mkText)
 350                          += ( arrL snd
 351                               >>>
 352                               ( eelem "page"
 353                                 += attr "name" (arr id >>> mkText)
 354                               )
 355                             )
 356                        )
 357                   ) -< (dir, items)
 358           returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
 359
 360
 361 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 362 pageListingToXHTML env
 363     = proc pageListing
 364     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 365           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 366           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 367           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 368
 369           name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
 370
 371           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 372               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 373
 374           feeds       <- arrIO0 (findFeeds (envStorage env)) -< ()
 375           javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
 376
 377           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 378           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 379           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 380
 381           ( eelem "/"
 382             += ( eelem "html"
 383                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 384                  += ( eelem "head"
 385                       += ( eelem "title"
 386                            += txt siteName
 387                            += txt " - "
 388                            += getXPathTreesInDoc "/pageListing/@path/text()"
 389                          )
 390                       += ( constL cssHref
 391                            >>>
 392                            eelem "link"
 393                            += sattr "rel"  "stylesheet"
 394                            += sattr "type" "text/css"
 395                            += attr "href" (arr id >>> mkText)
 396                          )
 397                       += ( constL feeds
 398                            >>>
 399                            eelem "link"
 400                            += sattr "rel"   "alternate"
 401                            += sattr "type"  "application/rss+xml"
 402                            += attr  "title" (txt siteName <+> txt " - " <+> mkText)
 403                            += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText)
 404                          )
 405                       += ( constL scriptSrc
 406                            >>>
 407                            eelem "script"
 408                            += sattr "type" "text/javascript"
 409                            += attr "src" (arr id >>> mkText)
 410                          )
 411                       += ( eelem "script"
 412                            += sattr "type" "text/javascript"
 413                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 414                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 415                          )
 416                       += ( constL javaScripts
 417                            >>>
 418                            eelem "script"
 419                            += sattr "type" "text/javascript"
 420                            += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
 421                          )
 422                     )
 423                  += ( eelem "body"
 424                       += ( eelem "div"
 425                            += sattr "class" "header"
 426                          )
 427                       += ( eelem "div"
 428                            += sattr "class" "center"
 429                            += ( eelem "div"
 430                                 += sattr "class" "title"
 431                                 += constL pageTitle
 432                               )
 433                            += ( eelem "div"
 434                                 += sattr "class" "body"
 435                                 += ( eelem "ul"
 436                                      += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
 437                                           >>>
 438                                           eelem "li"
 439                                           += ( eelem "a"
 440                                                += attr "href" ( getText
 441                                                                 >>>
 442                                                                 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 443                                                                 >>>
 444                                                                 mkText
 445                                                               )
 446                                                += this
 447                                              )
 448                                         )
 449                                    )
 450                               )
 451                          )
 452                       += ( eelem "div"
 453                            += sattr "class" "footer"
 454                          )
 455                       += ( eelem "div"
 456                            += sattr "class" "left sideBar"
 457                            += ( eelem "div"
 458                                 += sattr "class" "content"
 459                                 += constL leftSideBar
 460                               )
 461                          )
 462                       += ( eelem "div"
 463                            += sattr "class" "right sideBar"
 464                            += ( eelem "div"
 465                                 += sattr "class" "content"
 466                                 += constL rightSideBar
 467                               )
 468                          )
 469                     )
 470                  >>>
 471                  uniqueNamespacesFromDeclAndQNames
 472                ) ) -<< pageListing
 473
 474
 475 {-
 476   <pageNotFound name="Foo/Bar" />
 477 -}
 478 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 479 handlePageNotFound env
 480     = proc name
 481     -> do tree <- ( eelem "/"
 482                     += ( eelem "pageNotFound"
 483                          += attr "name" (arr id >>> mkText)
 484                        )
 485                   ) -< name
 486           returnA -< do setStatus NotFound
 487                         outputXmlPage' tree (notFoundToXHTML env)
 488
 489
 490 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 491 notFoundToXHTML env
 492     = proc pageNotFound
 493     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 494           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 495           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 496           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 497
 498           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 499
 500           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 501               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 502
 503           feeds       <- arrIO0 (findFeeds (envStorage env)) -< ()
 504           javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
 505
 506           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 507           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 508           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 509
 510           ( eelem "/"
 511             += ( eelem "html"
 512                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 513                  += ( eelem "head"
 514                       += ( eelem "title"
 515                            += txt siteName
 516                            += txt " - "
 517                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 518                          )
 519                       += ( constL cssHref
 520                            >>>
 521                            eelem "link"
 522                            += sattr "rel"  "stylesheet"
 523                            += sattr "type" "text/css"
 524                            += attr "href" (arr id >>> mkText)
 525                          )
 526                       += ( constL feeds
 527                            >>>
 528                            eelem "link"
 529                            += sattr "rel"   "alternate"
 530                            += sattr "type"  "application/rss+xml"
 531                            += attr  "title" (txt siteName <+> txt " - " <+> mkText)
 532                            += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText)
 533                          )
 534                       += ( constL scriptSrc
 535                            >>>
 536                            eelem "script"
 537                            += sattr "type" "text/javascript"
 538                            += attr "src" (arr id >>> mkText)
 539                          )
 540                       += ( eelem "script"
 541                            += sattr "type" "text/javascript"
 542                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 543                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 544                          )
 545                       += ( constL javaScripts
 546                            >>>
 547                            eelem "script"
 548                            += sattr "type" "text/javascript"
 549                            += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
 550                          )
 551                     )
 552                  += ( eelem "body"
 553                       += ( eelem "div"
 554                            += sattr "class" "header"
 555                          )
 556                       += ( eelem "div"
 557                            += sattr "class" "center"
 558                            += ( eelem "div"
 559                                 += sattr "class" "title"
 560                                 += constL pageTitle
 561                               )
 562                            += ( eelem "div"
 563                                 += sattr "class" "body"
 564                                 += txt "404 Not Found (FIXME)" -- FIXME
 565                               )
 566                          )
 567                       += ( eelem "div"
 568                            += sattr "class" "footer"
 569                          )
 570                       += ( eelem "div"
 571                            += sattr "class" "left sideBar"
 572                            += ( eelem "div"
 573                                 += sattr "class" "content"
 574                                 += constL leftSideBar
 575                               )
 576                          )
 577                       += ( eelem "div"
 578                            += sattr "class" "right sideBar"
 579                            += ( eelem "div"
 580                                 += sattr "class" "content"
 581                                 += constL rightSideBar
 582                               )
 583                          )
 584                     )
 585                  >>>
 586                  uniqueNamespacesFromDeclAndQNames
 587                ) ) -<< pageNotFound
 588
 589
 590 handlePut :: Environment -> PageName -> Resource ()
 591 handlePut env name
 592     = do userID <- getUserID env
 593          runXmlA env "rakka-page-1.0.rng" $ proc tree
 594              -> do page   <- parseXmlizedPage -< (name, tree)
 595                    status <- putPageA (envStorage env) -< (userID, page)
 596                    returnA  -< setStatus status
 597
 598
 599 handleDelete :: Environment -> PageName -> Resource ()
 600 handleDelete env name
 601     = do userID <- getUserID env
 602          status <- deletePage (envStorage env) userID name
 603          setStatus status
 604
 605
 606 findFeeds :: Storage -> IO [PageName]
 607 findFeeds sto
 608     = do cond <- newCondition
 609          setPhrase   cond "[UVSET]"
 610          addAttrCond cond "rakka:isFeed STREQ yes"
 611          setOrder    cond "@uri STRA"
 612          result <- searchPages sto cond
 613          return (map hpPageName $ srPages result)
 614
 615
 616 findJavaScripts :: Storage -> IO [PageName]
 617 findJavaScripts sto
 618     = do cond <- newCondition
 619          setPhrase   cond "[UVSET]"
 620          addAttrCond cond "@title STRBW Global/"
 621          addAttrCond cond "@type  STRBW text/javascript"
 622          setOrder    cond "@uri STRA"
 623          result <- searchPages sto cond
 624          return (map hpPageName $ srPages result)
 625
 626
 627 mkFeedURIStr :: URI -> PageName -> String
 628 mkFeedURIStr baseURI name
 629     = uriToString id (mkFeedURI baseURI name) ""
 630
 631
 632 mkObjectURIStr :: URI -> PageName -> String
 633 mkObjectURIStr baseURI name
 634     = uriToString id (mkObjectURI baseURI name) ""