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.Wiki.Engine
  22 import           System.FilePath
  23 import           Text.XML.HXT.Arrow.Namespace
  24 import           Text.XML.HXT.Arrow.WriteDocument
  25 import           Text.XML.HXT.Arrow.XmlArrow
  26 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  27 import           Text.XML.HXT.Arrow.XmlNodeSet
  28 import           Text.XML.HXT.DOM.TypeDefs
  29 import           Text.XML.HXT.DOM.XmlKeywords
  30
  31
  32 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
  33 fallbackPageEntity env path
  34     | null path                  = return Nothing
  35     | null $ head path           = return Nothing
  36     | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
  37     | otherwise
  38         = return $ Just $ ResourceDef {
  39             resUsesNativeThread = False
  40           , resIsGreedy         = True
  41           , resGet              = Just $ handleGet    env (toPageName path)
  42           , resHead             = Nothing
  43           , resPost             = Nothing
  44           , resPut              = Just $ handlePut    env (toPageName path)
  45           , resDelete           = Just $ handleDelete env (toPageName path)
  46           }
  47     where
  48       toPageName :: [String] -> PageName
  49       toPageName = decodePageName . dropExtension . joinWith "/"
  50
  51
  52 handleGet :: Environment -> PageName -> Resource ()
  53 handleGet env name
  54     = runIdempotentA $ proc ()
  55     -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
  56           case pageM of
  57             Nothing   -> handlePageNotFound env -< name
  58             Just page -> if isEntity page then
  59                              handleGetEntity env -< page
  60                          else
  61                              handleRedirect env -< page
  62
  63
  64 {-
  65   HTTP/1.1 302 Found
  66   Location: http://example.org/Destination.html#Redirect:Source
  67 -}
  68 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  69 handleRedirect env
  70     = proc redir
  71     -> returnA -< do mType <- getEntityType
  72                      case mType of
  73                        MIMEType "application" "xhtml+xml" _
  74                            -> do BaseURI baseURI <- getSysConf (envSysConf env)
  75                                  let uri = mkPageFragmentURI
  76                                            baseURI
  77                                            (redirDest redir)
  78                                            ("Redirect:" ++ redirName redir)
  79                                  redirect Found uri
  80
  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                        _   -> fail ("internal error: getEntityType returned " ++ show mType)
  94
  95
  96 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
  97 handleGetEntity env
  98     = proc page
  99     -> do tree <- xmlizePage -< page
 100           returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
 101                         -- てゐる可能性があるので、ETag も
 102                         -- Last-Modified も返す事が出來ない。
 103                         case entityType page of
 104                           MIMEType "text" "x-rakka" _
 105                               -> return ()
 106                           _   -> case entityRevision page of
 107                                    0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
 108                                    rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
 109
 110                         outputXmlPage tree (entityToXHTML env)
 111
 112
 113 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 114 entityToXHTML env
 115     = proc page
 116     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 117           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 118           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 119
 120           name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 121
 122           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 123               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 124
 125           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
 126           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
 127           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
 128           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 129
 130           ( eelem "/"
 131             += ( eelem "html"
 132                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 133                  += ( getXPathTreesInDoc "/page/@lang"
 134                       `guards`
 135                       qattr (QN "xml" "lang" "")
 136                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 137                     )
 138                  += ( eelem "head"
 139                       += ( eelem "title"
 140                            += txt siteName
 141                            += txt " - "
 142                            += getXPathTreesInDoc "/page/@name/text()"
 143                          )
 144                       += ( constL cssHref
 145                            >>>
 146                            eelem "link"
 147                            += sattr "rel"  "stylesheet"
 148                            += sattr "type" "text/css"
 149                            += attr "href" (arr id >>> mkText)
 150                          )
 151                       += ( constL scriptSrc
 152                            >>>
 153                            eelem "script"
 154                            += sattr "type" "text/javascript"
 155                            += attr "src" (arr id >>> mkText)
 156                          )
 157                       += ( eelem "script"
 158                            += sattr "type" "text/javascript"
 159                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 160                          )
 161                     )
 162                  += ( eelem "body"
 163                       += ( eelem "div"
 164                            += sattr "class" "header"
 165                          )
 166                       += ( eelem "div"
 167                            += sattr "class" "center"
 168                            += ( eelem "div"
 169                                 += sattr "class" "title"
 170                                 += constL pageTitle
 171                               )
 172                            += ( eelem "div"
 173                                 += sattr "class" "body"
 174                                 += constL pageBody
 175                               )
 176                          )
 177                       += ( eelem "div"
 178                            += sattr "class" "footer"
 179                          )
 180                       += ( eelem "div"
 181                            += sattr "class" "left sideBar"
 182                            += ( eelem "div"
 183                                 += sattr "class" "content"
 184                                 += constL leftSideBar
 185                               )
 186                          )
 187                       += ( eelem "div"
 188                            += sattr "class" "right sideBar"
 189                            += ( eelem "div"
 190                                 += sattr "class" "content"
 191                                 += constL rightSideBar
 192                               )
 193                          )
 194                     )
 195                  >>>
 196                  uniqueNamespacesFromDeclAndQNames
 197                ) ) -<< page
 198
 199
 200 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 201                Environment
 202             -> a (PageName, Maybe XmlTree, PageName) XmlTree
 203 readSubPage env
 204     = proc (mainPageName, mainPage, subPageName) ->
 205       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 206          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 207                      -< (mainPageName, mainPage, subPage)
 208          returnA -< subXHTML
 209
 210
 211 {-
 212   <pageNotFound name="Foo/Bar" />
 213 -}
 214 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 215 handlePageNotFound env
 216     = proc name
 217     -> do tree <- ( eelem "/"
 218                     += ( eelem "pageNotFound"
 219                          += attr "name" (arr id >>> mkText)
 220                        )
 221                   ) -< name
 222           returnA -< do setStatus NotFound
 223                         outputXmlPage tree (notFoundToXHTML env)
 224
 225
 226 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 227 notFoundToXHTML env
 228     = proc pageNotFound
 229     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 230           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 231           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 232
 233           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 234
 235           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 236               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 237
 238           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 239           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 240           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 241
 242           ( eelem "/"
 243             += ( eelem "html"
 244                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 245                  += ( eelem "head"
 246                       += ( eelem "title"
 247                            += txt siteName
 248                            += txt " - "
 249                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 250                          )
 251                       += ( constL cssHref
 252                            >>>
 253                            eelem "link"
 254                            += sattr "rel"  "stylesheet"
 255                            += sattr "type" "text/css"
 256                            += attr "href" (arr id >>> mkText)
 257                          )
 258                       += ( constL scriptSrc
 259                            >>>
 260                            eelem "script"
 261                            += sattr "type" "text/javascript"
 262                            += attr "src" (arr id >>> mkText)
 263                          )
 264                       += ( eelem "script"
 265                            += sattr "type" "text/javascript"
 266                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 267                          )
 268                     )
 269                  += ( eelem "body"
 270                       += ( eelem "div"
 271                            += sattr "class" "header"
 272                          )
 273                       += ( eelem "div"
 274                            += sattr "class" "center"
 275                            += ( eelem "div"
 276                                 += sattr "class" "title"
 277                                 += constL pageTitle
 278                               )
 279                            += ( eelem "div"
 280                                 += sattr "class" "body"
 281                                 += txt "404 Not Found (FIXME)" -- FIXME
 282                               )
 283                          )
 284                       += ( eelem "div"
 285                            += sattr "class" "footer"
 286                          )
 287                       += ( eelem "div"
 288                            += sattr "class" "left sideBar"
 289                            += ( eelem "div"
 290                                 += sattr "class" "content"
 291                                 += constL leftSideBar
 292                               )
 293                          )
 294                       += ( eelem "div"
 295                            += sattr "class" "right sideBar"
 296                            += ( eelem "div"
 297                                 += sattr "class" "content"
 298                                 += constL rightSideBar
 299                               )
 300                          )
 301                     )
 302                  >>>
 303                  uniqueNamespacesFromDeclAndQNames
 304                ) ) -<< pageNotFound
 305
 306
 307 handlePut :: Environment -> PageName -> Resource ()
 308 handlePut env name
 309     = runXmlA env "rakka-page-1.0.rng" $ proc tree
 310     -> do page   <- parseXmlizedPage -< (name, tree)
 311           status <- putPageA (envStorage env) -< page
 312           returnA  -< setStatus status
 313
 314
 315 handleDelete :: Environment -> PageName -> Resource ()
 316 handleDelete env name
 317     = do status <- deletePage (envStorage env) name
 318          setStatus status