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           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.Wiki.Engine
  23 import           System.FilePath
  24 import           Text.XML.HXT.Arrow.Namespace
  25 import           Text.XML.HXT.Arrow.WriteDocument
  26 import           Text.XML.HXT.Arrow.XmlArrow
  27 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  28 import           Text.XML.HXT.Arrow.XmlNodeSet
  29 import           Text.XML.HXT.DOM.TypeDefs
  30 import           Text.XML.HXT.DOM.XmlKeywords
  31
  32
  33 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
  34 fallbackPageEntity env path
  35     | null path                  = return Nothing
  36     | null $ head path           = return Nothing
  37     | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
  38     | otherwise
  39         = return $ Just $ ResourceDef {
  40             resUsesNativeThread = False
  41           , resIsGreedy         = True
  42           , resGet              = Just $ handleGet    env (toPageName path)
  43           , resHead             = Nothing
  44           , resPost             = Nothing
  45           , resPut              = Just $ handlePut    env (toPageName path)
  46           , resDelete           = Just $ handleDelete env (toPageName path)
  47           }
  48     where
  49       toPageName :: [String] -> PageName
  50       toPageName = decodePageName . dropExtension . joinWith "/"
  51
  52
  53 handleGet :: Environment -> PageName -> Resource ()
  54 handleGet env name
  55     = runIdempotentA $ proc ()
  56     -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
  57           case pageM of
  58             Nothing
  59                 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
  60                       case items of
  61                         [] -> handlePageNotFound   env -< name
  62                         _  -> handleGetPageListing env -< (name, items)
  63             Just page
  64                 -> if isEntity page then
  65                        handleGetEntity env -< page
  66                    else
  67                        handleRedirect env -< page
  68
  69
  70 {-
  71   HTTP/1.1 302 Found
  72   Location: http://example.org/Destination.html#Redirect:Source
  73 -}
  74 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  75 handleRedirect env
  76     = proc redir
  77     -> returnA -< do mType <- getEntityType
  78                      case mType of
  79                        MIMEType "application" "xhtml+xml" _
  80                            -> do BaseURI baseURI <- getSysConf (envSysConf env)
  81                                  let uri = mkPageFragmentURI
  82                                            baseURI
  83                                            (redirDest redir)
  84                                            ("Redirect:" ++ redirName redir)
  85                                  redirect Found uri
  86
  87                        MIMEType "text" "xml" _
  88                            -> do setContentType mType
  89                                  [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  90                                                                 >>>
  91                                                                 constA redir
  92                                                                 >>>
  93                                                                 xmlizePage
  94                                                                 >>>
  95                                                                 writeDocumentToString [ (a_indent, v_1) ]
  96                                                               )
  97                                  output resultStr
  98
  99                        _   -> fail ("internal error: getEntityType returned " ++ show mType)
 100
 101
 102 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 103 handleGetEntity env
 104     = proc page
 105     -> do tree <- xmlizePage -< page
 106           returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
 107                         -- てゐる可能性があるので、ETag も
 108                         -- Last-Modified も返す事が出來ない。
 109                         case entityType page of
 110                           MIMEType "text" "x-rakka" _
 111                               -> return ()
 112                           _   -> case entityRevision page of
 113                                    0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
 114                                    rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
 115
 116                         outputXmlPage tree (entityToXHTML env)
 117
 118
 119 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 120 entityToXHTML env
 121     = proc page
 122     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 123           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 124           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 125           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 126
 127           name     <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 128           isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
 129
 130           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 131               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 132
 133           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
 134           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
 135           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
 136           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 137
 138           ( eelem "/"
 139             += ( eelem "html"
 140                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 141                  += ( getXPathTreesInDoc "/page/@lang"
 142                       `guards`
 143                       qattr (QN "xml" "lang" "")
 144                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 145                     )
 146                  += ( eelem "head"
 147                       += ( eelem "title"
 148                            += txt siteName
 149                            += txt " - "
 150                            += getXPathTreesInDoc "/page/@name/text()"
 151                          )
 152                       += ( constL cssHref
 153                            >>>
 154                            eelem "link"
 155                            += sattr "rel"  "stylesheet"
 156                            += sattr "type" "text/css"
 157                            += attr "href" (arr id >>> mkText)
 158                          )
 159                       += ( constL scriptSrc
 160                            >>>
 161                            eelem "script"
 162                            += sattr "type" "text/javascript"
 163                            += attr "src" (arr id >>> mkText)
 164                          )
 165                       += ( eelem "script"
 166                            += sattr "type" "text/javascript"
 167                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 168                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
 169                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 170                          )
 171                     )
 172                  += ( eelem "body"
 173                       += ( eelem "div"
 174                            += sattr "class" "header"
 175                          )
 176                       += ( eelem "div"
 177                            += sattr "class" "center"
 178                            += ( eelem "div"
 179                                 += sattr "class" "title"
 180                                 += constL pageTitle
 181                               )
 182                            += ( eelem "div"
 183                                 += sattr "class" "body"
 184                                 += constL pageBody
 185                               )
 186                          )
 187                       += ( eelem "div"
 188                            += sattr "class" "footer"
 189                          )
 190                       += ( eelem "div"
 191                            += sattr "class" "left sideBar"
 192                            += ( eelem "div"
 193                                 += sattr "class" "content"
 194                                 += constL leftSideBar
 195                               )
 196                          )
 197                       += ( eelem "div"
 198                            += sattr "class" "right sideBar"
 199                            += ( eelem "div"
 200                                 += sattr "class" "content"
 201                                 += constL rightSideBar
 202                               )
 203                          )
 204                     )
 205                  >>>
 206                  uniqueNamespacesFromDeclAndQNames
 207                ) ) -<< page
 208
 209
 210 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 211                Environment
 212             -> a (PageName, Maybe XmlTree, PageName) XmlTree
 213 readSubPage env
 214     = proc (mainPageName, mainPage, subPageName) ->
 215       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 216          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 217                      -< (mainPageName, mainPage, subPage)
 218          returnA -< subXHTML
 219
 220
 221 {-
 222   <pageListing path="Foo">
 223     <page name="Foo/Bar" />
 224     <page name="Foo/Baz" />
 225   </pageListing>
 226 -}
 227 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
 228 handleGetPageListing env
 229     = proc (dir, items)
 230     -> do tree <- ( eelem "/"
 231                     += ( eelem "pageListing"
 232                          += attr "path" (arr fst >>> mkText)
 233                          += ( arrL snd
 234                               >>>
 235                               ( eelem "page"
 236                                 += attr "name" (arr id >>> mkText)
 237                               )
 238                             )
 239                        )
 240                   ) -< (dir, items)
 241           returnA -< outputXmlPage tree (pageListingToXHTML env)
 242
 243
 244 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 245 pageListingToXHTML env
 246     = proc pageListing
 247     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 248           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 249           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 250           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 251
 252           name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
 253
 254           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 255               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 256
 257           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 258           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 259           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 260
 261           ( eelem "/"
 262             += ( eelem "html"
 263                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 264                  += ( eelem "head"
 265                       += ( eelem "title"
 266                            += txt siteName
 267                            += txt " - "
 268                            += getXPathTreesInDoc "/pageListing/@path/text()"
 269                          )
 270                       += ( constL cssHref
 271                            >>>
 272                            eelem "link"
 273                            += sattr "rel"  "stylesheet"
 274                            += sattr "type" "text/css"
 275                            += attr "href" (arr id >>> mkText)
 276                          )
 277                       += ( constL scriptSrc
 278                            >>>
 279                            eelem "script"
 280                            += sattr "type" "text/javascript"
 281                            += attr "src" (arr id >>> mkText)
 282                          )
 283                       += ( eelem "script"
 284                            += sattr "type" "text/javascript"
 285                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 286                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 287                          )
 288                     )
 289                  += ( eelem "body"
 290                       += ( eelem "div"
 291                            += sattr "class" "header"
 292                          )
 293                       += ( eelem "div"
 294                            += sattr "class" "center"
 295                            += ( eelem "div"
 296                                 += sattr "class" "title"
 297                                 += constL pageTitle
 298                               )
 299                            += ( eelem "div"
 300                                 += sattr "class" "body"
 301                                 += ( eelem "ul"
 302                                      += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
 303                                           >>>
 304                                           eelem "li"
 305                                           += ( eelem "a"
 306                                                += attr "href" ( getText
 307                                                                 >>>
 308                                                                 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 309                                                                 >>>
 310                                                                 mkText
 311                                                               )
 312                                                += this
 313                                              )
 314                                         )
 315                                    )
 316                               )
 317                          )
 318                       += ( eelem "div"
 319                            += sattr "class" "footer"
 320                          )
 321                       += ( eelem "div"
 322                            += sattr "class" "left sideBar"
 323                            += ( eelem "div"
 324                                 += sattr "class" "content"
 325                                 += constL leftSideBar
 326                               )
 327                          )
 328                       += ( eelem "div"
 329                            += sattr "class" "right sideBar"
 330                            += ( eelem "div"
 331                                 += sattr "class" "content"
 332                                 += constL rightSideBar
 333                               )
 334                          )
 335                     )
 336                  >>>
 337                  uniqueNamespacesFromDeclAndQNames
 338                ) ) -<< pageListing
 339
 340
 341 {-
 342   <pageNotFound name="Foo/Bar" />
 343 -}
 344 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 345 handlePageNotFound env
 346     = proc name
 347     -> do tree <- ( eelem "/"
 348                     += ( eelem "pageNotFound"
 349                          += attr "name" (arr id >>> mkText)
 350                        )
 351                   ) -< name
 352           returnA -< do setStatus NotFound
 353                         outputXmlPage tree (notFoundToXHTML env)
 354
 355
 356 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 357 notFoundToXHTML env
 358     = proc pageNotFound
 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 "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 365
 366           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 367               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 368
 369           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 370           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 371           rightSideBar <- listA (readSubPage env) -< (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 siteName
 379                            += txt " - "
 380                            += getXPathTreesInDoc "/pageNotFound/@name/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                       += ( constL scriptSrc
 390                            >>>
 391                            eelem "script"
 392                            += sattr "type" "text/javascript"
 393                            += attr "src" (arr id >>> mkText)
 394                          )
 395                       += ( eelem "script"
 396                            += sattr "type" "text/javascript"
 397                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 398                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 399                          )
 400                     )
 401                  += ( eelem "body"
 402                       += ( eelem "div"
 403                            += sattr "class" "header"
 404                          )
 405                       += ( eelem "div"
 406                            += sattr "class" "center"
 407                            += ( eelem "div"
 408                                 += sattr "class" "title"
 409                                 += constL pageTitle
 410                               )
 411                            += ( eelem "div"
 412                                 += sattr "class" "body"
 413                                 += txt "404 Not Found (FIXME)" -- FIXME
 414                               )
 415                          )
 416                       += ( eelem "div"
 417                            += sattr "class" "footer"
 418                          )
 419                       += ( eelem "div"
 420                            += sattr "class" "left sideBar"
 421                            += ( eelem "div"
 422                                 += sattr "class" "content"
 423                                 += constL leftSideBar
 424                               )
 425                          )
 426                       += ( eelem "div"
 427                            += sattr "class" "right sideBar"
 428                            += ( eelem "div"
 429                                 += sattr "class" "content"
 430                                 += constL rightSideBar
 431                               )
 432                          )
 433                     )
 434                  >>>
 435                  uniqueNamespacesFromDeclAndQNames
 436                ) ) -<< pageNotFound
 437
 438
 439 handlePut :: Environment -> PageName -> Resource ()
 440 handlePut env name
 441     = do userID <- getUserID env
 442          runXmlA env "rakka-page-1.0.rng" $ proc tree
 443              -> do page   <- parseXmlizedPage -< (name, tree)
 444                    status <- putPageA (envStorage env) -< (userID, page)
 445                    returnA  -< setStatus status
 446
 447
 448 handleDelete :: Environment -> PageName -> Resource ()
 449 handleDelete env name
 450     = do userID <- getUserID env
 451          status <- deletePage (envStorage env) userID name
 452          setStatus status