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.WriteDocument
  24 import           Text.XML.HXT.Arrow.XmlArrow
  25 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  26 import           Text.XML.HXT.Arrow.XmlNodeSet
  27 import           Text.XML.HXT.DOM.TypeDefs
  28 import           Text.XML.HXT.DOM.XmlKeywords
  29
  30
  31 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
  32 fallbackPageEntity env path
  33     | null path                  = return Nothing
  34     | null $ head path           = return Nothing
  35     | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
  36     | otherwise
  37         = return $ Just $ ResourceDef {
  38             resUsesNativeThread = False
  39           , resIsGreedy         = True
  40           , resGet              = Just $ handleGet env (toPageName path)
  41           , resHead             = Nothing
  42           , resPost             = Nothing
  43           , resPut              = Just $ handlePut env (toPageName path)
  44           , resDelete           = Nothing
  45           }
  46     where
  47       toPageName :: [String] -> PageName
  48       toPageName = decodePageName . dropExtension . joinWith "/"
  49
  50
  51 handleGet :: Environment -> PageName -> Resource ()
  52 handleGet env name
  53     = runIdempotentA $ proc ()
  54     -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
  55           case pageM of
  56             Nothing
  57                 -> handlePageNotFound env -< name
  58
  59             Just redir@(Redirection _ _ _ _ _)
  60                 -> handleRedirect env -< redir
  61
  62             Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
  63                 -> handleGetEntity env -< entity
  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
 121           name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 122
 123           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 124               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 125
 126           pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
 127           leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
 128           rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
 129           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 130
 131           ( eelem "/"
 132             += ( eelem "html"
 133                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 134                  += ( getXPathTreesInDoc "/page/@lang"
 135                       `guards`
 136                       qattr (QN "xml" "lang" "")
 137                                 ( getXPathTreesInDoc "/page/@lang/text()" )
 138                     )
 139                  += ( eelem "head"
 140                       += ( eelem "title"
 141                            += txt siteName
 142                            += txt " - "
 143                            += getXPathTreesInDoc "/page/@name/text()"
 144                          )
 145                       += ( constL cssHref
 146                            >>>
 147                            eelem "link"
 148                            += sattr "rel"  "stylesheet"
 149                            += sattr "type" "text/css"
 150                            += attr "href" (arr id >>> mkText)
 151                          )
 152                       += ( constL scriptSrc
 153                            >>>
 154                            eelem "script"
 155                            += sattr "type" "text/javascript"
 156                            += attr "src" (arr id >>> mkText)
 157                          )
 158                       += ( eelem "script"
 159                            += sattr "type" "text/javascript"
 160                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 161                          )
 162                     )
 163                  += ( eelem "body"
 164                       += ( eelem "div"
 165                            += sattr "class" "header"
 166                          )
 167                       += ( eelem "div"
 168                            += sattr "class" "center"
 169                            += ( eelem "div"
 170                                 += sattr "class" "title"
 171                                 += constL pageTitle
 172                               )
 173                            += ( eelem "div"
 174                                 += sattr "class" "body"
 175                                 += constL pageBody
 176                               )
 177                          )
 178                       += ( eelem "div"
 179                            += sattr "class" "footer"
 180                          )
 181                       += ( eelem "div"
 182                            += sattr "class" "left sideBar"
 183                            += ( eelem "div"
 184                                 += sattr "class" "content"
 185                                 += constL leftSideBar
 186                               )
 187                          )
 188                       += ( eelem "div"
 189                            += sattr "class" "right sideBar"
 190                            += ( eelem "div"
 191                                 += sattr "class" "content"
 192                                 += constL rightSideBar
 193                               )
 194                          )
 195                     )
 196                ) ) -<< page
 197
 198
 199 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 200                Environment
 201             -> a (PageName, Maybe XmlTree, PageName) XmlTree
 202 readSubPage env
 203     = proc (mainPageName, mainPage, subPageName) ->
 204       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 205          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 206                      -< (mainPageName, mainPage, subPage)
 207          returnA -< subXHTML
 208
 209
 210 {-
 211   <pageNotFound name="Foo/Bar" />
 212 -}
 213 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 214 handlePageNotFound env
 215     = proc name
 216     -> do tree <- ( eelem "/"
 217                     += ( eelem "pageNotFound"
 218                          += attr "name" (arr id >>> mkText)
 219                        )
 220                   ) -< name
 221           returnA -< do setStatus NotFound
 222                         outputXmlPage tree (notFoundToXHTML env)
 223
 224
 225 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 226 notFoundToXHTML env
 227     = proc pageNotFound
 228     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 229           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 230           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 231
 232           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 233
 234           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 235               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 236
 237           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 238           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 239           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 240
 241           ( eelem "/"
 242             += ( eelem "html"
 243                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 244                  += ( eelem "head"
 245                       += ( eelem "title"
 246                            += txt siteName
 247                            += txt " - "
 248                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 249                          )
 250                       += ( constL cssHref
 251                            >>>
 252                            eelem "link"
 253                            += sattr "rel"  "stylesheet"
 254                            += sattr "type" "text/css"
 255                            += attr "href" (arr id >>> mkText)
 256                          )
 257                       += ( constL scriptSrc
 258                            >>>
 259                            eelem "script"
 260                            += sattr "type" "text/javascript"
 261                            += attr "src" (arr id >>> mkText)
 262                          )
 263                       += ( eelem "script"
 264                            += sattr "type" "text/javascript"
 265                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
 266                          )
 267                     )
 268                  += ( eelem "body"
 269                       += ( eelem "div"
 270                            += sattr "class" "header"
 271                          )
 272                       += ( eelem "div"
 273                            += sattr "class" "center"
 274                            += ( eelem "div"
 275                                 += sattr "class" "title"
 276                                 += constL pageTitle
 277                               )
 278                            += ( eelem "div"
 279                                 += sattr "class" "body"
 280                                 += txt "404 Not Found (FIXME)" -- FIXME
 281                               )
 282                          )
 283                       += ( eelem "div"
 284                            += sattr "class" "footer"
 285                          )
 286                       += ( eelem "div"
 287                            += sattr "class" "left sideBar"
 288                            += ( eelem "div"
 289                                 += sattr "class" "content"
 290                                 += constL leftSideBar
 291                               )
 292                          )
 293                       += ( eelem "div"
 294                            += sattr "class" "right sideBar"
 295                            += ( eelem "div"
 296                                 += sattr "class" "content"
 297                                 += constL rightSideBar
 298                               )
 299                          )
 300                     )
 301                ) ) -<< pageNotFound
 302
 303
 304 handlePut :: Environment -> PageName -> Resource ()
 305 handlePut env name
 306     = runXmlA env "rakka-page-1.0.rng" $ proc tree
 307     -> do page   <- parseXmlizedPage -< (name, tree)
 308           status <- putPageA (envStorage env) -< page
 309           returnA  -< setStatus status