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