Rakka/Resource/PageEntity.hs

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