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