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