13 import Control.Arrow.ArrowList
15 import Control.Monad.Trans
16 import Network.HTTP.Lucu
17 import Network.HTTP.Lucu.Utils
18 import Network.URI hiding (path)
19 import Rakka.Authorization
20 import Rakka.Environment
21 import Rakka.Validation
22 import System.FilePath.Posix
23 import System.Log.Logger
24 import Text.XML.HXT.Arrow.ReadDocument
25 import Text.XML.HXT.Arrow.WriteDocument
26 import Text.XML.HXT.DOM.TypeDefs
27 import Text.XML.HXT.DOM.XmlKeywords
31 logger = "Rakka.Resource"
35 -- "/foo" ==> "/foo.html"
36 -- "/foo/" ==> "/foo.html"
37 -- "/foo.bar/" ==> "/foo.bar"
38 -- "/foo.bar" ==> "/foo.bar"
39 canonicalizeURI :: URI -> Resource ()
40 canonicalizeURI baseURI
41 = do rPath <- return . uriPath =<< getRequestURI
42 let newURI = baseURI { uriPath = uriPath baseURI </> newPath }
43 newPath = foldl (</>) "/" newPath'
44 newPath' = case [x | x <- splitBy (== '/') rPath, x /= ""] of
46 path -> case break (== '.') $ last path of
47 (_, "") -> let basePieces = reverse $ tail $ reverse path
50 basePieces ++ [lastPiece ++ ".html"]
52 when (rPath /= newPath)
53 $ abort MovedPermanently
54 [("Location", uriToString id newURI $ "")]
58 runIdempotentA :: URI -> IOSArrow () (Resource c) -> Resource c
59 runIdempotentA baseURI a
60 = do canonicalizeURI baseURI
61 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
70 runIdempotentA' :: IOSArrow () (Resource c) -> Resource c
72 = do [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
81 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
82 runXmlA env schemaPath a
83 = do inputA <- getInputXmlA env schemaPath
84 [rsrc] <- liftIO $ runX ( inputA
86 setErrorMsgHandler False fail
93 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
94 -- Unprocessable Entity になる。入力の型が XML でない時は 415
95 -- Unsupported Media Type を返す。
96 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
97 getInputXmlA env schemaPath
98 = do reader <- getInputReader
99 validator <- getValidator env schemaPath
100 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
104 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
110 getInputReader :: Resource (IOSArrow b XmlTree)
112 = do mimeType <- getContentType
115 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
116 Just (MIMEType "text" "xml" _)
118 Just (MIMEType "application" "xml" _)
121 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
124 = do req <- input defaultLimit
125 liftIO $ debugM logger req
126 return $ readString [ (a_validate , v_0)
127 , (a_check_namespaces , v_1)
128 , (a_remove_whitespace, v_0)
129 ] (UTF8.decodeString req)
130 getFailingReader code headers msg
131 = return $ proc _ -> abortA -< (code, (headers, msg))
134 getEntityType :: Resource MIMEType
136 = do uri <- getRequestURI
137 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
138 case lookup ext extMap of
139 Just mType -> return mType
140 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
142 extMap :: [(String, MIMEType)]
143 extMap = [ ("html", read "application/xhtml+xml")
144 , ( "rdf", read "application/rss+xml" )
145 , ( "xml", read "text/xml" )
149 outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
150 outputXmlPage tree formatters
151 = do mType <- getEntityType
153 let formatter = case lookup mType formatters of
156 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
162 writeDocumentToString [ (a_indent , v_1 )
163 , (a_output_encoding, utf8)
164 , (a_no_xml_pi , v_0 ) ]
169 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
170 outputXmlPage' tree toXHTML
171 = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
174 outputXml :: XmlTree -> Resource ()
176 = do setContentType (MIMEType "text" "xml" [])
177 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
181 writeDocumentToString [ (a_indent , v_1 )
182 , (a_output_encoding, utf8)
183 , (a_no_xml_pi , v_0 ) ]
188 getUserID :: Environment -> Resource (Maybe String)
190 = do auth <- getAuthorization
192 Just (BasicAuthCredential userID password)
193 -> do valid <- isValidPair (envAuthDB env) userID password