Rakka/Resource/PageEntity.hs

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