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   -> handlePageNotFound env -< name
  59             Just page -> if isEntity page then
  60                              handleGetEntity env -< page
  61                          else
  62                              handleRedirect env -< page
  63
  64
  65 {-
  66   HTTP/1.1 302 Found
  67   Location: http://example.org/Destination.html#Redirect:Source
  68 -}
  69 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  70 handleRedirect env
  71     = proc redir
  72     -> returnA -< do mType <- getEntityType
  73                      case mType of
  74                        MIMEType "application" "xhtml+xml" _
  75                            -> do BaseURI baseURI <- getSysConf (envSysConf env)
  76                                  let uri = mkPageFragmentURI
  77                                            baseURI
  78                                            (redirDest redir)
  79                                            ("Redirect:" ++ redirName redir)
  80                                  redirect Found uri
  81
  82                        MIMEType "text" "xml" _
  83                            -> do setContentType mType
  84                                  [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  85                                                                 >>>
  86                                                                 constA redir
  87                                                                 >>>
  88                                                                 xmlizePage
  89                                                                 >>>
  90                                                                 writeDocumentToString [ (a_indent, v_1) ]
  91                                                               )
  92                                  output resultStr
  93
  94                        _   -> fail ("internal error: getEntityType returned " ++ show mType)
  95
  96
  97 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
  98 handleGetEntity env
  99     = proc page
 100     -> do tree <- xmlizePage -< page
 101           returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
 102                         -- てゐる可能性があるので、ETag も
 103                         -- Last-Modified も返す事が出來ない。
 104                         case entityType page of
 105                           MIMEType "text" "x-rakka" _
 106                               -> return ()
 107                           _   -> case entityRevision page of
 108                                    0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
 109                                    rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
 110
 111                         outputXmlPage tree (entityToXHTML env)
 112
 113
 114 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 115 entityToXHTML env
 116     = proc page
 117     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 118           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 119           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 120           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 121
 122           name     <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 123           isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
 124
 125           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 126               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 127
 128           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
 129           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
 130           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
 131           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 132
 133           ( eelem "/"
 134             += ( eelem "html"
 135                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 136                  += ( getXPathTreesInDoc "/page/@lang"
 137                       `guards`
 138                       qattr (QN "xml" "lang" "")
 139                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 140                     )
 141                  += ( eelem "head"
 142                       += ( eelem "title"
 143                            += txt siteName
 144                            += txt " - "
 145                            += getXPathTreesInDoc "/page/@name/text()"
 146                          )
 147                       += ( constL cssHref
 148                            >>>
 149                            eelem "link"
 150                            += sattr "rel"  "stylesheet"
 151                            += sattr "type" "text/css"
 152                            += attr "href" (arr id >>> mkText)
 153                          )
 154                       += ( constL scriptSrc
 155                            >>>
 156                            eelem "script"
 157                            += sattr "type" "text/javascript"
 158                            += attr "src" (arr id >>> mkText)
 159                          )
 160                       += ( eelem "script"
 161                            += sattr "type" "text/javascript"
 162                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 163                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
 164                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 165                          )
 166                     )
 167                  += ( eelem "body"
 168                       += ( eelem "div"
 169                            += sattr "class" "header"
 170                          )
 171                       += ( eelem "div"
 172                            += sattr "class" "center"
 173                            += ( eelem "div"
 174                                 += sattr "class" "title"
 175                                 += constL pageTitle
 176                               )
 177                            += ( eelem "div"
 178                                 += sattr "class" "body"
 179                                 += constL pageBody
 180                               )
 181                          )
 182                       += ( eelem "div"
 183                            += sattr "class" "footer"
 184                          )
 185                       += ( eelem "div"
 186                            += sattr "class" "left sideBar"
 187                            += ( eelem "div"
 188                                 += sattr "class" "content"
 189                                 += constL leftSideBar
 190                               )
 191                          )
 192                       += ( eelem "div"
 193                            += sattr "class" "right sideBar"
 194                            += ( eelem "div"
 195                                 += sattr "class" "content"
 196                                 += constL rightSideBar
 197                               )
 198                          )
 199                     )
 200                  >>>
 201                  uniqueNamespacesFromDeclAndQNames
 202                ) ) -<< page
 203
 204
 205 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 206                Environment
 207             -> a (PageName, Maybe XmlTree, PageName) XmlTree
 208 readSubPage env
 209     = proc (mainPageName, mainPage, subPageName) ->
 210       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 211          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 212                      -< (mainPageName, mainPage, subPage)
 213          returnA -< subXHTML
 214
 215
 216 {-
 217   <pageNotFound name="Foo/Bar" />
 218 -}
 219 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 220 handlePageNotFound env
 221     = proc name
 222     -> do tree <- ( eelem "/"
 223                     += ( eelem "pageNotFound"
 224                          += attr "name" (arr id >>> mkText)
 225                        )
 226                   ) -< name
 227           returnA -< do setStatus NotFound
 228                         outputXmlPage tree (notFoundToXHTML env)
 229
 230
 231 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 232 notFoundToXHTML env
 233     = proc pageNotFound
 234     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 235           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 236           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 237           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 238
 239           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 240
 241           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 242               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 243
 244           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 245           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 246           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 247
 248           ( eelem "/"
 249             += ( eelem "html"
 250                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 251                  += ( eelem "head"
 252                       += ( eelem "title"
 253                            += txt siteName
 254                            += txt " - "
 255                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 256                          )
 257                       += ( constL cssHref
 258                            >>>
 259                            eelem "link"
 260                            += sattr "rel"  "stylesheet"
 261                            += sattr "type" "text/css"
 262                            += attr "href" (arr id >>> mkText)
 263                          )
 264                       += ( constL scriptSrc
 265                            >>>
 266                            eelem "script"
 267                            += sattr "type" "text/javascript"
 268                            += attr "src" (arr id >>> mkText)
 269                          )
 270                       += ( eelem "script"
 271                            += sattr "type" "text/javascript"
 272                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 273                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 274                          )
 275                     )
 276                  += ( eelem "body"
 277                       += ( eelem "div"
 278                            += sattr "class" "header"
 279                          )
 280                       += ( eelem "div"
 281                            += sattr "class" "center"
 282                            += ( eelem "div"
 283                                 += sattr "class" "title"
 284                                 += constL pageTitle
 285                               )
 286                            += ( eelem "div"
 287                                 += sattr "class" "body"
 288                                 += txt "404 Not Found (FIXME)" -- FIXME
 289                               )
 290                          )
 291                       += ( eelem "div"
 292                            += sattr "class" "footer"
 293                          )
 294                       += ( eelem "div"
 295                            += sattr "class" "left sideBar"
 296                            += ( eelem "div"
 297                                 += sattr "class" "content"
 298                                 += constL leftSideBar
 299                               )
 300                          )
 301                       += ( eelem "div"
 302                            += sattr "class" "right sideBar"
 303                            += ( eelem "div"
 304                                 += sattr "class" "content"
 305                                 += constL rightSideBar
 306                               )
 307                          )
 308                     )
 309                  >>>
 310                  uniqueNamespacesFromDeclAndQNames
 311                ) ) -<< pageNotFound
 312
 313
 314 handlePut :: Environment -> PageName -> Resource ()
 315 handlePut env name
 316     = do userID <- getUserID env
 317          runXmlA env "rakka-page-1.0.rng" $ proc tree
 318              -> do page   <- parseXmlizedPage -< (name, tree)
 319                    status <- putPageA (envStorage env) -< (userID, page)
 320                    returnA  -< setStatus status
 321
 322
 323 handleDelete :: Environment -> PageName -> Resource ()
 324 handleDelete env name
 325     = do userID <- getUserID env
 326          status <- deletePage (envStorage env) userID name
 327          setStatus status