13 import qualified Codec.Binary.UTF8.String as UTF8
15 import Control.Arrow.ArrowList
17 import Control.Monad.Trans
18 import Network.HTTP.Lucu
19 import Network.HTTP.Lucu.Utils
20 import Network.URI hiding (path)
21 import Rakka.Authorization
22 import Rakka.Environment
23 import Rakka.Validation
24 import System.FilePath.Posix
25 import System.Log.Logger
26 import Text.XML.HXT.Arrow.ReadDocument
27 import Text.XML.HXT.Arrow.WriteDocument
28 import Text.XML.HXT.Arrow.XmlIOStateArrow
29 import Text.XML.HXT.DOM.TypeDefs
30 import Text.XML.HXT.DOM.XmlKeywords
34 logger = "Rakka.Resource"
38 -- "/foo" ==> "/foo.html"
39 -- "/foo/" ==> "/foo.html"
40 -- "/foo.bar/" ==> "/foo.bar"
41 -- "/foo.bar" ==> "/foo.bar"
42 canonicalizeURI :: URI -> Resource ()
43 canonicalizeURI baseURI
44 = do rPath <- return . uriPath =<< getRequestURI
45 let newURI = baseURI { uriPath = uriPath baseURI </> newPath }
46 newPath = foldl (</>) "/" newPath'
47 newPath' = case [x | x <- splitBy (== '/') rPath, x /= ""] of
49 path -> case break (== '.') $ last path of
50 (_, "") -> let basePieces = reverse $ tail $ reverse path
53 basePieces ++ [lastPiece ++ ".html"]
55 when (rPath /= newPath)
56 $ abort MovedPermanently
57 [("Location", uriToString id newURI $ "")]
61 runIdempotentA :: URI -> IOSArrow () (Resource c) -> Resource c
62 runIdempotentA baseURI a
63 = do canonicalizeURI baseURI
64 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
73 runIdempotentA' :: IOSArrow () (Resource c) -> Resource c
75 = do [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
84 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
85 runXmlA env schemaPath a
86 = do inputA <- getInputXmlA env schemaPath
87 [rsrc] <- liftIO $ runX ( inputA
89 setErrorMsgHandler False fail
96 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
97 -- Unprocessable Entity になる。入力の型が XML でない時は 415
98 -- Unsupported Media Type を返す。
99 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
100 getInputXmlA env schemaPath
101 = do reader <- getInputReader
102 validator <- getValidator env schemaPath
103 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
107 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
113 getInputReader :: Resource (IOSArrow b XmlTree)
115 = do mimeType <- getContentType
118 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
119 Just (MIMEType "text" "xml" _)
121 Just (MIMEType "application" "xml" _)
124 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
127 = do req <- input defaultLimit
128 liftIO $ debugM logger req
129 return $ readString [ (a_validate , v_0)
130 , (a_check_namespaces , v_1)
131 , (a_remove_whitespace, v_0)
132 ] (UTF8.decodeString req)
133 getFailingReader code headers msg
134 = return $ proc _ -> abortA -< (code, (headers, msg))
137 getEntityType :: Resource MIMEType
139 = do uri <- getRequestURI
140 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
141 case lookup ext extMap of
142 Just mType -> return mType
143 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
145 extMap :: [(String, MIMEType)]
146 extMap = [ ("html", read "application/xhtml+xml")
147 , ( "rdf", read "application/rss+xml" )
148 , ( "xml", read "text/xml" )
152 outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
153 outputXmlPage tree formatters
154 = do mType <- getEntityType
156 let formatter = case lookup mType formatters of
159 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
165 writeDocumentToString [ (a_indent , v_1 )
166 , (a_output_encoding, utf8)
167 , (a_no_xml_pi , v_0 ) ]
172 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
173 outputXmlPage' tree toXHTML
174 = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
177 outputXml :: XmlTree -> Resource ()
179 = do setContentType (MIMEType "text" "xml" [])
180 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
184 writeDocumentToString [ (a_indent , v_1 )
185 , (a_output_encoding, utf8)
186 , (a_no_xml_pi , v_0 ) ]
191 getUserID :: Environment -> Resource (Maybe String)
193 = do auth <- getAuthorization
195 Just (BasicAuthCredential userID password)
196 -> do valid <- isValidPair (envAuthDB env) userID password