11 import Control.Arrow.ArrowList
13 import Control.Monad.Trans
14 import Network.HTTP.Lucu
15 import Network.HTTP.Lucu.Utils
16 import Network.URI hiding (path)
17 import Rakka.Authorization
18 import Rakka.Environment
19 import Rakka.Validation
20 import System.Log.Logger
21 import Text.XML.HXT.Arrow.ReadDocument
22 import Text.XML.HXT.Arrow.WriteDocument
23 import Text.XML.HXT.Arrow.XmlIOStateArrow
24 import Text.XML.HXT.DOM.TypeDefs
25 import Text.XML.HXT.DOM.XmlKeywords
29 logger = "Rakka.Resource"
33 -- "/foo" ==> "/foo.html"
34 -- "/foo/" ==> "/foo.html"
35 -- "/foo.bar/" ==> "/foo.bar"
36 -- "/foo.bar" ==> "/foo.bar"
37 canonicalizeURI :: Resource ()
39 = do uri <- getRequestURI
40 let newURI = uri { uriPath = "/" ++ joinWith "/" newPath }
41 newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
43 path -> case break (== '.') $ last path of
44 (_, "") -> let basePieces = reverse $ tail $ reverse path
47 basePieces ++ [lastPiece ++ ".html"]
50 $ abort MovedPermanently
51 [("Location", uriToString id newURI $ "")]
55 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
58 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
67 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
68 runXmlA env schemaPath a
69 = do inputA <- getInputXmlA env schemaPath
70 [rsrc] <- liftIO $ runX ( inputA
72 setErrorMsgHandler False fail
79 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
80 -- Unprocessable Entity になる。入力の型が XML でない時は 415
81 -- Unsupported Media Type を返す。
82 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
83 getInputXmlA env schemaPath
84 = do reader <- getInputReader
85 validator <- getValidator env schemaPath
86 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
90 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
96 getInputReader :: Resource (IOSArrow b XmlTree)
98 = do mimeType <- getContentType
101 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
102 Just (MIMEType "text" "xml" _)
104 Just (MIMEType "application" "xml" _)
107 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
110 = do req <- input defaultLimit
111 liftIO $ debugM logger req
112 return $ readString [ (a_validate , v_0)
113 , (a_check_namespaces , v_1)
114 , (a_remove_whitespace, v_0)
116 getFailingReader code headers msg
117 = return $ proc _ -> abortA -< (code, (headers, msg))
120 getEntityType :: Resource MIMEType
122 = do uri <- getRequestURI
123 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
124 case lookup ext extMap of
125 Just mType -> return mType
126 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
128 extMap :: [(String, MIMEType)]
129 extMap = [ ("html", read "application/xhtml+xml")
130 , ( "xml", read "text/xml" )
134 outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
135 outputXmlPage tree toXHTML
136 = do mType <- getEntityType
138 let formatter = case mType of
139 MIMEType "application" "xhtml+xml" _ -> toXHTML
140 MIMEType "text" "xml" _ -> this
142 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
148 writeDocumentToString [ (a_indent, v_1) ]
153 getUserID :: Environment -> Resource (Maybe String)
155 = do auth <- getAuthorization
157 Just (BasicAuthCredential userID password)
158 -> do valid <- isValidPair (envAuthDB env) userID password