+module Rakka.Resource
+ ( runIdempotentA
+ , outputXmlPage
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Monad
+import Control.Monad.Trans
+import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Utils
+import Network.URI
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+-- / ==> /
+-- /foo ==> /foo.html
+-- /foo/ ==> /foo.html
+-- /foo.bar/ ==> /foo.bar
+-- /foo.bar ==> /foo.bar
+canonicalizeURI :: Resource ()
+canonicalizeURI
+ = do uri <- getRequestURI
+ let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
+ newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
+ [] -> []
+ path -> case break (== '.') $ last path of
+ (_, "") -> let basePieces = reverse $ tail $ reverse path
+ lastPiece = last path
+ in
+ basePieces ++ [lastPiece ++ ".html"]
+ (_, _) -> path
+ when (uri /= newURI)
+ $ abort MovedPermanently
+ [("Location", uriToString id newURI $ "")]
+ Nothing
+
+
+runIdempotentA :: IOSArrow () (Resource c) -> Resource c
+runIdempotentA a
+ = do canonicalizeURI
+ [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA ()
+ >>>
+ a
+ )
+ rsrc
+
+
+getEntityType :: Resource MIMEType
+getEntityType
+ = do uri <- getRequestURI
+ let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
+ case lookup ext extMap of
+ Just mType -> return mType
+ Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
+ where
+ extMap :: [(String, MIMEType)]
+ extMap = [ ("html", read "application/xhtml+xml")
+ , ( "xml", read "text/xml" )
+ ]
+
+
+outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
+outputXmlPage tree toXHTML
+ = do mType <- getEntityType
+ setContentType mType
+ let formatter = if mType == read "text/xml" then
+ this
+ else
+ toXHTML
+ [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA tree
+ >>>
+ formatter
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ output resultStr
\ No newline at end of file