Rakka/Resource/Page/Get.hs

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