12 import Control.Arrow.ArrowList
14 import Control.Monad.Trans
15 import Network.HTTP.Lucu
16 import Network.HTTP.Lucu.Utils
17 import Network.URI hiding (path)
18 import Rakka.Authorization
19 import Rakka.Environment
20 import Rakka.Validation
21 import System.Log.Logger
22 import Text.XML.HXT.Arrow.ReadDocument
23 import Text.XML.HXT.Arrow.WriteDocument
24 import Text.XML.HXT.Arrow.XmlIOStateArrow
25 import Text.XML.HXT.DOM.TypeDefs
26 import Text.XML.HXT.DOM.XmlKeywords
30 logger = "Rakka.Resource"
34 -- "/foo" ==> "/foo.html"
35 -- "/foo/" ==> "/foo.html"
36 -- "/foo.bar/" ==> "/foo.bar"
37 -- "/foo.bar" ==> "/foo.bar"
38 canonicalizeURI :: Resource ()
40 = do uri <- getRequestURI
41 let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
42 newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
44 path -> case break (== '.') $ last path of
45 (_, "") -> let basePieces = reverse $ tail $ reverse path
48 basePieces ++ [lastPiece ++ ".html"]
51 $ abort MovedPermanently
52 [("Location", uriToString id newURI $ "")]
56 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
59 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
68 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
69 runXmlA env schemaPath a
70 = do inputA <- getInputXmlA env schemaPath
71 [rsrc] <- liftIO $ runX ( inputA
73 setErrorMsgHandler False fail
80 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
81 -- Unprocessable Entity になる。入力の型が XML でない時は 415
82 -- Unsupported Media Type を返す。
83 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
84 getInputXmlA env schemaPath
85 = do reader <- getInputReader
86 validator <- getValidator env schemaPath
87 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
91 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
97 getInputReader :: Resource (IOSArrow b XmlTree)
99 = do mimeType <- getContentType
102 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
103 Just (MIMEType "text" "xml" _)
105 Just (MIMEType "application" "xml" _)
108 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
111 = do req <- input defaultLimit
112 liftIO $ debugM logger req
113 return $ readString [ (a_validate , v_0)
114 , (a_check_namespaces , v_1)
115 , (a_remove_whitespace, v_0)
117 getFailingReader code headers msg
118 = return $ proc _ -> abortA -< (code, (headers, msg))
121 getEntityType :: Resource MIMEType
123 = do uri <- getRequestURI
124 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
125 case lookup ext extMap of
126 Just mType -> return mType
127 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
129 extMap :: [(String, MIMEType)]
130 extMap = [ ("html", read "application/xhtml+xml")
131 , ( "rdf", read "application/rss+xml" )
132 , ( "xml", read "text/xml" )
136 outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
137 outputXmlPage tree formatters
138 = do mType <- getEntityType
140 let formatter = case lookup mType formatters of
143 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
149 writeDocumentToString [ (a_indent, v_1) ]
154 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
155 outputXmlPage' tree toXHTML
156 = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
159 getUserID :: Environment -> Resource (Maybe String)
161 = do auth <- getAuthorization
163 Just (BasicAuthCredential userID password)
164 -> do valid <- isValidPair (envAuthDB env) userID password