+runIdempotentA' :: IOSArrow () (Resource c) -> Resource c
+runIdempotentA' a
+ = do [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA ()
+ >>>
+ a
+ )
+ rsrc
+
+runXmlA ∷ FilePath → IOSArrow XmlTree (Resource c) → Resource c
+runXmlA schemaPath a
+ = do inputA ← getInputXmlA schemaPath
+ [rsrc] ← liftIO $ runX ( inputA
+ ⋙
+ setErrorMsgHandler False fail
+ ⋙
+ a
+ )
+ rsrc
+
+-- well-formed でない時は 400 Bad Request になり、valid でない時は 422
+-- Unprocessable Entity になる。入力の型が XML でない時は 415
+-- Unsupported Media Type を返す。
+getInputXmlA ∷ FilePath → Resource (IOSArrow b XmlTree)
+getInputXmlA schemaPath
+ = do reader ← getInputReader
+ validator ← getValidator schemaPath
+ return ( setErrorMsgHandler False (abort BadRequest [] ∘ Just)
+ ⋙
+ reader
+ ⋙
+ setErrorMsgHandler False (abort UnprocessableEntitiy [] ∘ Just)
+ ⋙
+ validator
+ )
+
+getInputReader ∷ Resource (IOSArrow b XmlTree)
+getInputReader
+ = do mimeType ← getContentType
+ case mimeType of
+ Nothing
+ → getFailingReader BadRequest [] (Just "Missing Content-Type")
+ Just (MIMEType "text" "xml" _)
+ → getXmlReader
+ Just (MIMEType "application" "xml" _)
+ → getXmlReader
+ Just t
+ → getFailingReader UnsupportedMediaType []
+ (Just $ "Unsupported media type: " ⊕ show t)
+ where
+ getXmlReader
+ = do req ← input defaultLimit
+ liftIO $ debugM logger req
+ return $ readString [ withValidate no
+ , withCheckNamespaces yes
+ , withRemoveWS yes
+ ] (UTF8.decodeString req)
+ getFailingReader code headers msg
+ = return $ proc _ -> abortA -< (code, (headers, msg))
+
+