Rakka/Resource/Render.hs

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