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                     )
 159                  += ( eelem "body"
 160                       += ( eelem "div"
 161                            += sattr "class" "header"
 162                          )
 163                       += ( eelem "div"
 164                            += sattr "class" "center"
 165                            += ( eelem "div"
 166                                 += sattr "class" "title"
 167                                 += constL pageTitle
 168                               )
 169                            += ( eelem "div"
 170                                 += sattr "class" "body"
 171                                 += constL pageBody
 172                               )
 173                          )
 174                       += ( eelem "div"
 175                            += sattr "class" "footer"
 176                          )
 177                       += ( eelem "div"
 178                            += sattr "class" "left sideBar"
 179                            += ( eelem "div"
 180                                 += sattr "class" "content"
 181                                 += constL leftSideBar
 182                               )
 183                          )
 184                       += ( eelem "div"
 185                            += sattr "class" "right sideBar"
 186                            += ( eelem "div"
 187                                 += sattr "class" "content"
 188                                 += constL rightSideBar
 189                               )
 190                          )
 191                     )
 192                ) ) -<< page
 193
 194
 195 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 196                Environment
 197             -> a (PageName, Maybe XmlTree, PageName) XmlTree
 198 readSubPage env
 199     = proc (mainPageName, mainPage, subPageName) ->
 200       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 201          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 202                      -< (mainPageName, mainPage, subPage)
 203          returnA -< subXHTML
 204
 205
 206 {-
 207   <pageNotFound name="Foo/Bar" />
 208 -}
 209 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 210 handlePageNotFound env
 211     = proc name
 212     -> do tree <- ( eelem "/"
 213                     += ( eelem "pageNotFound"
 214                          += attr "name" (arr id >>> mkText)
 215                        )
 216                   ) -< name
 217           returnA -< do setStatus NotFound
 218                         outputXmlPage tree (notFoundToXHTML env)
 219
 220
 221 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 222 notFoundToXHTML env
 223     = proc pageNotFound
 224     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 225           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 226           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 227
 228           name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 229
 230           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 231               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 232
 233           pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
 234           leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
 235           rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 236
 237           ( eelem "/"
 238             += ( eelem "html"
 239                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 240                  += ( eelem "head"
 241                       += ( eelem "title"
 242                            += txt siteName
 243                            += txt " - "
 244                            += getXPathTreesInDoc "/pageNotFound/@name/text()"
 245                          )
 246                       += ( constL cssHref
 247                            >>>
 248                            eelem "link"
 249                            += sattr "rel"  "stylesheet"
 250                            += sattr "type" "text/css"
 251                            += attr "href" (arr id >>> mkText)
 252                          )
 253                       += ( constL scriptSrc
 254                            >>>
 255                            eelem "script"
 256                            += sattr "type" "text/javascript"
 257                            += attr "src" (arr id >>> mkText)
 258                          )
 259                     )
 260                  += ( eelem "body"
 261                       += ( eelem "div"
 262                            += sattr "class" "header"
 263                          )
 264                       += ( eelem "div"
 265                            += sattr "class" "center"
 266                            += ( eelem "div"
 267                                 += sattr "class" "title"
 268                                 += constL pageTitle
 269                               )
 270                            += ( eelem "div"
 271                                 += sattr "class" "body"
 272                                 += txt "404 Not Found (FIXME)" -- FIXME
 273                               )
 274                          )
 275                       += ( eelem "div"
 276                            += sattr "class" "footer"
 277                          )
 278                       += ( eelem "div"
 279                            += sattr "class" "left sideBar"
 280                            += ( eelem "div"
 281                                 += sattr "class" "content"
 282                                 += constL leftSideBar
 283                               )
 284                          )
 285                       += ( eelem "div"
 286                            += sattr "class" "right sideBar"
 287                            += ( eelem "div"
 288                                 += sattr "class" "content"
 289                                 += constL rightSideBar
 290                               )
 291                          )
 292                     )
 293                ) ) -<< pageNotFound
 294
 295
 296 handlePut :: Environment -> PageName -> Resource ()
 297 handlePut env name
 298     = runXmlA env "rakka-page-1.0.rng" $ proc tree
 299     -> do page   <- parseXmlizedPage -< (name, tree)
 300           status <- putPageA (envStorage env) -< page
 301           returnA  -< setStatus status