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.ArrowList
   8 import           Network.HTTP.Lucu
   9 import           Network.URI
  10 import           Rakka.Environment
  11 import           Rakka.Page
  12 import           Rakka.Resource
  13 import           Rakka.Storage
  14 import           Rakka.Utils
  15 import           Text.XML.HXT.Arrow.XmlArrow
  16 import           Text.XML.HXT.DOM.TypeDefs
  17
  18
  19 {-
  20   [リダイレクトの場合]
  21   HTTP/1.1 302 Found
  22   Location: http://example.org/Destination?from=Source&revision=112
  23
  24   <page site="CieloNegro"
  25         baseURI="http://example.org/"
  26         name="Source"
  27         redirect="Destination"
  28         revision="112"         -- デフォルトでない場合のみ存在
  29         lastModified="2000-01-01T00:00:00" />
  30
  31
  32   [text/* の場合]
  33
  34   <page site="CieloNegro"
  35         baseURI="http://example.org/"
  36         name="Foo/Bar"
  37         type="text/x-rakka"
  38         isTheme="no"        -- text/css の場合のみ存在
  39         isFeed="no"         -- text/x-rakka の場合のみ存在
  40         isLocked="no"
  41         revision="112">     -- デフォルトでない場合のみ存在
  42         lastModified="2000-01-01T00:00:00" />
  43
  44     <summary>
  45         blah blah...
  46     </summary> -- 存在しない場合もある
  47
  48     <otherLang>
  49       <link lang="ja" page="Bar/Baz" />
  50     </otherLang>
  51
  52     <content>
  53       blah blah...
  54     </content>
  55   </page>
  56
  57
  58   [text/* 以外の場合: content 要素の代はりに object 要素]
  59
  60   <object data="/object/Foo/Bar" /> -- data 屬性に URI
  61 -}
  62 handleGet :: Environment -> PageName -> Resource ()
  63 handleGet env name
  64     = let sto = envStorage env
  65       in
  66         runIdempotentA $ proc ()
  67           -> do siteName <- getSiteNameA env -< ()
  68                 baseURI  <- getBaseURIA  env -< ()
  69
  70                 pageM <- getPageA sto -< name
  71                 case pageM of
  72                   Nothing
  73                       -> returnA -< foundNoEntity Nothing
  74
  75                   Just redir@(Redirection _ _ _ _)
  76                       -> do tree <- ( eelem "/"
  77                                       += ( eelem "page"
  78                                            += sattr "site"     siteName
  79                                            += sattr "baseURI"  (uriToString id baseURI "")
  80                                            += sattr "name"     name
  81                                            += sattr "redirect" (redirDest redir)
  82                                            += ( case redirRevision redir of
  83                                                   Nothing  -> none
  84                                                   Just rev -> sattr "revision" (show rev)
  85                                               )
  86                                            += sattr "lastModified" (formatW3CDateTime $ redirLastMod redir)
  87                                          )
  88                                     ) -<< ()
  89                             returnA -< do redirect SeeOther (mkPageURI baseURI name)
  90                                           outputXmlPage tree redirToXHTML
  91
  92
  93 redirToXHTML :: ArrowXml a => a XmlTree XmlTree
  94 redirToXHTML = error "not implemented"