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     | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
  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         styleSheet="http://example.org/object/StyleSheet/Default"
  74         name="Foo/Bar"
  75         type="text/x-rakka"
  76         lang="ja"            -- 存在しない場合もある
  77         fileName="bar.rakka" -- 存在しない場合もある
  78         isTheme="no"         -- text/css の場合のみ存在
  79         isFeed="no"          -- text/x-rakka の場合のみ存在
  80         isLocked="no"
  81         isBinary="no"
  82         revision="112">      -- デフォルトでない場合のみ存在
  83         lastModified="2000-01-01T00:00:00">
  84
  85     <summary>
  86         blah blah...
  87     </summary> -- 存在しない場合もある
  88
  89     <otherLang> -- 存在しない場合もある
  90       <link lang="ja" page="Bar/Baz" />
  91     </otherLang>
  92
  93     <pageTitle>
  94       blah blah...
  95     </pageTitle>
  96
  97     <sideBar>
  98       <left>
  99         blah blah...
 100       </left>
 101       <right>
 102         blah blah...
 103       </right>
 104     </sideBar>
 105
 106     <body>
 107       blah blah...
 108     </body>
 109   </page>
 110 -}
 111 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 112 handleGetEntity env
 113     = proc page
 114     -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
 115           returnA -< do let lastMod = toClockTime $ pageLastMod page
 116
 117                         -- text/x-rakka の場合は、内容が動的に生成され
 118                         -- てゐる可能性があるので、ETag も
 119                         -- Last-Modified も返す事が出來ない。
 120                         case pageType page of
 121                           MIMEType "text" "x-rakka" _
 122                               -> return ()
 123                           _   -> case pageRevision page of
 124                                    0   -> foundTimeStamp lastMod -- 0 はデフォルトページ
 125                                    rev -> foundEntity (strongETag $ show rev) lastMod
 126
 127                         outputXmlPage tree entityToXHTML
 128
 129
 130 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
 131 entityToXHTML
 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                      += getXPathTreesInDoc "/page/@site/text()"
 143                      += txt " - "
 144                      += getXPathTreesInDoc "/page/@name/text()"
 145                    )
 146                 += ( eelem "link"
 147                      += sattr "rel"  "stylesheet"
 148                      += sattr "type" "text/css"
 149                      += attr "href"
 150                             ( getXPathTreesInDoc "/page/@styleSheet/text()" )
 151                    )
 152               )
 153            += ( eelem "body"
 154                 += ( eelem "div"
 155                      += sattr "class" "header"
 156                    )
 157                 += ( eelem "div"
 158                      += sattr "class" "center"
 159                      += ( eelem "div"
 160                           += sattr "class" "title"
 161                           += getXPathTreesInDoc "/page/pageTitle/*"
 162                         )
 163                      += ( eelem "div"
 164                           += sattr "class" "body"
 165                           += getXPathTreesInDoc "/page/body/*"
 166                         )
 167                    )
 168                 += ( eelem "div"
 169                      += sattr "class" "footer"
 170                    )
 171                 += ( eelem "div"
 172                      += sattr "class" "left sideBar"
 173                      += ( eelem "div"
 174                           += sattr "class" "content"
 175                           += getXPathTreesInDoc "/page/sideBar/left/*"
 176                         )
 177                    )
 178                 += ( eelem "div"
 179                      += sattr "class" "right sideBar"
 180                      += ( eelem "div"
 181                           += sattr "class" "content"
 182                           += getXPathTreesInDoc "/page/sideBar/right/*"
 183                         )
 184                    )
 185               )
 186            >>>
 187            uniqueNamespacesFromDeclAndQNames
 188          )
 189
 190
 191 {-
 192   <pageNotFound site="CieloNegro"
 193                 styleSheet="http://example.org/object/StyleSheet/Default"
 194                 name="Foo/Bar">
 195
 196     <pageTitle>
 197       blah blah...
 198     </pageTitle>
 199
 200     <sideBar>
 201       <left>
 202         blah blah...
 203       </left>
 204       <right>
 205         blah blah...
 206       </right>
 207     </sideBar>
 208   </pageNotFound>
 209 -}
 210 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 211 handlePageNotFound env
 212     = proc name
 213     -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
 214           returnA -< do setStatus NotFound
 215                         outputXmlPage tree notFoundToXHTML
 216
 217
 218 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
 219 notFoundToXHTML
 220     = eelem "/"
 221       += ( eelem "html"
 222            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 223            += ( eelem "head"
 224                 += ( eelem "title"
 225                      += getXPathTreesInDoc "/pageNotFound/@site/text()"
 226                      += txt " - "
 227                      += getXPathTreesInDoc "/pageNotFound/@name/text()"
 228                    )
 229                 += ( eelem "link"
 230                      += sattr "rel"  "stylesheet"
 231                      += sattr "type" "text/css"
 232                      += attr "href"
 233                             ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
 234                    )
 235               )
 236            += ( eelem "body"
 237                 += ( eelem "div"
 238                      += sattr "class" "header"
 239                    )
 240                 += ( eelem "div"
 241                      += sattr "class" "center"
 242                      += ( eelem "div"
 243                           += sattr "class" "title"
 244                           += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
 245                         )
 246                      += ( eelem "div"
 247                           += sattr "class" "body"
 248                           += txt "404 Not Found (FIXME)" -- FIXME
 249                         )
 250                    )
 251                 += ( eelem "div"
 252                      += sattr "class" "footer"
 253                    )
 254                 += ( eelem "div"
 255                      += sattr "class" "left sideBar"
 256                      += ( eelem "div"
 257                           += sattr "class" "content"
 258                           += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
 259                         )
 260                    )
 261                 += ( eelem "div"
 262                      += sattr "class" "right sideBar"
 263                      += ( eelem "div"
 264                           += sattr "class" "content"
 265                           += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
 266                         )
 267                    )
 268               )
 269            >>>
 270            uniqueNamespacesFromDeclAndQNames
 271          )