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 hiding (path)
  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 = case mType of
  74                            MIMEType "application" "xhtml+xml" _ -> toXHTML
  75                            MIMEType "text"        "xml"       _ -> this
  76                            _                                    -> undefined
  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