X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource.hs;h=a6fc01f492f1b4fcf27089f80c6e335cadeaee90;hp=26d73897e544cc1ec13d3553913bff5bf214da15;hb=HEAD;hpb=443af4d3304139bb2187a0c726327b9c05829810 diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index 26d7389..a6fc01f 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -1,29 +1,41 @@ +{-# LANGUAGE + Arrows + , DoAndIfThenElse + , UnicodeSyntax + #-} module Rakka.Resource ( runIdempotentA + , runIdempotentA' , runXmlA , getEntityType , outputXmlPage + , outputXmlPage' + , outputXml , getUserID ) where - -import Control.Arrow -import Control.Arrow.ArrowList +import qualified Codec.Binary.UTF8.String as UTF8 +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" @@ -34,27 +46,28 @@ logger = "Rakka.Resource" -- "/foo/" ==> "/foo.html" -- "/foo.bar/" ==> "/foo.bar" -- "/foo.bar" ==> "/foo.bar" -canonicalizeURI :: Resource () -canonicalizeURI - = do uri <- getRequestURI - let newURI = uri { uriPath = "/" ++ joinWith "/" newPath } - newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of - [] -> [] - path -> case break (== '.') $ last path of - (_, "") -> let basePieces = reverse $ tail $ reverse path - lastPiece = last path - in - basePieces ++ [lastPiece ++ ".html"] - (_, _) -> path - when (uri /= newURI) +canonicalizeURI :: URI -> Resource () +canonicalizeURI baseURI + = do rPath <- return . uriPath =<< getRequestURI + let newURI = baseURI { uriPath = uriPath baseURI newPath } + newPath = foldl () "/" newPath' + newPath' = case [x | x <- splitBy (== '/') rPath, x /= ""] of + [] -> [] + path -> case break (== '.') $ last path of + (_, "") -> let basePieces = reverse $ tail $ reverse path + lastPiece = last path + in + basePieces ++ [lastPiece ++ ".html"] + (_, _) -> path + when (rPath /= newPath) $ abort MovedPermanently [("Location", uriToString id newURI $ "")] Nothing -runIdempotentA :: IOSArrow () (Resource c) -> Resource c -runIdempotentA a - = do canonicalizeURI +runIdempotentA :: URI -> IOSArrow () (Resource c) -> Resource c +runIdempotentA baseURI a + = do canonicalizeURI baseURI [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail >>> constA () @@ -64,55 +77,64 @@ 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 +runIdempotentA' :: IOSArrow () (Resource c) -> Resource c +runIdempotentA' a + = do [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail >>> - 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 :: 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) - ] req + return $ readString [ withValidate no + , withCheckNamespaces yes + , withRemoveWS yes + ] (UTF8.decodeString req) getFailingReader code headers msg = return $ proc _ -> abortA -< (code, (headers, msg)) @@ -127,37 +149,56 @@ getEntityType where extMap :: [(String, MIMEType)] extMap = [ ("html", read "application/xhtml+xml") + , ( "rdf", read "application/rss+xml" ) , ( "xml", read "text/xml" ) ] -outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource () -outputXmlPage tree toXHTML - = do mType <- getEntityType +outputXmlPage ∷ XmlTree → [(MIMEType, IOSArrow XmlTree XmlTree)] → Resource () +outputXmlPage tree formatters + = do mType ← getEntityType setContentType mType - let formatter = case mType of - MIMEType "application" "xhtml+xml" _ -> toXHTML - MIMEType "text" "xml" _ -> this - _ -> undefined - [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail - >>> - constA tree - >>> - formatter - >>> - writeDocumentToString [ (a_indent, v_1) ] - ) - output resultStr - - -getUserID :: Environment -> Resource (Maybe String) + let formatter = case lookup mType formatters of + 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 tree + = do setContentType (MIMEType "text" "xml" []) + 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