module Rakka.Resource ( runIdempotentA , runXmlA , getEntityType , outputXmlPage , outputXmlPage' , getUserID ) where import Control.Arrow import Control.Arrow.ArrowList import Control.Monad import Control.Monad.Trans import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI hiding (path) import Rakka.Authorization import Rakka.Environment import Rakka.Validation 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 logger :: String logger = "Rakka.Resource" -- "/" ==> "/" -- "/foo" ==> "/foo.html" -- "/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) $ abort MovedPermanently [("Location", uriToString id newURI $ "")] Nothing runIdempotentA :: IOSArrow () (Resource c) -> Resource c runIdempotentA a = do canonicalizeURI [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail >>> constA () >>> a ) rsrc runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c runXmlA env schemaPath a = do inputA <- getInputXmlA env 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) >>> 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 [ (a_validate , v_0) , (a_check_namespaces , v_1) , (a_remove_whitespace, v_0) ] req getFailingReader code headers msg = return $ proc _ -> abortA -< (code, (headers, msg)) getEntityType :: Resource MIMEType getEntityType = do uri <- getRequestURI let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri case lookup ext extMap of Just mType -> return mType Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext) where extMap :: [(String, MIMEType)] extMap = [ ("html", read "application/xhtml+xml") , ( "rdf", read "application/rss+xml" ) , ( "xml", read "text/xml" ) ] outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource () outputXmlPage tree formatters = 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) ] ) output resultStr outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource () outputXmlPage' tree toXHTML = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)] getUserID :: Environment -> Resource (Maybe String) getUserID env = 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