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     <content>
  93       blah blah...
  94     </content>
  95   </page>
  96 -}
  97 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
  98 handleGetEntity env
  99     = let sysConf = envSysConf env
 100       in
 101         proc page
 102           -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
 103                 BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
 104                 StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
 105
 106                 tree <- ( eelem "/"
 107                           += ( eelem "page"
 108                                += sattr "site"       siteName
 109                                += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
 110                                += sattr "name"       (pageName page)
 111                                += sattr "type"       (show $ pageType page)
 112                                += ( case pageType page of
 113                                       MIMEType "text" "css" _
 114                                           -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
 115                                       _   -> none
 116                                   )
 117                                += ( case pageType page of
 118                                       MIMEType "text" "x-rakka" _
 119                                           -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
 120                                       _   -> none
 121                                   )
 122                                += sattr "isLocked" (yesOrNo $ pageIsLocked page)
 123                                += ( case pageRevision page of
 124                                       Nothing  -> none
 125                                       Just rev -> sattr "revision" (show rev)
 126                                   )
 127                                += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
 128
 129                                += ( case pageSummary page of
 130                                       Nothing -> none
 131                                       Just s  -> eelem "summary" += txt s
 132                                   )
 133
 134                                += ( case pageOtherLang page of
 135                                       [] -> none
 136                                       xs -> selem "otherLang"
 137                                             [ eelem "link"
 138                                               += sattr "lang" lang
 139                                               += sattr "page" page
 140                                                   | (lang, page) <- xs ]
 141                                   )
 142                                += ( eelem "content"
 143                                     += (constA page >>> formatPage env )
 144                                   )
 145                                >>>
 146                                uniqueNamespacesFromDeclAndQNames
 147                              )
 148                         ) -<< ()
 149
 150                 returnA -< do let lastMod = toClockTime $ pageLastMod page
 151
 152                               case pageRevision page of
 153                                 Nothing  -> foundTimeStamp lastMod
 154                                 Just rev -> foundEntity (strongETag $ show rev) lastMod
 155
 156                               outputXmlPage tree entityToXHTML
 157
 158
 159 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
 160 entityToXHTML
 161     = eelem "/"
 162       += ( eelem "html"
 163            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 164            += ( eelem "head"
 165                 += ( eelem "title"
 166                      += getXPathTreesInDoc "/page/@site/text()"
 167                      += txt " - "
 168                      += getXPathTreesInDoc "/page/@name/text()"
 169                    )
 170                 += ( eelem "link"
 171                      += sattr "rel"  "stylesheet"
 172                      += sattr "type" "text/css"
 173                      += attr "href"
 174                             ( getXPathTreesInDoc "/page/@styleSheet/text()" )
 175                    )
 176               )
 177            += ( eelem "body"
 178                 += ( eelem "div"
 179                      += sattr "class" "header"
 180                    )
 181                 += ( eelem "div"
 182                      += sattr "class" "center"
 183                      += ( eelem "div"
 184                           += sattr "class" "title"
 185                         )
 186                      += ( eelem "div"
 187                           += sattr "class" "body"
 188                           += getXPathTreesInDoc "/page/content/*"
 189                         )
 190                    )
 191                 += ( eelem "div"
 192                      += sattr "class" "footer"
 193                    )
 194                 += ( eelem "div"
 195                      += sattr "class" "left side-bar"
 196                      += ( eelem "div"
 197                           += sattr "class" "content"
 198                         )
 199                    )
 200                 += ( eelem "div"
 201                      += sattr "class" "right side-bar"
 202                      += ( eelem "div"
 203                           += sattr "class" "content"
 204                         )
 205                    )
 206               )
 207            >>>
 208            uniqueNamespacesFromDeclAndQNames
 209          )