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