Rakka/Resource/PageEntity.hs

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