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