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           Network.HTTP.Lucu
  28 import           Network.URI hiding (path)
  29 import Prelude.Unicode
  30 import           Rakka.Environment
  31 import           Rakka.Page
  32 import           Rakka.Resource
  33 import           Rakka.Storage
  34 import           Rakka.SystemConfig
  35 import           Rakka.Utils
  36 import           Rakka.W3CDateTime
  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                 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
 234                 += ( eelem "channel"
 235                      += sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "")
 236                      += ( eelem "title"
 237                           += txt (T.unpack siteName)
 238                           += txt " - "
 239                           += getXPathTreesInDoc "/page/@name/text()"
 240                         )
 241                      += ( eelem "link"
 242                           += txt (uriToString id baseURI "")
 243                         )
 244                      += ( eelem "description"
 245                           += txt (case summary of
 246                                     Nothing → "RSS Feed for " ⊕ T.unpack siteName
 247                                     Just s  → s)
 248                         )
 249                      += ( eelem "items"
 250                           += ( eelem "rdf:Seq"
 251                                += ( constL pages
 252                                     ⋙
 253                                     eelem "rdf:li"
 254                                     += attr "resource" (arr (mkPageURIStr baseURI) ⋙ mkText) ) ) ) )
 255                 += ( constL pages
 256                      ⋙
 257                      arr (\n → (n, Nothing))
 258                      ⋙
 259                      getPageA (envStorage env)
 260                      ⋙
 261                      arr fromJust
 262                      ⋙
 263                      eelem "item"
 264                      += attr "rdf:about" (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
 265                      += ( eelem "title"
 266                           += (arr (T.unpack ∘ entityName) ⋙ mkText)
 267                         )
 268                      += ( eelem "link"
 269                           += (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
 270                         )
 271                      += ( arrL (\p → case entitySummary p of
 272                                        Nothing → []
 273                                        Just s  → [s])
 274                           ⋙
 275                           eelem "description"
 276                           += mkText
 277                         )
 278                      += ( eelem "dc:date"
 279                           += ( arrIO (utcToLocalZonedTime . entityLastMod)
 280                                ⋙
 281                                arr formatW3CDateTime
 282                                ⋙
 283                                mkText
 284                              )
 285                         )
 286                      += ( eelem "trackback:ping"
 287                           += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) ⋙ mkText)
 288                         )
 289                    )
 290                 ⋙
 291                 uniqueNamespacesFromDeclAndQNames
 292               ) ) ⤛ page
 293     where
 294       mkPageURIStr :: URI → PageName → String
 295       mkPageURIStr baseURI name
 296             = uriToString id (mkPageURI baseURI name) ""
 297
 298       mkTrackbackURIStr :: URI → PageName → String
 299       mkTrackbackURIStr baseURI name
 300             = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
 301
 302 readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 303             ⇒ Environment
 304             → (PageName, Maybe XmlTree, PageName) ⇝ XmlTree
 305 readSubPage env
 306     = proc (mainPageName, mainPage, subPageName) →
 307       do langM        ← case mainPage of
 308                            Nothing
 309                                → returnA ⤙ Nothing
 310                            Just p
 311                                → maybeA (getXPathTreesInDoc "/page/@lang/text()" ⋙ getText) ⤙ p
 312          subPage      ← getPageA (envStorage env) ⋙ arr fromJust ⤙ (subPageName, Nothing)
 313          localSubPage ← case langM of
 314                            Nothing
 315                                → returnA ⤙ subPage
 316                            Just l
 317                                → localize (envStorage env) ⤙ (CI.mk $ T.pack l, subPage)
 318          subPageXml   ← xmlizePage ⤙ localSubPage
 319          subXHTML     ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 320                          ⤙ (Just mainPageName, mainPage, subPageXml)
 321          returnA ⤙ subXHTML
 322     where
 323       localize ∷ (ArrowChoice (⇝), ArrowIO (⇝)) ⇒ Storage → (LanguageTag, Page) ⇝ Page
 324       localize sto
 325           = proc (lang, origPage)
 326           → do let otherLang = entityOtherLang origPage
 327                    localName = M.lookup lang otherLang
 328                case localName of
 329                  Nothing
 330                      → returnA ⤙ origPage
 331                  Just ln
 332                      → do localPage ← getPageA sto ⤙ (ln, Nothing)
 333                           returnA ⤙ case localPage of
 334                                        Nothing → origPage
 335                                        Just p  → p
 336
 337
 338 {-
 339   <pageListing path="Foo">
 340     <page name="Foo/Bar" />
 341     <page name="Foo/Baz" />
 342   </pageListing>
 343 -}
 344 handleGetPageListing ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 345                      ⇒ Environment
 346                      → (PageName, [PageName]) ⇝ Resource ()
 347 handleGetPageListing env
 348     = proc (dir, items)
 349     → do tree ← ( eelem "/"
 350                   += ( eelem "pageListing"
 351                        += attr "path" (arr (T.unpack ∘ fst) ⋙ mkText)
 352                        += ( arrL snd
 353                             ⋙
 354                             ( eelem "page"
 355                               += attr "name" (arr (T.unpack ∘ id) ⋙ mkText)
 356                             )
 357                           )
 358                      )
 359                 ) ⤙ (dir, items)
 360          returnA ⤙ outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
 361
 362 pageListingToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 363                    ⇒ Environment
 364                    → XmlTree ⇝ XmlTree
 365 pageListingToXHTML env
 366     = proc pageListing
 367     → do SiteName   siteName   ← getSysConfA (envSysConf env) ⤙ ()
 368          BaseURI    baseURI    ← getSysConfA (envSysConf env) ⤙ ()
 369          StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
 370          GlobalLock isGLocked  ← getSysConfA (envSysConf env) ⤙ ()
 371
 372          name ← (getXPathTreesInDoc "/pageListing/@path/text()" ⋙ getText) ⤙ pageListing
 373
 374          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 375              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 376
 377          pageTitle    ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "PageTitle")
 378          leftSideBar  ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left")
 379          rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
 380
 381          ( eelem "/"
 382            += ( eelem "html"
 383                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 384                 += ( eelem "head"
 385                      += ( eelem "title"
 386                           += txt (T.unpack siteName)
 387                           += txt " - "
 388                           += getXPathTreesInDoc "/pageListing/@path/text()"
 389                         )
 390                      += ( constL cssHref
 391                           ⋙
 392                           eelem "link"
 393                           += sattr "rel"  "stylesheet"
 394                           += sattr "type" "text/css"
 395                           += attr "href" (arr id ⋙ mkText)
 396                         )
 397                      += mkFeedList env
 398                      += ( constL scriptSrc
 399                           ⋙
 400                           eelem "script"
 401                           += sattr "type" "text/javascript"
 402                           += attr "src" (arr id ⋙ mkText)
 403                         )
 404                      += ( eelem "script"
 405                           += sattr "type" "text/javascript"
 406                           += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 407                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 408                         )
 409                      += mkGlobalJSList env
 410                    )
 411                 += ( eelem "body"
 412                      += ( eelem "div"
 413                           += sattr "class" "header"
 414                         )
 415                      += ( eelem "div"
 416                           += sattr "class" "center"
 417                           += ( eelem "div"
 418                                += sattr "class" "title"
 419                                += constL pageTitle
 420                              )
 421                           += ( eelem "div"
 422                                += sattr "class" "body"
 423                                += ( eelem "ul"
 424                                     += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
 425                                          ⋙
 426                                          eelem "li"
 427                                          += ( eelem "a"
 428                                               += attr "href" ( getText
 429                                                                ⋙
 430                                                                arr (\ x → uriToString id (mkPageURI baseURI (T.pack x)) "")
 431                                                                ⋙
 432                                                                mkText
 433                                                              )
 434                                               += this
 435                                             ) ) ) ) )
 436                      += ( eelem "div"
 437                           += sattr "class" "footer"
 438                         )
 439                      += ( eelem "div"
 440                           += sattr "class" "left sideBar"
 441                           += ( eelem "div"
 442                                += sattr "class" "content"
 443                                += constL leftSideBar
 444                              )
 445                         )
 446                      += ( eelem "div"
 447                           += sattr "class" "right sideBar"
 448                           += ( eelem "div"
 449                                += sattr "class" "content"
 450                                += constL rightSideBar
 451                              )
 452                         )
 453                    )
 454                 ⋙
 455                 uniqueNamespacesFromDeclAndQNames
 456               ) ) ⤛ pageListing
 457
 458 {-
 459   <pageNotFound name="Foo/Bar" />
 460 -}
 461 handlePageNotFound ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 462                    ⇒ Environment
 463                    → PageName ⇝ Resource ()
 464 handlePageNotFound env
 465     = proc name
 466     → do tree ← ( eelem "/"
 467                   += ( eelem "pageNotFound"
 468                        += attr "name" (arr T.unpack ⋙ mkText)
 469                      )
 470                 ) ⤙ name
 471          returnA ⤙ do setStatus NotFound
 472                       outputXmlPage' tree (notFoundToXHTML env)
 473
 474 notFoundToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
 475                 ⇒ Environment
 476                 → XmlTree ⇝ XmlTree
 477 notFoundToXHTML env
 478     = proc pageNotFound
 479     → do SiteName   siteName   ← getSysConfA (envSysConf env) ⤙ ()
 480          BaseURI    baseURI    ← getSysConfA (envSysConf env) ⤙ ()
 481          StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
 482          GlobalLock isGLocked  ← getSysConfA (envSysConf env) ⤙ ()
 483
 484          name ← (getXPathTreesInDoc "/pageNotFound/@name/text()" ⋙ getText) ⤙ pageNotFound
 485
 486          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 487              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 488
 489          pageTitle    ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "PageTitle"    )
 490          leftSideBar  ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left" )
 491          rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
 492
 493          ( eelem "/"
 494            += ( eelem "html"
 495                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 496                 += ( eelem "head"
 497                      += ( eelem "title"
 498                           += txt (T.unpack siteName)
 499                           += txt " - "
 500                           += getXPathTreesInDoc "/pageNotFound/@name/text()"
 501                         )
 502                      += ( constL cssHref
 503                           ⋙
 504                           eelem "link"
 505                           += sattr "rel"  "stylesheet"
 506                           += sattr "type" "text/css"
 507                           += attr "href" (arr id ⋙ mkText)
 508                         )
 509                      += mkFeedList env
 510                      += ( constL scriptSrc
 511                           ⋙
 512                           eelem "script"
 513                           += sattr "type" "text/javascript"
 514                           += attr "src" (arr id ⋙ mkText)
 515                         )
 516                      += ( eelem "script"
 517                           += sattr "type" "text/javascript"
 518                           += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 519                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 520                         )
 521                      += mkGlobalJSList env
 522                    )
 523                 += ( eelem "body"
 524                      += ( eelem "div"
 525                           += sattr "class" "header"
 526                         )
 527                      += ( eelem "div"
 528                           += sattr "class" "center"
 529                           += ( eelem "div"
 530                                += sattr "class" "title"
 531                                += constL pageTitle
 532                              )
 533                           += ( eelem "div"
 534                                += sattr "class" "body"
 535                                += txt "404 Not Found (FIXME)" -- FIXME
 536                              )
 537                         )
 538                      += ( eelem "div"
 539                           += sattr "class" "footer"
 540                         )
 541                      += ( eelem "div"
 542                           += sattr "class" "left sideBar"
 543                           += ( eelem "div"
 544                                += sattr "class" "content"
 545                                += constL leftSideBar
 546                              )
 547                         )
 548                      += ( eelem "div"
 549                           += sattr "class" "right sideBar"
 550                           += ( eelem "div"
 551                                += sattr "class" "content"
 552                                += constL rightSideBar
 553                              )
 554                         )
 555                    )
 556                 ⋙
 557                 uniqueNamespacesFromDeclAndQNames
 558               ) ) ⤛ pageNotFound
 559
 560 handlePut ∷ Environment → PageName → Resource ()
 561 handlePut env name
 562     = do userID ← getUserID env
 563          runXmlA "rakka-page-1.0.rng" $ proc tree
 564              → do page   ← parseXmlizedPage ⤙ (name, tree)
 565                   status ← putPageA (envStorage env) ⤙ (userID, page)
 566                   returnA ⤙ setStatus status
 567
 568 handleDelete ∷ Environment → PageName → Resource ()
 569 handleDelete env name
 570     = do userID ← getUserID env
 571          status ← deletePage (envStorage env) userID name
 572          setStatus status
 573
 574 mkFeedList ∷ (ArrowIO (⇝), ArrowXml (⇝)) ⇒ Environment → β ⇝ XmlTree
 575 mkFeedList env
 576     = proc _
 577       → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
 578            BaseURI  baseURI  ← getSysConfA (envSysConf env) ⤙ ()
 579            feed ← unlistA ⋘ arrIO0 (findFeeds $ envStorage env) ⤙ ()
 580            ( eelem "link"
 581              += sattr "rel"   "alternate"
 582              += sattr "type"  "application/rss+xml"
 583              += attr  "title" (txt (T.unpack siteName) <+> txt " - " <+> (arr T.unpack ⋙ mkText))
 584              += attr  "href"  (arr (mkFeedURIStr baseURI) ⋙ mkText) ) ⤛ feed
 585
 586 findFeeds :: Storage -> IO [PageName]
 587 findFeeds sto
 588     = do cond <- newCondition
 589          setPhrase   cond "[UVSET]"
 590          addAttrCond cond "rakka:isFeed STREQ yes"
 591          setOrder    cond "@uri STRA"
 592          result <- searchPages sto cond
 593          return (map hpPageName $ srPages result)
 594
 595
 596 mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree
 597 mkGlobalJSList env
 598     = proc _ -> do BaseURI baseURI  <- getSysConfA (envSysConf env) -< ()
 599
 600                    scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< ()
 601                    pageM      <- getPageA (envStorage env) -< (scriptName, Nothing)
 602
 603                    case pageM of
 604                      Nothing -> none -< ()
 605                      Just page
 606                          | isEntity page
 607                              -> ( if entityIsBinary page then
 608                                       ( eelem "script"
 609                                         += sattr "type" "text/javascript"
 610                                         += attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) )
 611                                   else
 612                                       ( eelem "script"
 613                                         += sattr "type" "text/javascript"
 614                                         += (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) )
 615                                 ) -<< page
 616                          | otherwise
 617                              -> none -< ()
 618
 619 findJavaScripts ∷ Storage → IO [PageName]
 620 findJavaScripts sto
 621     = do cond ← newCondition
 622          setPhrase   cond "[UVSET]"
 623          addAttrCond cond "@title STRBW Global/"
 624          addAttrCond cond "@type  STRBW text/javascript"
 625          setOrder    cond "@uri STRA"
 626          result ← searchPages sto cond
 627          return (map hpPageName $ srPages result)
 628
 629 mkFeedURIStr ∷ URI → PageName → String
 630 mkFeedURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkFeedURI
 631
 632 mkObjectURIStr ∷ URI → PageName → String
 633 mkObjectURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkObjectURI