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.ArrowList
   9 import           Data.Char
  10 import           Network.HTTP.Lucu
  11 import           Network.HTTP.Lucu.Utils
  12 import           Network.URI
  13 import           Rakka.Environment
  14 import           Rakka.Page
  15 import           Rakka.Resource
  16 import           Rakka.Storage
  17 import           Rakka.SystemConfig
  18 import           Rakka.Utils
  19 import           Rakka.Wiki.Engine
  20 import           System.FilePath
  21 import           System.Time
  22 import           Text.XML.HXT.Arrow.Namespace
  23 import           Text.XML.HXT.Arrow.XmlArrow
  24 import           Text.XML.HXT.Arrow.XmlNodeSet
  25 import           Text.XML.HXT.DOM.TypeDefs
  26
  27
  28 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
  29 fallbackRender env path
  30     | null path                        = return Nothing
  31     | null $ head path                 = return Nothing
  32     | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
  33     | otherwise
  34         = return $ Just $ ResourceDef {
  35             resUsesNativeThread = False
  36           , resIsGreedy         = True
  37           , resGet              = Just $ handleGet env (toPageName path)
  38           , resHead             = Nothing
  39           , resPost             = Nothing
  40           , resPut              = Nothing
  41           , resDelete           = Nothing
  42           }
  43     where
  44       toPageName :: [String] -> PageName
  45       toPageName = decodePageName . dropExtension . joinWith "/"
  46
  47
  48 handleGet :: Environment -> PageName -> Resource ()
  49 handleGet env name
  50     = runIdempotentA $ proc ()
  51     -> do pageM <- getPageA (envStorage env) -< name
  52           case pageM of
  53             Nothing
  54                 -> returnA -< foundNoEntity Nothing
  55
  56             Just redir@(Redirection _ _ _ _)
  57                 -> handleRedirect env -< redir
  58
  59             Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
  60                 -> handleGetEntity env -< entity
  61
  62 {-
  63   HTTP/1.1 302 Found
  64   Location: http://example.org/Destination?from=Source
  65 -}
  66 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  67 handleRedirect env
  68     = proc redir
  69     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  70           returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
  71
  72
  73 {-
  74   <page site="CieloNegro"
  75         styleSheet="http://example.org/object/StyleSheet/Default"
  76         name="Foo/Bar"
  77         type="text/x-rakka"
  78         isTheme="no"        -- text/css の場合のみ存在
  79         isFeed="no"         -- text/x-rakka の場合のみ存在
  80         isLocked="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     = let sysConf = envSysConf env
 113       in
 114         proc page
 115           -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
 116                 BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
 117                 StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
 118
 119                 Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
 120                 Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
 121                 Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
 122
 123                 tree <- ( eelem "/"
 124                           += ( eelem "page"
 125                                += sattr "site"       siteName
 126                                += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
 127                                += sattr "name"       (pageName page)
 128                                += sattr "type"       (show $ pageType page)
 129                                += ( case pageType page of
 130                                       MIMEType "text" "css" _
 131                                           -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
 132                                       _   -> none
 133                                   )
 134                                += ( case pageType page of
 135                                       MIMEType "text" "x-rakka" _
 136                                           -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
 137                                       _   -> none
 138                                   )
 139                                += sattr "isLocked" (yesOrNo $ pageIsLocked page)
 140                                += ( case pageRevision page of
 141                                       Nothing  -> none
 142                                       Just rev -> sattr "revision" (show rev)
 143                                   )
 144                                += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
 145
 146                                += ( case pageSummary page of
 147                                       Nothing -> none
 148                                       Just s  -> eelem "summary" += txt s
 149                                   )
 150
 151                                += ( case pageOtherLang page of
 152                                       [] -> none
 153                                       xs -> selem "otherLang"
 154                                             [ eelem "link"
 155                                               += sattr "lang" lang
 156                                               += sattr "page" page
 157                                                   | (lang, page) <- xs ]
 158                                   )
 159                                += ( eelem "pageTitle"
 160                                     += ( (constA page &&& constA pageTitle)
 161                                          >>>
 162                                          formatSubPage env
 163                                        )
 164                                   )
 165                                += ( eelem "sideBar"
 166                                     += ( eelem "left"
 167                                          += ( (constA page &&& constA leftSideBar)
 168                                               >>>
 169                                               formatSubPage env
 170                                             )
 171                                        )
 172                                     += ( eelem "right"
 173                                          += ( (constA page &&& constA rightSideBar)
 174                                               >>>
 175                                               formatSubPage env
 176                                             )
 177                                        )
 178                                   )
 179                                += ( eelem "body"
 180                                     += (constA page >>> formatPage env)
 181                                   )
 182                                >>>
 183                                uniqueNamespacesFromDeclAndQNames
 184                              )
 185                         ) -<< ()
 186
 187                 returnA -< do let lastMod = toClockTime $ pageLastMod page
 188
 189                               -- text/x-rakka の場合は、内容が動的に生
 190                               -- 成されてゐる可能性があるので、ETag も
 191                               -- Last-Modified も返す事が出來ない。
 192                               case pageType page of
 193                                 MIMEType "text" "x-rakka" _
 194                                     -> return ()
 195                                 _   -> case pageRevision page of
 196                                          Nothing  -> foundTimeStamp lastMod
 197                                          Just rev -> foundEntity (strongETag $ show rev) lastMod
 198
 199                               outputXmlPage tree entityToXHTML
 200
 201
 202 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
 203 entityToXHTML
 204     = eelem "/"
 205       += ( eelem "html"
 206            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 207            += ( eelem "head"
 208                 += ( eelem "title"
 209                      += getXPathTreesInDoc "/page/@site/text()"
 210                      += txt " - "
 211                      += getXPathTreesInDoc "/page/@name/text()"
 212                    )
 213                 += ( eelem "link"
 214                      += sattr "rel"  "stylesheet"
 215                      += sattr "type" "text/css"
 216                      += attr "href"
 217                             ( getXPathTreesInDoc "/page/@styleSheet/text()" )
 218                    )
 219               )
 220            += ( eelem "body"
 221                 += ( eelem "div"
 222                      += sattr "class" "header"
 223                    )
 224                 += ( eelem "div"
 225                      += sattr "class" "center"
 226                      += ( eelem "div"
 227                           += sattr "class" "title"
 228                           += getXPathTreesInDoc "/page/pageTitle/*"
 229                         )
 230                      += ( eelem "div"
 231                           += sattr "class" "body"
 232                           += getXPathTreesInDoc "/page/body/*"
 233                         )
 234                    )
 235                 += ( eelem "div"
 236                      += sattr "class" "footer"
 237                    )
 238                 += ( eelem "div"
 239                      += sattr "class" "left sideBar"
 240                      += ( eelem "div"
 241                           += sattr "class" "content"
 242                           += getXPathTreesInDoc "/page/sideBar/left/*"
 243                         )
 244                    )
 245                 += ( eelem "div"
 246                      += sattr "class" "right sideBar"
 247                      += ( eelem "div"
 248                           += sattr "class" "content"
 249                           += getXPathTreesInDoc "/page/sideBar/right/*"
 250                         )
 251                    )
 252               )
 253            >>>
 254            uniqueNamespacesFromDeclAndQNames
 255          )