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 System.Log.Logger
19 import Text.XML.HXT.Arrow.ReadDocument
20 import Text.XML.HXT.Arrow.WriteDocument
21 import Text.XML.HXT.Arrow.XmlIOStateArrow
22 import Text.XML.HXT.DOM.TypeDefs
23 import Text.XML.HXT.DOM.XmlKeywords
27 logger = "Rakka.Resource"
31 -- "/foo" ==> "/foo.html"
32 -- "/foo/" ==> "/foo.html"
33 -- "/foo.bar/" ==> "/foo.bar"
34 -- "/foo.bar" ==> "/foo.bar"
35 canonicalizeURI :: Resource ()
37 = do uri <- getRequestURI
38 let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
39 newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
41 path -> case break (== '.') $ last path of
42 (_, "") -> let basePieces = reverse $ tail $ reverse path
45 basePieces ++ [lastPiece ++ ".html"]
48 $ abort MovedPermanently
49 [("Location", uriToString id newURI $ "")]
53 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
56 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
65 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
66 runXmlA env schemaPath a
67 = do inputA <- getInputXmlA env schemaPath
68 [rsrc] <- liftIO $ runX ( inputA
70 setErrorMsgHandler False fail
77 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
78 -- Unprocessable Entity になる。入力の型が XML でない時は 415
79 -- Unsupported Media Type を返す。
80 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
81 getInputXmlA env schemaPath
82 = do reader <- getInputReader
83 validator <- getValidator env schemaPath
84 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
88 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
94 getInputReader :: Resource (IOSArrow b XmlTree)
96 = do mimeType <- getContentType
99 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
100 Just (MIMEType "text" "xml" _)
102 Just (MIMEType "application" "xml" _)
105 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
108 = do req <- input defaultLimit
109 liftIO $ debugM logger req
110 return $ readString [ (a_validate , v_0)
111 , (a_check_namespaces , v_1)
112 , (a_remove_whitespace, v_0)
114 getFailingReader code headers msg
115 = return $ proc _ -> abortA -< (code, (headers, msg))
118 getEntityType :: Resource MIMEType
120 = do uri <- getRequestURI
121 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
122 case lookup ext extMap of
123 Just mType -> return mType
124 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
126 extMap :: [(String, MIMEType)]
127 extMap = [ ("html", read "application/xhtml+xml")
128 , ( "xml", read "text/xml" )
132 outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
133 outputXmlPage tree toXHTML
134 = do mType <- getEntityType
136 let formatter = case mType of
137 MIMEType "application" "xhtml+xml" _ -> toXHTML
138 MIMEType "text" "xml" _ -> this
140 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
146 writeDocumentToString [ (a_indent, v_1) ]