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