Rakka/Resource/Render.hs

   1 module Rakka.Resource.Render
   2     ( fallbackRender
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowIf
   8 import           Control.Arrow.ArrowIO
   9 import           Control.Arrow.ArrowList
  10 import           Data.Char
  11 import           Network.HTTP.Lucu
  12 import           Network.HTTP.Lucu.Utils
  13 import           Network.URI
  14 import           Rakka.Environment
  15 import           Rakka.Page
  16 import           Rakka.Resource
  17 import           Rakka.Storage
  18 import           Rakka.SystemConfig
  19 import           Rakka.Utils
  20 import           Rakka.Wiki.Engine
  21 import           System.FilePath
  22 import           System.Time
  23 import           Text.XML.HXT.Arrow.Namespace
  24 import           Text.XML.HXT.Arrow.XmlArrow
  25 import           Text.XML.HXT.Arrow.XmlNodeSet
  26 import           Text.XML.HXT.DOM.TypeDefs
  27
  28
  29 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
  30 fallbackRender env path
  31     | null path                        = return Nothing
  32     | null $ head path                 = return Nothing
  33     | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
  34     | otherwise
  35         = return $ Just $ ResourceDef {
  36             resUsesNativeThread = False
  37           , resIsGreedy         = True
  38           , resGet              = Just $ handleGet env (toPageName path)
  39           , resHead             = Nothing
  40           , resPost             = Nothing
  41           , resPut              = Nothing
  42           , resDelete           = Nothing
  43           }
  44     where
  45       toPageName :: [String] -> PageName
  46       toPageName = decodePageName . dropExtension . joinWith "/"
  47
  48
  49 handleGet :: Environment -> PageName -> Resource ()
  50 handleGet env name
  51     = runIdempotentA $ proc ()
  52     -> do pageM <- getPageA (envStorage env) -< name
  53           case pageM of
  54             Nothing
  55                 -> returnA -< foundNoEntity Nothing
  56
  57             Just redir@(Redirection _ _ _ _)
  58                 -> handleRedirect env -< redir
  59
  60             Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
  61                 -> handleGetEntity env -< entity
  62
  63 {-
  64   HTTP/1.1 302 Found
  65   Location: http://example.org/Destination?from=Source
  66 -}
  67 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
  68 handleRedirect env
  69     = proc redir
  70     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  71           returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
  72
  73
  74 {-
  75   [pageIsBinary が False の場合]
  76
  77   <page site="CieloNegro"
  78         baseURI="http://example.org/"
  79         styleSheet="StyleSheet/Default"
  80         name="Foo/Bar"
  81         type="text/x-rakka"
  82         isTheme="no"        -- text/css の場合のみ存在
  83         isFeed="no"         -- text/x-rakka の場合のみ存在
  84         isLocked="no"
  85         revision="112">     -- デフォルトでない場合のみ存在
  86         lastModified="2000-01-01T00:00:00" />
  87
  88     <summary>
  89         blah blah...
  90     </summary> -- 存在しない場合もある
  91
  92     <otherLang> -- 存在しない場合もある
  93       <link lang="ja" page="Bar/Baz" />
  94     </otherLang>
  95
  96     <content>
  97       blah blah...
  98     </content>
  99   </page>
 100
 101
 102   [pageIsBinary が True の場合: content 要素の代はりに object 要素]
 103
 104   <object data="/object/Foo/Bar" /> -- data 屬性に URI
 105 -}
 106 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 107 handleGetEntity env
 108     = let sysConf = envSysConf env
 109       in
 110         proc page
 111           -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
 112                 BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
 113                 StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
 114
 115                 tree <- ( eelem "/"
 116                           += ( eelem "page"
 117                                += sattr "site"       siteName
 118                                += sattr "baseURI"    (uriToString id baseURI "")
 119                                += sattr "styleSheet" cssName
 120                                += sattr "name"       (pageName page)
 121                                += sattr "type"       (show $ pageType page)
 122                                += ( case pageType page of
 123                                       MIMEType "text" "css" _
 124                                           -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
 125                                       _   -> none
 126                                   )
 127                                += ( case pageType page of
 128                                       MIMEType "text" "x-rakka" _
 129                                           -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
 130                                       _   -> none
 131                                   )
 132                                += sattr "isLocked" (yesOrNo $ pageIsLocked page)
 133                                += ( case pageRevision page of
 134                                       Nothing  -> none
 135                                       Just rev -> sattr "revision" (show rev)
 136                                   )
 137                                += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
 138
 139                                += ( case pageSummary page of
 140                                       Nothing -> none
 141                                       Just s  -> eelem "summary" += txt s
 142                                   )
 143
 144                                += ( case pageOtherLang page of
 145                                       [] -> none
 146                                       xs -> selem "otherLang"
 147                                             [ eelem "link"
 148                                               += sattr "lang" lang
 149                                               += sattr "page" page
 150                                                   | (lang, page) <- xs ]
 151                                   )
 152
 153                                += ( case pageIsBinary page of
 154                                       False -> eelem "content"
 155                                                += (constA page >>> formatPage)
 156
 157                                       True  -> eelem "object"
 158                                                += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
 159                                   )
 160                                >>>
 161                                uniqueNamespacesFromDeclAndQNames
 162                              )
 163                         ) -<< ()
 164
 165                 returnA -< do let lastMod = toClockTime $ pageLastMod page
 166
 167                               case pageRevision page of
 168                                 Nothing  -> foundTimeStamp lastMod
 169                                 Just rev -> foundEntity (strongETag $ show rev) lastMod
 170
 171                               outputXmlPage tree entityToXHTML
 172
 173
 174 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
 175 entityToXHTML
 176     = eelem "/"
 177       += ( eelem "html"
 178            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 179            += ( eelem "head"
 180                 += ( eelem "title"
 181                      += getXPathTreesInDoc "/page/@site/text()"
 182                      += txt " - "
 183                      += getXPathTreesInDoc "/page/@name/text()"
 184                    )
 185                 += ( eelem "base"
 186                      += attr "href"
 187                             ( getXPathTreesInDoc "/page/@baseURI/text()" )
 188                    )
 189                 += ( eelem "link"
 190                      += sattr "rel"  "stylesheet"
 191                      += sattr "type" "text/css"
 192                      += attr "href"
 193                             ( txt "./object/"
 194                               <+>
 195                               getXPathTreesInDoc "/page/@styleSheet/text()"
 196                               >>>
 197                               getText
 198                               >>>
 199                               arr encodePageName
 200                               >>>
 201                               mkText
 202                             )
 203                    )
 204               )
 205            += ( eelem "body"
 206                 += ( eelem "div"
 207                      += sattr "class" "header"
 208                    )
 209                 += ( eelem "div"
 210                      += sattr "class" "center"
 211                      += ( eelem "div"
 212                           += sattr "class" "title"
 213                         )
 214                      += ( eelem "div"
 215                           += sattr "class" "body"
 216                           += getXPathTreesInDoc "/page/content/*"
 217                           += ( getXPathTreesInDoc "/page/object"
 218                                `guards`
 219                                eelem "object"
 220                                += attr "data"
 221                                       ( getXPathTreesInDoc "/page/object/@data/text()" )
 222                              )
 223                         )
 224                    )
 225                 += ( eelem "div"
 226                      += sattr "class" "footer"
 227                    )
 228                 += ( eelem "div"
 229                      += sattr "class" "left side-bar"
 230                      += ( eelem "div"
 231                           += sattr "class" "content"
 232                         )
 233                    )
 234                 += ( eelem "div"
 235                      += sattr "class" "right side-bar"
 236                      += ( eelem "div"
 237                           += sattr "class" "content"
 238                         )
 239                    )
 240               )
 241            >>>
 242            uniqueNamespacesFromDeclAndQNames
 243          )