10 import Control.Arrow.ArrowList
12 import Control.Monad.Trans
13 import Network.HTTP.Lucu
14 import Network.HTTP.Lucu.Utils
15 import Network.URI hiding (path)
16 import Rakka.Environment
17 import Rakka.Validation
18 import Text.XML.HXT.Arrow.ReadDocument
19 import Text.XML.HXT.Arrow.WriteDocument
20 import Text.XML.HXT.Arrow.XmlIOStateArrow
21 import Text.XML.HXT.DOM.TypeDefs
22 import Text.XML.HXT.DOM.XmlKeywords
26 -- "/foo" ==> "/foo.html"
27 -- "/foo/" ==> "/foo.html"
28 -- "/foo.bar/" ==> "/foo.bar"
29 -- "/foo.bar" ==> "/foo.bar"
30 canonicalizeURI :: Resource ()
32 = do uri <- getRequestURI
33 let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
34 newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
36 path -> case break (== '.') $ last path of
37 (_, "") -> let basePieces = reverse $ tail $ reverse path
40 basePieces ++ [lastPiece ++ ".html"]
43 $ abort MovedPermanently
44 [("Location", uriToString id newURI $ "")]
48 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
51 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
60 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
61 runXmlA env schemaPath a
62 = do inputA <- getInputXmlA env schemaPath
63 [rsrc] <- liftIO $ runX ( inputA
65 setErrorMsgHandler False fail
72 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
73 -- Unprocessable Entity になる。入力の型が XML でない時は 415
74 -- Unsupported Media Type を返す。
75 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
76 getInputXmlA env schemaPath
77 = do reader <- getInputReader
78 validator <- getValidator env schemaPath
79 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
83 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
89 getInputReader :: Resource (IOSArrow b XmlTree)
91 = do mimeType <- getContentType
94 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
95 Just (MIMEType "text" "xml" _)
97 Just (MIMEType "application" "xml" _)
100 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
103 = do req <- input defaultLimit
104 return $ readString [ (a_validate , v_0)
105 , (a_check_namespaces , v_1)
106 , (a_remove_whitespace, v_0)
108 getFailingReader code headers msg
109 = return $ proc _ -> abortA -< (code, (headers, msg))
112 getEntityType :: Resource MIMEType
114 = do uri <- getRequestURI
115 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
116 case lookup ext extMap of
117 Just mType -> return mType
118 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
120 extMap :: [(String, MIMEType)]
121 extMap = [ ("html", read "application/xhtml+xml")
122 , ( "xml", read "text/xml" )
126 outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
127 outputXmlPage tree toXHTML
128 = do mType <- getEntityType
130 let formatter = case mType of
131 MIMEType "application" "xhtml+xml" _ -> toXHTML
132 MIMEType "text" "xml" _ -> this
134 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
140 writeDocumentToString [ (a_indent, v_1) ]