Rakka/Resource/PageEntity.hs

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