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