Rakka/Resource.hs

   1 module Rakka.Resource
   2     ( runIdempotentA
   3     , outputXmlPage
   4     )
   5     where
   6
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowList
   9 import           Control.Monad
  10 import           Control.Monad.Trans
  11 import           Network.HTTP.Lucu
  12 import           Network.HTTP.Lucu.Utils
  13 import           Network.URI
  14 import           Text.XML.HXT.Arrow.WriteDocument
  15 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  16 import           Text.XML.HXT.DOM.TypeDefs
  17 import           Text.XML.HXT.DOM.XmlKeywords
  18
  19
  20 -- /         ==> /
  21 -- /foo      ==> /foo.html
  22 -- /foo/     ==> /foo.html
  23 -- /foo.bar/ ==> /foo.bar
  24 -- /foo.bar  ==> /foo.bar
  25 canonicalizeURI :: Resource ()
  26 canonicalizeURI
  27     = do uri <- getRequestURI
  28          let newURI  = uri { uriPath = "/" ++ joinWith "/" newPath }
  29              newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
  30                          []   -> []
  31                          path -> case break (== '.') $ last path of
  32                                    (_, "") -> let basePieces = reverse $ tail $ reverse path
  33                                                   lastPiece  = last path
  34                                               in
  35                                                 basePieces ++ [lastPiece ++ ".html"]
  36                                    (_, _)  -> path
  37          when (uri /= newURI)
  38               $ abort MovedPermanently
  39                 [("Location", uriToString id newURI $ "")]
  40                 Nothing
  41
  42
  43 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
  44 runIdempotentA a
  45     = do canonicalizeURI
  46          [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
  47                                    >>>
  48                                    constA ()
  49                                    >>>
  50                                    a
  51                                  )
  52          rsrc
  53
  54
  55 getEntityType :: Resource MIMEType
  56 getEntityType
  57     = do uri <- getRequestURI
  58          let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
  59          case lookup ext extMap of
  60            Just mType -> return mType
  61            Nothing    -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
  62     where
  63       extMap :: [(String, MIMEType)]
  64       extMap = [ ("html", read "application/xhtml+xml")
  65                , ( "xml", read "text/xml"             )
  66                ]
  67
  68
  69 outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
  70 outputXmlPage tree toXHTML
  71     = do mType <- getEntityType
  72          setContentType mType
  73          let formatter = if mType == read "text/xml" then
  74                              this
  75                          else
  76                              toXHTML
  77          [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  78                                         >>>
  79                                         constA tree
  80                                         >>>
  81                                         formatter
  82                                         >>>
  83                                         writeDocumentToString [ (a_indent, v_1) ]
  84                                       )
  85          output resultStr