8 import Control.Arrow.ArrowList
10 import Control.Monad.Trans
11 import Network.HTTP.Lucu
12 import Network.HTTP.Lucu.Utils
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
21 -- "/foo" ==> "/foo.html"
22 -- "/foo/" ==> "/foo.html"
23 -- "/foo.bar/" ==> "/foo.bar"
24 -- "/foo.bar" ==> "/foo.bar"
25 canonicalizeURI :: Resource ()
27 = do uri <- getRequestURI
28 let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
29 newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
31 path -> case break (== '.') $ last path of
32 (_, "") -> let basePieces = reverse $ tail $ reverse path
35 basePieces ++ [lastPiece ++ ".html"]
38 $ abort MovedPermanently
39 [("Location", uriToString id newURI $ "")]
43 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
46 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
55 getEntityType :: Resource MIMEType
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)
63 extMap :: [(String, MIMEType)]
64 extMap = [ ("html", read "application/xhtml+xml")
65 , ( "xml", read "text/xml" )
69 outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
70 outputXmlPage tree toXHTML
71 = do mType <- getEntityType
73 let formatter = case mType of
74 MIMEType "application" "xhtml+xml" _ -> toXHTML
75 MIMEType "text" "xml" _ -> this
76 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
82 writeDocumentToString [ (a_indent, v_1) ]