X-Git-Url: https://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource.hs;fp=Rakka%2FResource.hs;h=a6fc01f492f1b4fcf27089f80c6e335cadeaee90;hp=c589cecceb1cea38f9ada43cc13b73b6eb7d4ebd;hb=42f51754dea02201aececaacbf194d714cd58aaf;hpb=98fd1cb53a837a9bda7145544c34872acb13a634 diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index c589cec..a6fc01f 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + Arrows + , DoAndIfThenElse + , UnicodeSyntax + #-} module Rakka.Resource ( runIdempotentA , runIdempotentA' @@ -9,26 +14,28 @@ module Rakka.Resource , getUserID ) where - import qualified Codec.Binary.UTF8.String as UTF8 -import Control.Arrow -import Control.Arrow.ArrowList +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ListArrow +import Control.Arrow.Unicode import Control.Monad import Control.Monad.Trans +import Data.Monoid.Unicode +import qualified Data.Text as T import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI hiding (path) +import Prelude.Unicode import Rakka.Authorization import Rakka.Environment import Rakka.Validation import System.FilePath.Posix import System.Log.Logger -import Text.XML.HXT.Arrow.ReadDocument -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.DOM.TypeDefs -import Text.XML.HXT.DOM.XmlKeywords - +import Text.XML.HXT.Arrow.ReadDocument +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.Arrow.XmlState logger :: String logger = "Rakka.Resource" @@ -80,55 +87,53 @@ runIdempotentA' a ) rsrc - -runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c -runXmlA env schemaPath a - = do inputA <- getInputXmlA env schemaPath - [rsrc] <- liftIO $ runX ( inputA - >>> +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 :: Environment -> FilePath -> Resource (IOSArrow b XmlTree) -getInputXmlA env schemaPath - = do reader <- getInputReader - validator <- getValidator env schemaPath - return ( setErrorMsgHandler False (abort BadRequest [] . Just) - >>> +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) - >>> + ⋙ + setErrorMsgHandler False (abort UnprocessableEntitiy [] ∘ Just) + ⋙ validator ) - -getInputReader :: Resource (IOSArrow b XmlTree) +getInputReader ∷ Resource (IOSArrow b XmlTree) getInputReader - = do mimeType <- getContentType + = do mimeType ← getContentType case mimeType of Nothing - -> getFailingReader BadRequest [] (Just "Missing Content-Type") + → getFailingReader BadRequest [] (Just "Missing Content-Type") Just (MIMEType "text" "xml" _) - -> getXmlReader + → getXmlReader Just (MIMEType "application" "xml" _) - -> getXmlReader + → getXmlReader Just t - -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t) + → getFailingReader UnsupportedMediaType [] + (Just $ "Unsupported media type: " ⊕ show t) where getXmlReader - = do req <- input defaultLimit + = do req ← input defaultLimit liftIO $ debugM logger req - return $ readString [ (a_validate , v_0) - , (a_check_namespaces , v_1) - , (a_remove_whitespace, v_0) + return $ readString [ withValidate no + , withCheckNamespaces yes + , withRemoveWS yes ] (UTF8.decodeString req) getFailingReader code headers msg = return $ proc _ -> abortA -< (code, (headers, msg)) @@ -149,53 +154,51 @@ getEntityType ] -outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource () +outputXmlPage ∷ XmlTree → [(MIMEType, IOSArrow XmlTree XmlTree)] → Resource () outputXmlPage tree formatters - = do mType <- getEntityType + = do mType ← getEntityType setContentType mType let formatter = case lookup mType formatters of - Just f -> f - Nothing -> this - [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail - >>> - constA tree - >>> - formatter - >>> - writeDocumentToString [ (a_indent , v_1 ) - , (a_output_encoding, utf8) - , (a_no_xml_pi , v_0 ) ] - ) - output resultStr - + Just f → f + Nothing → this + [resultStr] ← liftIO $ + runX ( setErrorMsgHandler False fail + >>> + constA tree + >>> + formatter + >>> + writeDocumentToString + [ withIndent yes + , withXmlPi yes + ] + ) + output $ UTF8.encodeString resultStr outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource () outputXmlPage' tree toXHTML = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)] - -outputXml :: XmlTree -> Resource () +outputXml ∷ XmlTree → Resource () outputXml tree = do setContentType (MIMEType "text" "xml" []) - [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail - >>> - constA tree - >>> - writeDocumentToString [ (a_indent , v_1 ) - , (a_output_encoding, utf8) - , (a_no_xml_pi , v_0 ) ] - ) - output xmlStr - - -getUserID :: Environment -> Resource (Maybe String) + let [xmlStr] = runLA ( writeDocumentToString + [ withIndent yes + , withXmlPi yes + ] + ) tree + output $ UTF8.encodeString xmlStr + +getUserID ∷ Environment → Resource (Maybe String) getUserID env - = do auth <- getAuthorization + = do auth ← getAuthorization case auth of Just (BasicAuthCredential userID password) - -> do valid <- isValidPair (envAuthDB env) userID password - if valid then - return (Just userID) - else - return Nothing - _ -> return Nothing + → do valid ← isValidPair (envAuthDB env) + (T.pack userID) + (T.pack password) + if valid then + return (Just userID) + else + return Nothing + _ → return Nothing